Add jose for verifying signatures (temporary, WIP, etc)

gas-prices.csv

@@ -25,6 +25,7 @@ add-time,3
 and,1
 and?,1
 at,2
+base64-concat,5
 base64-decode,1
 base64-encode,1
 bind,4
@@ -102,6 +103,7 @@ resume,2
 reverse,2
 round,1
 select,24
+sha-256,5
 shift,1
 sort,2
 sqrt,6
@@ -116,6 +118,7 @@ typeof,2
 update,25
 use,3
 validate-keypair,29
+verify-signature-jwk,30
 where,2
 with-capability,2
 with-default-read,14
@@ -124,4 +127,4 @@ write,25
 xor,1
 yield,2
 |,1
-~,1
+~,1

pact.cabal

@@ -74,6 +74,7 @@ library
       cbits/musl/sqrt_data.c
     exposed-modules:
       Pact.Native.Trans.TOps
+    build-depends: hashes
   exposed-modules:
     Crypto.Hash.Blake2Native
     Pact.Analyze.Remote.Types
@@ -228,12 +229,14 @@ library
       Pact.PersistPactDb.Regression
       Pact.Server.PactService
       Pact.Types.Crypto
+      Pact.Native.Crypto
       Pact.Types.ECDSA
       Pact.Types.Server
       Pact.Types.SQLite
     build-depends:
       , criterion >= 1.1.4 && < 1.6
       , cryptonite
+      , jose
       , direct-sqlite == 2.3.27
       , memory
       , safe-exceptions >= 0.1.5.0 && < 0.2

src/Pact/Gas/Table.hs

@@ -87,6 +87,7 @@ defaultGasTable =
   ,("and", 1)
   ,("and?", 1)
   ,("at", 2)
+  ,("base64-concat", 5)
   ,("base64-decode", 1)
   ,("base64-encode", 1)
   ,("bind", 4)
@@ -159,6 +160,7 @@ defaultGasTable =
   ,("resume", 2)
   ,("reverse", 2)
   ,("round", 1)
+  ,("sha-256", 5)
   ,("shift", 1)
   ,("sort", 2)
   ,("sqrt", 6)
@@ -173,6 +175,7 @@ defaultGasTable =
   ,("distinct", 2)
   ,("validate-keypair", 29)
   ,("validate-principal", 1)
+  ,("verify-signature-jwk", 30)
   ,("verify-spv", 100) -- deprecated
   ,("where", 2)
   ,("with-capability", 2)

src/Pact/Native.hs

@@ -86,6 +86,7 @@ import Numeric
 
 import Pact.Eval
 import Pact.Native.Capabilities
+import Pact.Native.Crypto
 import Pact.Native.Db
 import Pact.Native.Decrypt
 import Pact.Native.Guards
@@ -119,6 +120,7 @@ natives =
   , decryptDefs
   , guardDefs
   , zkDefs
+  , cryptoDefs
   ]
 
 

src/Pact/Native/Crypto.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Pact.Native.Crypto where
+
+import Control.Lens
+import Control.Monad.Except
+import Data.Aeson
+import Data.Foldable
+import Data.Hash.SHA2
+import Data.ByteString(ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Short as SBS
+import Data.Text.Encoding
+
+import Pact.Native.Internal
+import Pact.Types.Runtime
+
+import Crypto.JOSE.Error
+import Crypto.JOSE.JWA.JWS
+import Crypto.JOSE.JWK
+
+decodeBase64UrlUnpaddedFatal :: ByteString -> ByteString
+decodeBase64UrlUnpaddedFatal = either error id . decodeBase64UrlUnpadded
+
+cryptoDefs :: NativeModule
+cryptoDefs =
+    ("Crypto",
+    [ verifySignatureDef, sha256Def, base64ConcatDef ])
+    where
+    verifySignatureDef = defRNative "verify-signature-jwk" verifySignature (funType tTyBool [("message", tTyString), ("sig", tTyString), ("pubkey-jwk", tTyString)]) [] ""
+    verifySignature _ [TLitString msg,TLitString sig,TLitString pubkeyjwk] = do
+        let keyMaterial = maybe (error "invalid JWK") (view jwkMaterial) $ decode' (LBS.fromStrict $ encodeUtf8 pubkeyjwk)
+        isValidOrErr :: Either Error Bool <- runExceptT $ verify ES256 keyMaterial (decodeBase64UrlUnpaddedFatal $ encodeUtf8 msg) (decodeBase64UrlUnpaddedFatal $ encodeUtf8 sig)
+        case isValidOrErr of
+            Left err -> error ("verify-signature-jwk: " <> show err)
+            Right isValid -> return $ toTerm isValid
+    verifySignature i as = argsError i as
+
+    sha256Def = defRNative "sha-256" sha256 (funType tTyString [("input", tTyString)]) [] ""
+        where
+        sha256 _ [TLitString msg] = do
+            case hashByteString $ decodeBase64UrlUnpaddedFatal (encodeUtf8 msg) of
+                Sha2_256 sb -> return $ tStr $ decodeUtf8 $ encodeBase64UrlUnpadded $ SBS.fromShort sb
+        sha256 i as = argsError i as
+
+    base64ConcatDef = defRNative "base64-concat" base64Concat (funType tTyString [("input", TyList tTyString)]) [] ""
+        where
+        fromTLitString (TLitString m) = Just m
+        fromTLitString _ = Nothing
+        base64Concat _ [TList (traverse fromTLitString -> Just ins) _ _] = do
+            let ins' = decodeBase64UrlUnpaddedFatal . encodeUtf8 <$> ins
+            return $ tStr $ decodeUtf8 $ encodeBase64UrlUnpadded $ fold ins'
+        base64Concat i as = argsError i as

tests/GasModelSpec.hs

@@ -60,6 +60,9 @@ untestedNativesCheck = do
      [ "CHARSET_ASCII"
      , "CHARSET_LATIN1"
      , "verify-spv"
+     , "verify-signature-jwk"
+     , "base64-concat"
+     , "sha-256"
      , "public-chain-data"
      , "list"
      , "continue"
@@ -114,7 +117,7 @@ allNativesInGasTable = do
         absentNatives = foldl' absent [] justNatives
     (S.fromList absentNatives)
     `shouldBe`
-    (S.fromList ["CHARSET_ASCII", "CHARSET_LATIN1", "public-chain-data", "list"])
+    (S.fromList ["CHARSET_ASCII", "CHARSET_LATIN1", "public-chain-data", "list", "verify-signature-jwk", "base64-concat", "sha-256"])
 
 -- | Use this to run a single named test.
 _runNative :: NativeDefName -> IO (Maybe [(T.Text,Gas)])