diff --git a/gas-prices.csv b/gas-prices.csv index 09a87df30..8b7f6fe58 100644 --- a/gas-prices.csv +++ b/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 \ No newline at end of file +~,1 diff --git a/pact.cabal b/pact.cabal index fc8b4dc47..3fc62f950 100644 --- a/pact.cabal +++ b/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 diff --git a/src/Pact/Gas/Table.hs b/src/Pact/Gas/Table.hs index 5d98f9081..e4787310b 100644 --- a/src/Pact/Gas/Table.hs +++ b/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) diff --git a/src/Pact/Native.hs b/src/Pact/Native.hs index 6e985eb84..4a781ef20 100644 --- a/src/Pact/Native.hs +++ b/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 ] diff --git a/src/Pact/Native/Crypto.hs b/src/Pact/Native/Crypto.hs new file mode 100644 index 000000000..898029d45 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/tests/GasModelSpec.hs b/tests/GasModelSpec.hs index d63da4b54..2d9a09b62 100644 --- a/tests/GasModelSpec.hs +++ b/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)])