add fv translation

Author: rsoeldner

docs/en/pact-properties-api.md

@@ -814,6 +814,19 @@ BLAKE2b 256-bit hash of lists
 
 Supported in properties only.
 
+### keccak {#FKeccak256Hash}
+
+```lisp
+(keccak256 xs)
+```
+
+* takes `xs`: [`string`]
+* produces `string`
+
+Compute the hash of a list of base64-encoded inputs. The hash is computed incrementally over all of the base64-decoded inputs.
+
+Supported in properties only.
+
 ## String operators {#String}
 
 ### length {#FStringLength}

src-tool/Pact/Analyze/Eval/Core.hs

@@ -47,9 +47,11 @@ import Pact.Types.Util (AsString(asString))
 import Data.Text.Encoding (encodeUtf8)
 import qualified Pact.Types.Lang as Pact
 import qualified Pact.Types.PactValue as Pact
+import Crypto.Hash.Keccak256Native
 import qualified Data.ByteString as BS
 import Data.Functor ((<&>))
 import qualified Data.Vector as V
+import Data.Default
 
 import qualified Pact.JSON.Encode as J
 
@@ -312,6 +314,17 @@ evalCore (ListHash ty' xs) = do
       SList t' -> Pact.PList . V.fromList <$> traverse (reify t') c
       _ -> throwErrorNoLoc (FailureMessage "Unsupported type, currently we support integer, decimal, string, and bool")
 
+evalCore (Keccak256Hash xs) = eval xs <&> unliteralS >>= \case
+    Nothing ->do
+      -- (keccak256 [])
+      let h = "xdJGAYb3IzySfn2y3McDwOUAtlPKgic7e/rYBF2FpHA="
+      emitWarning (FVShimmedStaticContent "keccac256" ("of type '[string]', substitute '" <> T.pack h <> "')"))
+      pure (literalS (Str h))
+    Just (xs':: [Str]) -> do
+      let tm = fmap (\x -> Pact.TLiteral (Pact.LString $ T.pack $ unStr x) def) xs'
+          h = keccak256 (V.fromList tm)
+      pure (literalS . Str . T.unpack $ h)
+
 evalCore (ListContains ty needle haystack) = withSymVal ty $ do
   S _ needle'   <- withSing ty $ eval needle
   S _ haystack' <- withSing ty $ eval haystack

src-tool/Pact/Analyze/Feature.hs

@@ -133,6 +133,7 @@ data Feature
   | FNumericalHash
   | FBoolHash
   | FListHash
+  | FKeccak256Hash
   -- Temporal operators
   | FTemporalAddition
   | FTemporalDiff
@@ -1303,6 +1304,21 @@ doc FListHash = Doc
         ]
       (TyCon str)
   ]
