Merge pull request #3 from input-output-hk/feat/plustan-04

feat: add plustan-04

Author: RSoulatIOHK

src/Stan/Inspection/AntiPattern.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 {- |
 Copyright: (c) 2020 Kowainik
@@ -50,6 +51,7 @@ module Stan.Inspection.AntiPattern
     , plustan01
     , plustan02
     , plustan03
+    , plustan04
     -- * All inspections
     , antiPatternInspectionsMap
     ) where
@@ -60,7 +62,7 @@ import Relude.Extra.Tuple (fmapToFst)
 import Stan.Core.Id (Id (..))
 import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap, categoryL,
                         descriptionL, severityL, solutionL)
-import Stan.NameMeta (NameMeta (..), baseNameFrom, mkBaseFoldableMeta, mkBaseOldListMeta,
+import Stan.NameMeta (ghcPrimNameFrom, NameMeta (..), baseNameFrom, mkBaseFoldableMeta, mkBaseOldListMeta,
                       primTypeMeta, textNameFrom, unorderedNameFrom, _nameFrom, plutusTxNameFrom)
 import Stan.Pattern.Ast (Literal (..), PatternAst (..), anyNamesToPatternAst, app,
                          namesToPatternAst, opApp, range)
@@ -69,6 +71,8 @@ import Stan.Pattern.Type (PatternType, charPattern, foldableMethodsPatterns, fol
                           listPattern, stringPattern, textPattern, (|->), (|::))
 import Stan.Severity (Severity (..))
 
+import Stan.Core.ModuleName
+
 import qualified Data.List.NonEmpty as NE
 import qualified Stan.Category as Category
 
@@ -95,6 +99,7 @@ antiPatternInspectionsMap = fromList $ fmapToFst inspectionId
     , plustan01
     , plustan02
     , plustan03
+    , plustan04
     ]
 
 -- | Smart constructor to create anti-pattern 'Inspection'.
@@ -452,3 +457,40 @@ plustan03 = mkAntiPatternInspection (Id "PLU-STAN-03") "No usage of Optional typ
   where
     useOfFromMaybe :: NameMeta
     useOfFromMaybe = "fromMaybe" `plutusTxNameFrom` "PlutusTx.Maybe"
+
+plustan04 :: Inspection
+plustan04 = mkAntiPatternInspection (Id "PLU-STAN-04") "Usage of eq instance of ScriptHash/PublicKeyHash/Credential"
+    (FindAst pat)
+    & descriptionL .~ "Usage of eq instance of script-hash / pubkeyhash / payment credential "
+    & solutionL .~
+        [ "Potential staking value theft might want to prefer eq comparison of address" ]
+    & severityL .~ Warning
+  where
+
+    opNames :: [NameMeta]
+    opNames = map opName ["<", "<=", "==", ">", ">="]
+
+    pat = foldl' (\acc x -> acc ||| PatternAstName x fun)
+               (PatternAstNeg PatternAstAnything) opNames
+
+    fun :: PatternType
+    fun = (publicKeyHashPattern ||| scriptHashPattern ||| credentialPattern)
+          |-> (?) |-> (?)
+
+    opName :: Text -> NameMeta
+    opName = (`ghcPrimNameFrom` "GHC.Classes")
+
+    publicKeyHashPattern :: PatternType
+    publicKeyHashPattern = ledgerApiTypePattern "PubKeyHash" "Crypto"
+
+    scriptHashPattern :: PatternType
+    scriptHashPattern = ledgerApiTypePattern "ScriptHash" "Scripts"
+
+    credentialPattern :: PatternType
+    credentialPattern = ledgerApiTypePattern "Credential" "Credential"
+
+    ledgerApiTypePattern name moduleSuffix = NameMeta
+        { nameMetaName       = name
+        , nameMetaModuleName = ModuleName $ "PlutusLedgerApi.V1." <> moduleSuffix
+        , nameMetaPackage    = "plutus-ledger-api"
+        } |:: []

stan.cabal

@@ -176,6 +176,7 @@ library target
                      , text
                      , unordered-containers
                      , plutus-tx ^>=1.29
+                     , plutus-ledger-api ^>=1.29
 
   exposed-modules:     Target.AntiPattern
                          Target.AntiPattern.Stan0206