+doc FKeccak256Hash = Doc
+  "keccak"
+  CList
+  PropOnly
+  "Compute the hash of a list of base64-encoded inputs. The hash is computed incrementally over all of the base64-decoded inputs."
+  [ Usage
+      "(keccak256 xs)"
+      Map.empty
+      $ Fun
+        Nothing
+        [ ("xs", TyList' (TyCon str))
+        ]
+      (TyCon str)
+  ]
+
 -- Temporal features
 
 doc FTemporalAddition = Doc
@@ -1894,6 +1910,7 @@ PAT(SStringHash, FStringHash)
 PAT(SNumericalHash, FNumericalHash)
 PAT(SBoolHash, FBoolHash)
 PAT(SListHash, FListHash)
+PAT(SKeccak256Hash, FKeccak256Hash)
 PAT(STemporalAddition, FTemporalAddition)
 PAT(STemporalDiff, FTemporalDiff)
 PAT(SUniversalQuantification, FUniversalQuantification)

src-tool/Pact/Analyze/Patterns.hs

@@ -189,6 +189,10 @@ pattern AST_ParseTime formatStr timeStr <-
 pattern AST_Hash :: forall a. AST a -> AST a
 pattern AST_Hash val <- App _node (NativeFunc "hash") [val]
 
+pattern AST_Keccak :: forall a. AST a -> AST a
+pattern AST_Keccak val <- App _node (NativeFunc "keccak256") [val]
+
+
 pattern AST_AddTime :: forall a. AST a -> AST a -> AST a
 pattern AST_AddTime time seconds <- App _ (NativeFunc STemporalAddition) [time, seconds]
 

src-tool/Pact/Analyze/PrenexNormalize.hs

@@ -109,6 +109,7 @@ singFloat ty p = case p of
   CoreProp (BoolHash s) -> CoreProp . BoolHash <$> float s
   CoreProp (DecHash s)  -> CoreProp . DecHash  <$> float s
   CoreProp (ListHash ty' s) -> CoreProp . ListHash ty' <$> singFloat (SList ty') s
+  CoreProp (Keccak256Hash s) -> CoreProp . Keccak256Hash <$> float s
   -- time
   CoreProp (IntAddTime time int) -> PIntAddTime <$> float time <*> float int
   CoreProp (DecAddTime time dec) -> PDecAddTime <$> float time <*> float dec

src-tool/Pact/Analyze/Translate.hs

@@ -1007,7 +1007,7 @@ translateNode astNode = withAstContext astNode $ case astNode of
       notStaticShim = do
         addWarning' (UnsupportedNonFatal "Call to `hash` is only implemented for string, bool, and integer, substituting hash of `hello pact`")
         wrap (StrHash (Lit' (Str "hello pact")))
-    
+
     case ty of
       SStr       -> wrap (StrHash val')
       SBool      -> wrap (BoolHash val')
@@ -1022,6 +1022,10 @@ translateNode astNode = withAstContext astNode $ case astNode of
         _otherwise ->  notStaticShim
       _otherwise -> notStaticShim
 
+  AST_Keccak val -> translateNode val >>= \case
+    Some (SList SStr) val' -> pure $ Some SStr $ CoreTerm $ Keccak256Hash val'
+    _ -> unexpectedNode astNode
+
   AST_ReadKeyset nameA -> translateNode nameA >>= \case
     Some SStr nameT -> return $ Some SGuard $ ReadKeySet nameT
     _ -> unexpectedNode astNode

src-tool/Pact/Analyze/Types/Languages.hs

@@ -213,6 +213,9 @@ data Core (t :: Ty -> K.Type) (a :: Ty) where
   DecHash      :: t 'TyDecimal -> Core t 'TyStr
   ListHash     :: SingTy a -> t ('TyList a) -> Core t 'TyStr
 
+  -- | Keccak256 hash
+  Keccak256Hash :: t ('TyList 'TyStr) -> Core t 'TyStr
+
   Enumerate :: t 'TyInteger -> t 'TyInteger -> t 'TyInteger -> Core t ('TyList 'TyInteger)
 
   -- numeric ops
@@ -765,6 +768,7 @@ showsPrecCore ty p core = showParen (p > 10) $ case core of
   BoolHash a       -> showString "BoolHash "     . showsTm 11 a
   DecHash a        -> showString "DecimalHash "  . showsTm 11 a
   ListHash ty' a   -> showString "ListHash "     . showsPrec 11 ty' . showChar ' ' . singShowsTmList ty' 11 a
+  Keccak256Hash a  -> showString "Keccak256"     . showsTm 11 a
   Enumerate a b c  -> showString "Enumerate "    . showsTm 11 a . showChar ' ' . showsTm 11 b . showChar ' ' . showsTm 11 c
   Numerical a      -> showString "Numerical "    . showsNumerical ty 11 a
   IntAddTime a b   -> showString "IntAddTime "   . showsTm 11 a . showChar ' ' . showsTm 11 b
@@ -1024,7 +1028,7 @@ prettyCore ty = \case
   BoolHash x               -> parensSep [pretty SBoolHash, prettyTm x]
   DecHash x                -> parensSep [pretty SNumericalHash, prettyTm x]
   ListHash ty' x           -> parensSep [pretty SListHash, singPrettyTmList ty' x]
-
+  Keccak256Hash x          -> parensSep [pretty SKeccak256Hash, prettyTm x]
   Enumerate x y z          -> parensSep [pretty SEnumerate, prettyTm x, prettyTm y, prettyTm z]
   Numerical tm             -> prettyNumerical ty tm
   IntAddTime x y           -> parensSep [pretty STemporalAddition, prettyTm x, prettyTm y]
@@ -1911,6 +1915,8 @@ propToInvariant (CoreProp core) = CoreInvariant <$> case core of
     BoolHash <$> f tm1
   ListHash ty tm1 ->
     ListHash ty <$> f tm1
+  Keccak256Hash tm ->
+    Keccak256Hash <$> f tm
   Enumerate tm1 tm2 tm3 ->
     Enumerate <$> f tm1 <*> f tm2 <*> f tm3
   Numerical num ->

tests/AnalyzeSpec.hs

@@ -2814,6 +2814,23 @@ spec = describe "analyze" $ do
           |]
     expectPass code $ Valid Success'
 
+  describe "keccak256" $ do
+    let code =
+          [text|
+            (defun test:bool (arg:[string])
+           ;;   (enforce (=
+           ;;     (keccak256 [""])
+           ;;     "xdJGAYb3IzySfn2y3McDwOUAtlPKgic7e/rYBF2FpHA=") "should match empty")
+
+               (enforce (=
+                 (keccak256 [""])
+                 (keccak256 arg)) "should match empty")
+
+
+            )
+          |]
+    expectPass code $ Valid Success'
+
   describe "validate-principal" $ do
     let code =
          [text| (defun test:bool (ks: keyset)