@@ -220,6 +221,9 @@ test-suite stan-test
                      , tomland
                      , trial
                      , unordered-containers
+                     -- This should be removed after the reserach is done
+                     , pretty-show
+                     , pretty-simple
 
   ghc-options:         -threaded
                        -rtsopts

target/Target/PlutusTx.hs

@@ -16,7 +16,7 @@ import qualified PlutusTx.AssocMap as AssocMap
 import PlutusTx (UnsafeFromData(unsafeFromBuiltinData))
 
 -- Place for future imports
---
+import PlutusLedgerApi.V1 (PubKeyHash(..),Credential(..),ScriptHash(..))
 --
 --
 --
@@ -36,6 +36,31 @@ unsafeFromBuiltinData :: Integer
 unsafeFromBuiltinData =
   Tx.unsafeFromBuiltinData (error "we don't care")
 
-fromMaybe01 :: Integer
-fromMaybe01 =
-  Maybe.fromMaybe 2 (Just 1)
+usageOfPTxMaybe :: Integer
+usageOfPTxMaybe = let
+  x = Maybe.fromMaybe 0 (Maybe.Just 1)
+  in x
+
+pubKeyHashEq :: Bool
+pubKeyHashEq = pubKeyHash == pubKeyHash
+  where
+    pubKeyHash :: PubKeyHash
+    pubKeyHash = error "we don't care"
+
+scriptHashEq :: Bool
+scriptHashEq = scriptHash == scriptHash
+  where
+    scriptHash :: ScriptHash
+    scriptHash = error "we don't care"
+
+credentialHashEq :: Bool
+credentialHashEq = credentialHash == credentialHash
+  where
+    credentialHash :: Credential
+    credentialHash = error "we don't care"
+
+credentialHashLe :: Bool
+credentialHashLe = credentialHash < credentialHash
+  where
+    credentialHash :: Credential
+    credentialHash = error "we don't care"

test/Test/Stan/Analysis.hs

@@ -18,6 +18,9 @@ import Test.Stan.Analysis.Partial (analysisPartialSpec)
 import Test.Stan.Analysis.Style (analysisStyleSpec)
 
 import qualified Data.Set as Set
+--import qualified GHC.Prelude as Prel
+--import GHC.IO (unsafePerformIO)
+--import Text.Pretty.Simple (pPrint)
 
 
 analysisSpec :: [HieFile] -> Spec
@@ -26,6 +29,7 @@ analysisSpec hieFiles = describe "Static Analysis" $ do
     let checksMap = mkDefaultChecks (map hie_hs_file hieFiles)
 
     -- tests without ignorance
+    --(Just myFile) = find ((== "target/Target/PlutusTx.hs") . hie_hs_file) hieFiles
     let analysis = runAnalysis extensionsMap checksMap [] hieFiles
     analysisPartialSpec analysis
     analysisInfiniteSpec analysis

test/Test/Stan/Analysis/PlutusTx.hs

@@ -14,16 +14,25 @@ analysisPlutusTxSpec :: Analysis -> Spec
 analysisPlutusTxSpec analysis = describe "Plutus-Tx" $ do
     let checkObservation = observationAssert ["PlutusTx"] analysis
 
-    --it "PLU-STAN-0X: no variable named foo" $
-        --checkObservation AntiPattern.dummyFooStan01 37 3 6
-
     it "PLU-STAN-01: PlutusTx.AssocMap unsafeFromList" $
         checkObservation AntiPattern.plustan01 33 12 35
 
     it "PLU-STAN-02: PlutusTx.UnsafeFromData unsafeFromBuiltinData" $
         checkObservation AntiPattern.plustan02 37 3 27
 
     it "PLU-STAN-03: No usage of Optional types in on-chain code" $
-        checkObservation AntiPattern.plustan03 41 3 18
+        checkObservation AntiPattern.plustan03 41 7 22
+
+    it "PLU-STAN-04: == on pubKeyHash" $
+        checkObservation AntiPattern.plustan04 45 27 29
+
+    it "PLU-STAN-04: == on scriptHash" $
+        checkObservation AntiPattern.plustan04 51 27 29
+
+    it "PLU-STAN-04: == on credentialHash" $
+        checkObservation AntiPattern.plustan04 57 35 37
+
+    it "PLU-STAN-04: < on credentialHash" $
+        checkObservation AntiPattern.plustan04 63 35 36