diff --git a/cabal.project b/cabal.project index 7b72e3561..a6435cf99 100644 --- a/cabal.project +++ b/cabal.project @@ -3,13 +3,6 @@ packages: . -- temporary upper bounds constraints: sbv <10 --- these upper bounds are required in order to not break payload validation in chainweb -constraints: base16-bytestring <1 -constraints: base64-bytestring <1.1 - -allow-newer: base64-bytestring:* -allow-newer: base16-bytestring:* - -- test upper bounds constraints: hspec-golden <0.2, diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index 34511b3eb..3f1e9d107 100644 --- a/docs/en/pact-functions.md +++ b/docs/en/pact-functions.md @@ -461,7 +461,7 @@ Return ID if called during current pact execution, failing if not. Obtain current pact build version. ```lisp pact> (pact-version) -"4.8" +"4.9" ``` Top level only: this function will fail if used in module code. @@ -1928,7 +1928,7 @@ Retreive any accumulated events and optionally clear event state. Object returne *→* `[string]` -Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] +Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePact49","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] ```lisp pact> (env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config) ["DisableHistoryInTransactionalMode"] @@ -2104,14 +2104,6 @@ pact> (expect-that "addition" (> 2) (+ 1 2)) ``` -### format-address {#format-address} - -*scheme* `string` *public-key* `string` *→* `string` - - -Transform PUBLIC-KEY into an address (i.e. a Pact Runtime Public Key) depending on its SCHEME. - - ### load {#load} *file* `string` *→* `string` diff --git a/flake.lock b/flake.lock index 32193c10f..17fec3a83 100644 --- a/flake.lock +++ b/flake.lock @@ -151,11 +151,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1689640360, - "narHash": "sha256-837/6Bfs6UJx2GDSCLmCg3zyhW2tyBf1Ad4plT021WE=", + "lastModified": 1690331094, + "narHash": "sha256-xGJlmbRruW61N0rEcFn2pRlpLnE1TCKvvyz2nytYzE4=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "c6a15a90fef46d4de1dbdfd6b20873b239599387", + "rev": "efc8a53a648a6a3b0973aaefc93ace7d0ddf198d", "type": "github" }, "original": { @@ -195,11 +195,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1689686507, - "narHash": "sha256-Q3lDRmZoxnL1Ddrx4lI8mqQajLV+K0aToBNjUjaqBsw=", + "lastModified": 1690332668, + "narHash": "sha256-GtrWrvYe5GlUH6adZjcs4Z0yEY+JrGBS2uentXjVNyI=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "b873d6f5bb5b1543bf0c8022e9d0943e24551b95", + "rev": "d9c1f82b37b4226eb22718b657bb80fe961f1cdf", "type": "github" }, "original": { @@ -284,11 +284,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1688517130, + "narHash": "sha256-hUqfxSlo+ffqVdkSZ1EDoB7/ILCL25eYkcCXW9/P3Wc=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "9151db2a9a61d7f5fe52ff8836f18bbd0fd8933c", + "revCount": 13, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -522,11 +522,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1689639109, - "narHash": "sha256-Jy7nQuxmKsWuxQp7ztCZz3zeVFjVnySLU8zcj/OlPvI=", + "lastModified": 1690330226, + "narHash": "sha256-ApHKqIP/Ubi92lZ0fp8EwiVdM7cejhYA4Hd5Zf8b7d8=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "c2eec3ceb5fbe77fb6fa008460b9f64622a08ddf", + "rev": "22fbccd7b46469e9405a7c035b8f83682d9c68f1", "type": "github" }, "original": { diff --git a/pact.cabal b/pact.cabal index 32118066a..b64668d09 100644 --- a/pact.cabal +++ b/pact.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: pact -version: 4.8 +version: 4.9 -- ^ 4 digit is prerelease, 3- or 2-digit for prod release synopsis: Smart contract language library and REPL description: @@ -145,7 +145,6 @@ library Pact.Types.Command Pact.Types.Continuation Pact.Types.Crypto - Pact.Types.ECDSA Pact.Types.Exp Pact.Types.ExpParser Pact.Types.Gas @@ -229,6 +228,7 @@ library , scientific >= 0.3 , semigroupoids >=5.0 , semirings + , serialise >= 0.2.6 , servant , servant-client >=0.16 , servant-client-core >=0.16 @@ -242,6 +242,7 @@ library , vector-algorithms >=0.7 , vector-space >=0.10.4 , yaml + , webauthn >= 0.7 if flag(build-tool) cpp-options: -DBUILD_TOOL diff --git a/src/Pact/ApiReq.hs b/src/Pact/ApiReq.hs index 74e1f6208..bbd600de2 100644 --- a/src/Pact/ApiReq.hs +++ b/src/Pact/ApiReq.hs @@ -296,7 +296,7 @@ loadSigData fp = do Left e -> Left $ "Error loading SigData file " <> fp <> ": " <> show e Right sd -> Right sd -addSigToSigData :: SomeKeyPair -> SigData a -> IO (SigData a) +addSigToSigData :: Ed25519KeyPair -> SigData a -> IO (SigData a) addSigToSigData kp sd = do sig <- signHash (_sigDataHash sd) kp let k = PublicKeyHex $ toB16Text $ getPublic kp @@ -384,7 +384,7 @@ addSigReq sd keyFile = do kp <- importKeyFile keyFile addSigToSigData kp sd -importKeyFile :: FilePath -> IO SomeKeyPair +importKeyFile :: FilePath -> IO Ed25519KeyPair importKeyFile keyFile = do v :: Value <- decodeYaml keyFile let ekp = do @@ -393,7 +393,7 @@ importKeyFile keyFile = do pub <- getKey "public" v sec <- getKey "secret" v - importKeyPair defaultScheme (Just $ PubBS pub) (PrivBS sec) + importKeyPair (Just $ PubBS pub) (PrivBS sec) case ekp of Left e -> dieAR $ "Could not parse key file " <> keyFile <> ": " <> e Right kp -> return kp @@ -480,7 +480,7 @@ signCmd keyFiles bs = do withKeypairsOrSigner :: Bool -> ApiReq - -> ([SomeKeyPairCaps] -> IO a) + -> ([Ed25519KeyPairCaps] -> IO a) -> ([Signer] -> IO a) -> IO a withKeypairsOrSigner unsignedReq ApiReq{..} keypairAction signerAction = @@ -548,7 +548,7 @@ mkExec -- ^ optional environment data -> PublicMeta -- ^ public metadata - -> [SomeKeyPairCaps] + -> [Ed25519KeyPairCaps] -- ^ signing keypairs + caplists -> Maybe NetworkId -- ^ optional 'NetworkId' @@ -635,7 +635,7 @@ mkCont -- ^ environment data -> PublicMeta -- ^ command public metadata - -> [SomeKeyPairCaps] + -> [Ed25519KeyPairCaps] -- ^ signing keypairs -> Maybe Text -- ^ optional nonce @@ -687,12 +687,11 @@ mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid = do (Continuation (ContMsg txid step rollback (toLegacyJson mdata) proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd -mkKeyPairs :: [ApiKeyPair] -> IO [SomeKeyPairCaps] +-- Parse `APIKeyPair`s into Ed25519 keypairs. +mkKeyPairs :: [ApiKeyPair] -> IO [Ed25519KeyPairCaps] mkKeyPairs keyPairs = traverse mkPair keyPairs where importValidKeyPair ApiKeyPair{..} = fmap (,maybe [] id _akpCaps) $ - case _akpScheme of - Nothing -> importKeyPair defaultScheme _akpPublic _akpSecret - Just ppk -> importKeyPair (toScheme ppk) _akpPublic _akpSecret + importKeyPair _akpPublic _akpSecret mkPair akp = case _akpAddress akp of Nothing -> either dieAR return (importValidKeyPair akp) @@ -703,14 +702,12 @@ mkKeyPairs keyPairs = traverse mkPair keyPairs -- Enforces that user provided address matches the address derived from the Public Key -- for transparency and a better user experience. User provided address not used except -- for this purpose. - - case (addrBS, formatPublicKey (fst kp)) of - (expectAddr, actualAddr) - | expectAddr == actualAddr -> return kp - | otherwise -> dieAR $ "Address provided " - ++ show (toB16Text expectAddr) - ++ " does not match actual Address " - ++ show (toB16Text actualAddr) + if addrBS == getPublic (fst kp) + then return kp + else dieAR $ "Address provided " + ++ show (toB16Text addrBS) + ++ " does not match actual Address " + ++ show (toB16Text $ getPublic $ fst kp) dieAR :: String -> IO a dieAR errMsg = throwM . userError $ intercalate "\n" $ diff --git a/src/Pact/Bench.hs b/src/Pact/Bench.hs index 29ff90a9b..749ff5c69 100644 --- a/src/Pact/Bench.hs +++ b/src/Pact/Bench.hs @@ -234,7 +234,7 @@ benchReadValue benchMod (DataTable t) _k benchReadValue _ (TxTable _t) _k = rcp Nothing -mkBenchCmd :: [SomeKeyPairCaps] -> (String, Text) -> IO (String, Command ByteString) +mkBenchCmd :: [Ed25519KeyPairCaps] -> (String, Text) -> IO (String, Command ByteString) mkBenchCmd kps (str, t) = do cmd <- mkCommand' kps $ J.encodeStrict @@ -291,7 +291,7 @@ main = do !priv <- eitherDie "priv" $ parseB16TextOnly "6c938ed95a8abf99f34a1b5edd376f790a2ea8952413526af91b4c3eb0331b3c" !keyPair <- eitherDie "keyPair" $ - importKeyPair defaultScheme (Just $ PubBS pub) (PrivBS priv) + importKeyPair (Just $ PubBS pub) (PrivBS priv) !parsedExps <- force <$> mapM (mapM (eitherDie "parseExps" . parseExprs)) exps !pureDb <- perfEnv dbPerf <$> mkPureEnv neverLog initSchema pureDb diff --git a/src/Pact/Main.hs b/src/Pact/Main.hs index 28e205862..b222f7f78 100644 --- a/src/Pact/Main.hs +++ b/src/Pact/Main.hs @@ -245,6 +245,6 @@ echoBuiltins = do genKeys :: IO () genKeys = do - kp <- genKeyPair defaultScheme + kp <- genKeyPair putStrLn $ "public: " ++ unpack (toB16Text $ getPublic kp) putStrLn $ "secret: " ++ unpack (toB16Text $ getPrivate kp) diff --git a/src/Pact/Native.hs b/src/Pact/Native.hs index 5120e6c19..b5933162b 100644 --- a/src/Pact/Native.hs +++ b/src/Pact/Native.hs @@ -56,14 +56,16 @@ module Pact.Native , cdPrevBlockHash ) where -import Control.Arrow hiding (app) +import Control.Arrow hiding (app, first) import Control.Exception.Safe import Control.Lens hiding (parts,Fold,contains) import Control.Monad import Control.Monad.IO.Class import qualified Data.Attoparsec.Text as AP +import Data.Bifunctor (first) import Data.Bool (bool) import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 import qualified Data.Char as Char import Data.Bits import Data.Default @@ -75,11 +77,13 @@ import qualified Data.List as L (nubBy) import qualified Data.Set as S import Data.Text (Text, pack, unpack) import qualified Data.Text as T +import qualified Data.Text as Text import qualified Data.Text.Encoding as T import Pact.Time import qualified Data.Vector as V import qualified Data.Vector.Algorithms.Intro as V import Numeric +import Text.Read (readMaybe) import Pact.Eval import Pact.Native.Capabilities @@ -1338,9 +1342,11 @@ strToInt i as = doBase si base txt = case baseStrToInt base txt of Left e -> evalError' si (pretty e) Right n -> return (toTerm n) - doBase64 si txt = case parseB64UrlUnpaddedText' txt of - Left e -> evalError' si (pretty e) - Right bs -> return $ toTerm $ bsToInteger bs + doBase64 si txt = do + parseResult <- base64DecodeWithShimmedErrors (getInfo si) txt + case parseResult of + Left e -> evalError' si (pretty (T.pack e)) + Right bs -> return $ toTerm $ bsToInteger bs bsToInteger :: BS.ByteString -> Integer bsToInteger bs = fst $ foldl' go (0,(BS.length bs - 1) * 8) $ BS.unpack bs @@ -1403,12 +1409,15 @@ base64decode = defRNative "base64-decode" go where go :: RNativeFun e go i as = case as of - [TLitString s] -> - case fromB64UrlUnpaddedText $ T.encodeUtf8 s of - Left e -> evalError' i - $ "Could not decode string: " - <> pretty e - Right t -> return $ tStr t + [TLitString s] -> do + parseResult <- base64DecodeWithShimmedErrors (getInfo i) s + let + parseResultErrorContext = first ("Could not decode string: " <>) $ parseResult + case parseResultErrorContext of + Right bs -> case T.decodeUtf8' bs of + Right t -> return $ tStr t + Left _unicodeError -> evalError' i $ "Could not decode string: Base64URL decode failed: invalid unicode" + Left base64Error -> evalError' i (pretty (T.pack base64Error)) _ -> argsError i as -- | Continue a nested defpact. @@ -1445,3 +1454,92 @@ continueNested i as = gasUnreduced i as $ case as of unTVar = \case TVar (Ref d) _ -> unTVar d d -> d + +-- | A tag for determining how to proceed when encountering an invalid +-- base64-encoded message. +-- +-- Legacy: +-- Although we are using base64-bytestring > 1.0, emulate the behavior of +-- base64-bytestring-0.1, for hash compatibility with historical blocks. +-- Messages that continue to fail with new error messages will have those +-- error messages parsed and reformatted into the older form. And messages +-- that now fail due to "non-canonical encoding" will be parsed again +-- leniently, because the legacy base64 parser accepted these messages. +-- +-- Simplified: +-- Only base64-encoded messages that pass strict parsing will be accepted +-- (no second lenient pass for non-canonical encodings). All failures to +-- parse will result in the same single error message. This makes the error +-- messages less informative, but makes it easier to maintain compatibility +-- as the base64 parsing algorithm evolves, for failures encountered after +-- the fork that enables simplified error messages. +data Base64DecodingBehavior + = Legacy + | Simplified + deriving (Eq, Show) + +-- | Convert from base64-bytestring-1.0 behavior to +-- base64-bytestring-0.1 behavior. This is needed in order +-- to preserve hash equality with old versions of pact (which +-- used base64-bytestring-0.1). +-- +-- Throws a Pact `evalError` if it fails to parse an encountered +-- base64-decoding error message. +base64DecodeWithShimmedErrors + :: Info + -> Text + -> Eval e (Either String BS.ByteString) +base64DecodeWithShimmedErrors i txt = do + + -- Use Legacy error behavior when 4.9 is disabled. + behavior <- ifExecutionFlagSet' FlagDisablePact49 Legacy Simplified + + -- Attempt to decode the bytestring, and convert error messages to Text. + case first Text.pack $ parseB64UrlUnpaddedText' txt of + + -- base64-bytestring-0.1 is more strict than base64-bytestring-0.1, + -- so all new successful decodings succeeded on the old version, too. + Right e -> return $ Right e + + -- With Simplified error messages, map every error to a single string. + Left _ | behavior == Simplified -> + return $ Left "Could not base64-decode string" + + -- All cases beyond this point are errors and the behavior context is Legacy. + + -- base64-bytestring-1.0 fails with a "non-canonical encoding" error + -- for a subset of encoded messages that decode to some bytestring + -- that would subsequently encode to something other than the original. + Left e | "non-canonical" `T.isInfixOf` e -> + return $ Right (B64.decodeLenient (T.encodeUtf8 txt)) + + -- This particular error message is reported differently between the + -- two versions. + Left "Base64URL decode failed: Base64-encoded bytestring has invalid size" -> + return $ Left "Base64URL decode failed: invalid base64 encoding near offset 0" + + -- The "invalid character at offset: $n" message is spelled as + -- "invalid base64 encoding near offset $n" in the old base64-bytestring. + Left (Text.stripPrefix "Base64URL decode failed: invalid character at offset: " -> Just suffix) -> do + offset <- adjustedOffset suffix + return . Left $ + "Base64URL decode failed: invalid base64 encoding near offset " ++ show offset + + Left (Text.stripPrefix "Base64URL decode failed: invalid padding at offset: " -> Just suffix) -> do + offset <- adjustedOffset suffix + return . Left $ "Base64URL decode failed: invalid padding near offset " ++ show offset + + -- All other error messages should be the same between old and + -- new versions of base64-bytestring. + Left e -> return $ Left (Text.unpack e) + where + endsInThreeEquals = + T.drop (T.length txt - 3) txt == "===" + paddingAdjustment = if endsInThreeEquals then -1 else 0 + + adjustedOffset :: Text -> Eval e Int + adjustedOffset suffix = case readMaybe (Text.unpack suffix) of + Just (offsetI :: Int) -> + return $ offsetI - (offsetI `rem` 4) + paddingAdjustment + Nothing -> + evalError i "Could not parse error message" diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index a036c8f52..d8cf87c8a 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -53,7 +53,6 @@ import Statistics.Types (Estimate(..)) import qualified Pact.Analyze.Check as Check import System.Directory # endif -import qualified Pact.Types.Crypto as Crypto import Pact.Typechecker import qualified Pact.Types.Typecheck as TC @@ -107,9 +106,6 @@ replDefs = ("Repl", funType tTyString [("file",tTyString),("reset",tTyBool)]) [LitExample "(load \"accounts.repl\")"] "Load and evaluate FILE, resetting repl state beforehand if optional RESET is true." - ,defZRNative "format-address" formatAddr (funType tTyString [("scheme", tTyString), ("public-key", tTyString)]) - [] - "Transform PUBLIC-KEY into an address (i.e. a Pact Runtime Public Key) depending on its SCHEME." ,defZRNative "env-keys" setsigs (funType tTyString [("keys",TyList tTyString)]) ["(env-keys [\"my-key\" \"admin-key\"])"] ("DEPRECATED in favor of 'env-sigs'. Set transaction signer KEYS. "<> @@ -335,24 +331,6 @@ mockSPV i as = case as of return $ tStr $ "Added mock SPV for " <> spvType _ -> argsError i as -formatAddr :: RNativeFun LibState -formatAddr i [TLitString scheme, TLitString cryptoPubKey] = do - let eitherEvalErr :: Either String a -> String -> (a -> b) -> Eval LibState b - eitherEvalErr res effectStr transformFunc = - case res of - Left e -> evalError' i $ prettyString effectStr <> ": " <> prettyString e - Right v -> return (transformFunc v) - sppk <- eitherEvalErr (fromText' scheme) - "Invalid PPKScheme" - Crypto.toScheme - pubBS <- eitherEvalErr (parseB16TextOnly cryptoPubKey) - "Invalid Public Key format" - Crypto.PubBS - addr <- eitherEvalErr (Crypto.formatPublicKeyBS sppk pubBS) - "Unable to convert Public Key to Address" - toB16Text - return (tStr addr) -formatAddr i as = argsError i as setsigs :: RNativeFun LibState setsigs i [TList ts _ _] = do diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 3e08a747a..00cc01b3b 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -1,14 +1,17 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -34,7 +37,8 @@ module Pact.Types.Command , keyPairsToSigners , verifyUserSig , verifyCommand - , SomeKeyPairCaps + , PPKScheme(..) + , Ed25519KeyPairCaps , ProcessedCommand(..),_ProcSucc,_ProcFail , Payload(..),pMeta,pNonce,pPayload,pSigners,pNetworkId , ParsedCode(..),pcCode,pcExps @@ -50,7 +54,6 @@ module Pact.Types.Command , requestKeyToB16Text ) where - import Control.Applicative import Control.Lens hiding ((.=), elements) import Control.DeepSeq @@ -60,6 +63,7 @@ import Data.Serialize as SZ import Data.Hashable (Hashable) import Data.Aeson as A import Data.Text (Text) +import qualified Data.Text.Encoding as Text import Data.Maybe (fromMaybe) import GHC.Generics @@ -120,14 +124,15 @@ data ProcessedCommand m a = deriving (Show, Eq, Generic, Functor, Foldable, Traversable) instance (NFData a,NFData m) => NFData (ProcessedCommand m a) -type SomeKeyPairCaps = (SomeKeyPair,[SigCapability]) + +type Ed25519KeyPairCaps = (Ed25519KeyPair ,[SigCapability]) -- CREATING AND SIGNING TRANSACTIONS mkCommand :: J.Encode c => J.Encode m - => [SomeKeyPairCaps] + => [(Ed25519KeyPair, [SigCapability])] -> m -> Text -> Maybe NetworkId @@ -138,22 +143,18 @@ mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload encodedPayload = J.encodeStrict $ toLegacyJsonViaEncode payload payload = Payload rpc nonce meta (keyPairsToSigners creds) nid -keyPairToSigner :: SomeKeyPair -> [SigCapability] -> Signer +keyPairToSigner :: Ed25519KeyPair -> [SigCapability] -> Signer keyPairToSigner cred caps = Signer scheme pub addr caps - where scheme = case kpToPPKScheme cred of - ED25519 -> Nothing - s -> Just s - pub = toB16Text $ getPublic cred - addr = case scheme of - Nothing -> Nothing - Just {} -> Just $ toB16Text $ formatPublicKey cred + where + scheme = Nothing + pub = toB16Text $ toBS $ fst cred + addr = Nothing - -keyPairsToSigners :: [SomeKeyPairCaps] -> [Signer] +keyPairsToSigners :: [Ed25519KeyPairCaps] -> [Signer] keyPairsToSigners creds = map (uncurry keyPairToSigner) creds -mkCommand' :: [(SomeKeyPair,a)] -> ByteString -> IO (Command ByteString) +mkCommand' :: [(Ed25519KeyPair ,a)] -> ByteString -> IO (Command ByteString) mkCommand' creds env = do let hsh = hash env -- hash associated with a Command, aka a Command's Request Key toUserSig (cred,_) = signHash hsh cred @@ -173,8 +174,8 @@ mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload where encodedPayload = J.encodeStrict payload payload = Payload rpc nonce meta signers nid -signHash :: TypedHash h -> SomeKeyPair -> IO UserSig -signHash hsh cred = UserSig . toB16Text <$> sign cred (toUntypedHash hsh) +signHash :: TypedHash h -> Ed25519KeyPair -> IO UserSig +signHash hsh (pub,priv) = UserSig . toB16Text <$> sign pub priv (toUntypedHash hsh) -- VALIDATING TRANSACTIONS @@ -203,6 +204,7 @@ hasInvalidSigs hsh sigs signers | otherwise = if (length failedSigs == 0) then Nothing else formatIssues where verifyFailed (sig, signer) = not $ verifyUserSig hsh sig signer + -- assumes nth Signer is responsible for the nth UserSig failedSigs = filter verifyFailed (zip sigs signers) formatIssues = Just $ "Invalid sig(s) found: " ++ show (J.encode . J.Array <$> failedSigs) @@ -211,22 +213,28 @@ hasInvalidSigs hsh sigs signers verifyUserSig :: PactHash -> UserSig -> Signer -> Bool verifyUserSig msg UserSig{..} Signer{..} = case (pubT, sigT, addrT) of - (Right p, Right sig, addr) -> + (Right p, sig, addr) -> (isValidAddr addr p) && verify (toScheme $ fromMaybe defPPKScheme _siScheme) - (toUntypedHash msg) (PubBS p) (SigBS sig) + (toUntypedHash msg) (PubBS p) sig _ -> False where pubT = parseB16TextOnly _siPubKey - sigT = parseB16TextOnly _usSig + sigT = case parseB16TextOnly _usSig of + Left _ -> SigBS (Text.encodeUtf8 _usSig) + Right bs -> SigBS bs addrT = parseB16TextOnly <$> _siAddress - toScheme' = toScheme . fromMaybe ED25519 isValidAddr addrM pubBS = case addrM of Nothing -> True Just (Left _) -> False - Just (Right givenAddr) -> - case formatPublicKeyBS (toScheme' _siScheme) (PubBS pubBS) of - Right expectAddr -> givenAddr == expectAddr - Left _ -> False + -- All current cases of `_siScheme` require the same relationship + -- between `pubBS` and `givenAddr`. But we enumerate them anyway, + -- so that if another scheme is added in the future, this use site + -- will warn us that we need to consider the `pubBS`/`givenAddr` + -- relationship for that scheme, since it may be different. + Just (Right givenAddr) -> case _siScheme of + Nothing -> pubBS == givenAddr + Just ED25519 -> pubBS == givenAddr + Just WebAuthn -> pubBS == givenAddr -- | Signer combines PPKScheme, PublicKey, and the Address (aka the -- formatted PublicKey). diff --git a/src/Pact/Types/Crypto.hs b/src/Pact/Types/Crypto.hs index cfb12f8fd..663592d75 100644 --- a/src/Pact/Types/Crypto.hs +++ b/src/Pact/Types/Crypto.hs @@ -7,6 +7,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} @@ -25,32 +27,40 @@ module Pact.Types.Crypto ( ST.PPKScheme(..) , ST.defPPKScheme , SomeScheme + , SPPKScheme(..) , defaultScheme , toScheme - , SomeKeyPair , PublicKeyBS(..) , PrivateKeyBS(..) , SignatureBS(..) , sign , verify - , formatPublicKey - , formatPublicKeyBS - , kpToPPKScheme , getPublic , getPrivate , genKeyPair , importKeyPair - , KeyPair(..) , Scheme(..) , ConvertBS(..) + , Ed25519KeyPair ) where import Prelude import GHC.Generics +import qualified Codec.Serialise as Serialise +import Control.Monad (unless) +import qualified Crypto.Hash as H +import qualified Crypto.WebAuthn as WA +import qualified Crypto.WebAuthn.Cose.Internal.Verify as WAVerify +import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.ByteString.Short (fromShort) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.URL as Base64URL import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -62,8 +72,8 @@ import qualified Data.Serialize as S import Pact.Types.Util import Pact.Types.Hash +import qualified Pact.Types.Hash as PactHash import Pact.Types.Scheme as ST -import qualified Pact.Types.ECDSA as ECDSA #ifdef CRYPTONITE_ED25519 import qualified Crypto.Error as E @@ -78,7 +88,6 @@ import qualified Pact.JSON.Encode as J import Test.QuickCheck - --------- INTERNAL SCHEME CLASS --------- class ConvertBS a where @@ -86,53 +95,10 @@ class ConvertBS a where fromBS :: ByteString -> Either String a - - --- | Scheme class created to enforce at the type level that Public Key, --- Private Key, and Signature are of the same scheme when signing --- and validating. --- --- Also ensures that each scheme specifies --- how it will transform its public keys to Pact Runtime public keys. - -class ( ConvertBS (PublicKey a), Eq (PublicKey a), Show (PublicKey a) - , ConvertBS (PrivateKey a) - , ConvertBS (Signature a), Eq (Signature a), Show (Signature a) - , Show a - ) => - Scheme a where - - type PublicKey a - -- ^ Associated public key type - - type PrivateKey a - -- ^ Associated private key type - - type Signature a - -- ^ Associated cryptographic signature type - - _sign :: a -> Hash -> PublicKey a -> PrivateKey a -> IO (Signature a) - -- ^ Sign a hash given public and private key - - _valid :: a -> Hash -> PublicKey a -> Signature a -> Bool +class Scheme a where + _valid :: a -> Hash -> PublicKeyBS -> SignatureBS -> Bool -- ^ Validate a signature given a public key and hash - _genKeyPair :: a -> IO (PublicKey a, PrivateKey a) - -- ^ Randomly generate a keypair - - _getPublic :: a -> PrivateKey a -> Maybe (PublicKey a) - -- ^ Trivial to derive in Elliptic Curve Cryptography. - -- Return Nothing if not possible to derive. - - _formatPublicKey :: a -> PublicKey a -> ByteString - -- ^ Converts "Cryptographic" public keys to "Runtime" public keys depending on the scheme. - -- Cryptographic PKs are used to sign/validate transactions, while "Runtime PKs" - -- are used during keyset enforcement in the Pact environment. - -- With schemes like ETH or BTC that have address formats that differ from the public key itself, - -- the "Runtime PK" is in the address format. This allows migration of ownership ledgers - -- from those blockchains to the Pact system. - - --------- CONNECTS PPKSCHEME TO SPPKSCHEME --------- @@ -146,32 +112,18 @@ defaultScheme = toScheme defPPKScheme toScheme :: PPKScheme -> SomeScheme toScheme ED25519 = SomeScheme SED25519 -toScheme ETH = SomeScheme SETH - - --- Connects each SPPKScheme a with a PPKScheme - -toPPKScheme :: SPPKScheme a -> PPKScheme -toPPKScheme SED25519 = ED25519 -toPPKScheme SETH = ETH - - +toScheme WebAuthn = SomeScheme SWebAuthn --------- SCHEME ED25519 INSTANCES -------- #ifdef CRYPTONITE_ED25519 instance Scheme (SPPKScheme 'ED25519) where - type PublicKey (SPPKScheme 'ED25519) = Ed25519.PublicKey - type PrivateKey (SPPKScheme 'ED25519) = Ed25519.SecretKey - type Signature (SPPKScheme 'ED25519) = Ed25519.Signature - - _sign _ (Hash msg) pub priv = return $ Ed25519.sign priv pub (fromShort msg) - _valid _ (Hash msg) pub sig = Ed25519.verify pub (fromShort msg) sig - _genKeyPair _ = ed25519GenKeyPair - _getPublic _ = Just . ed25519GetPublicKey - _formatPublicKey _ p = toBS p + _valid _ (Hash msg) (PubBS pubBS) (SigBS sigBS) = + case (fromBS pubBS, fromBS sigBS) of + (Right pubKey, Right sig) -> Ed25519.verify pubKey (fromShort msg) sig + _ -> False instance ConvertBS (Ed25519.PublicKey) where @@ -198,13 +150,10 @@ instance Scheme (SPPKScheme 'ED25519) where type PrivateKey (SPPKScheme 'ED25519) = Ed25519.PrivateKey type Signature (SPPKScheme 'ED25519) = Ed25519.Signature - _sign _ (Hash msg) pub priv = return $ Ed25519.sign msg priv pub - _valid _ (Hash msg) pub sig = Ed25519.valid msg pub sig - _genKeyPair _ = ed25519GenKeyPair - _getPublic _ = Just . ed25519GetPublicKey - _formatPublicKey _ p = toBS p - - + _valid _ (Hash msg) pub sig = + case (fromBS pubBS, fromBS sigBS) of + (Right pubKey, Right sig) -> Ed25519.verify pubKey (fromShort msg) sig + _ -> False instance ConvertBS (Ed25519.PublicKey) where toBS = Ed25519.exportPublic @@ -219,64 +168,70 @@ instance ConvertBS Ed25519.Signature where fromBS = Right . Ed25519.Sig #endif - - ---------- SCHEME ETH INSTANCES -------- - -instance Scheme (SPPKScheme 'ETH) where - type PublicKey (SPPKScheme 'ETH) = ECDSA.PublicKey - type PrivateKey (SPPKScheme 'ETH) = ECDSA.PrivateKey - type Signature (SPPKScheme 'ETH) = ECDSA.Signature - - - _sign _ (Hash msg) pub priv = ECDSA.signETH (fromShort msg) pub priv - _valid _ (Hash msg) pub sig = ECDSA.validETH (fromShort msg) pub sig - _genKeyPair _ = ECDSA.genKeyPair - _getPublic _ = Just . ECDSA.getPublicKey - _formatPublicKey _ p = ECDSA.formatPublicKeyETH (toBS p) - - - -instance ConvertBS (ECDSA.PublicKey) where - toBS = ECDSA.exportPublic - fromBS s = maybeToEither ("Invalid ECDSA Public Key: " ++ show (toB16Text s)) - (ECDSA.importPublic s) -instance ConvertBS (ECDSA.PrivateKey) where - toBS = ECDSA.exportPrivate - fromBS s = maybeToEither ("Invalid ECDSA Private Key: " ++ show (toB16Text s)) - (ECDSA.importPrivate s) -instance ConvertBS (ECDSA.Signature) where - toBS = ECDSA.exportSignature - fromBS s = maybeToEither ("Invalid ECDSA Signature: " ++ show (toB16Text s)) - (ECDSA.importSignature s) - - - +instance Scheme (SPPKScheme 'WebAuthn) where + + _valid _ msg (PubBS pubBS) (SigBS sigBS) = + case runVerification of + Left _ -> False + Right () -> True + where + -- Verifying a WebAuthn signature requires that we know the payload + -- signed by the WebAuthn keys on the client device. This payload is + -- a combination of the Challenge (in our case, the PactHash of a + -- transaction), a JSON object of "client metadata", and data about + -- the authenticator hardware. + -- We require this data to be part of our WebAuthn signature so that + -- we can reconstitute the payload that was signed on the browser. + runVerification :: Either String () + runVerification = do + + -- Decode our WebAuthn signature object from a `UserSig` string. + WebAuthnSignature + { authenticatorData + , signature + , clientDataJSON } <- A.eitherDecode (BSL.fromStrict sigBS) + + -- Decode the signer's public key. + publicKey <- first show $ + Serialise.deserialiseOrFail @WA.CosePublicKey + (BSL.fromStrict pubBS) + + -- Enforce that the public key was generated by one of the two most + -- common signing algorithms. This lowers our susceptibility to + -- algorithm confusion attacks. + let WA.PublicKeyWithSignAlg _ signAlg = publicKey + unless (WA.fromCoseSignAlg signAlg `elem` + [-7 :: Int -- ECDSA with SHA-256, the most common webauthn signing algorithm. + ,-8 -- EdDSA, which is also supported by YubiKey. + ]) $ Left "Signing algorithm must be EdDSA" + + -- Recover the signature, clientData, and authData bytestrings. + sig <- Base64.decode (T.encodeUtf8 signature) + clientData <- Base64URL.decode (T.encodeUtf8 clientDataJSON) + authData <- Base64.decode (T.encodeUtf8 authenticatorData) + + -- Reconstitute the payload signed by the WebAuthn client. + clientDataDigest <- Base16.decode $ BS.pack (show (H.hashWith H.SHA256 clientData)) + let payload = authData <> clientDataDigest + + -- Check the signature's validity. + first T.unpack $ WAVerify.verify publicKey payload sig + + -- Extract the original challenge from client data. + ClientDataJSON { challenge } <- A.eitherDecode (BSL.fromStrict clientData) + + -- Check that the input `PactHash` matches the hash of the transaction + -- that was signed by WebAuthn keys. + let pactHashText = PactHash.hashToText msg + unless (pactHashText == challenge) $ + Left "Hash mismatch" + + -- If all of the above conditions are met, the signature is valid. + return () --------- SCHEME HELPER DATA TYPES --------- - --- | Specialized KeyPair datatype for schemes -data KeyPair a = KeyPair - { _kpScheme :: a - , _kpPublicKey :: PublicKey a - , _kpPrivateKey :: PrivateKey a - } - -instance Scheme a => Show (KeyPair a) where - show KeyPair{..} = "KeyPair { _kpScheme = " ++ show _kpScheme ++ - ", _kpPublicKey = " ++ show _kpPublicKey ++ - ", _kpPrivateKey = ... }" - - --- | SomeKeyPair existential allows a transaction to be signed by --- key pairs of different schemes -data SomeKeyPair = - forall a. Scheme (SPPKScheme a) => - SomeKeyPair (KeyPair (SPPKScheme a)) - -instance Show SomeKeyPair where - show (SomeKeyPair kp) = "SomeKeyPair (" ++ show kp ++")" +type Ed25519KeyPair = (Ed25519.PublicKey, Ed25519.SecretKey) newtype PublicKeyBS = PubBS { _pktPublic :: ByteString } @@ -337,71 +292,49 @@ instance Arbitrary SignatureBS where --------- SCHEME HELPER FUNCTIONS --------- -sign :: SomeKeyPair -> Hash -> IO ByteString -sign (SomeKeyPair KeyPair{..}) msg = toBS <$> _sign _kpScheme msg _kpPublicKey _kpPrivateKey +sign :: Ed25519.PublicKey -> Ed25519.SecretKey -> Hash -> IO ByteString +sign pub priv (Hash msg) = return $ toBS $ Ed25519.sign priv pub (fromShort msg) verify :: SomeScheme -> Hash -> PublicKeyBS -> SignatureBS -> Bool -verify (SomeScheme scheme) msg (PubBS pBS) (SigBS sigBS) = - let pParsed = fromBS pBS - sigParsed = fromBS sigBS - in case (pParsed, sigParsed) of - (Right p, Right sig) -> _valid scheme msg p sig - _ -> False - - -formatPublicKey :: SomeKeyPair -> ByteString -formatPublicKey (SomeKeyPair KeyPair{..}) = _formatPublicKey _kpScheme _kpPublicKey - -formatPublicKeyBS :: SomeScheme -> PublicKeyBS -> Either String ByteString -formatPublicKeyBS (SomeScheme scheme) (PubBS pBS) = do - pub <- fromBS pBS - return $ _formatPublicKey scheme pub - +verify (SomeScheme scheme) msg pBS sigBS = _valid scheme msg pBS sigBS --- Key Pair getter functions -kpToPPKScheme :: SomeKeyPair -> PPKScheme -kpToPPKScheme (SomeKeyPair kp) = toPPKScheme (_kpScheme kp) +getPublic :: Ed25519KeyPair -> ByteString +getPublic = toBS . fst -getPublic :: SomeKeyPair -> ByteString -getPublic (SomeKeyPair kp) = toBS (_kpPublicKey kp) - -getPrivate :: SomeKeyPair -> ByteString -getPrivate (SomeKeyPair kp) = toBS (_kpPrivateKey kp) +getPrivate :: Ed25519KeyPair -> ByteString +getPrivate = toBS . snd -- Key Pair setter functions -genKeyPair :: SomeScheme -> IO SomeKeyPair -genKeyPair (SomeScheme scheme) = do - (pub, priv) <- _genKeyPair scheme - return $ SomeKeyPair $ KeyPair scheme pub priv +genKeyPair :: IO (Ed25519.PublicKey, Ed25519.SecretKey) +genKeyPair = ed25519GenKeyPair +-- | Parse a pair of keys (where the public key is optional) into an Ed25519 keypair. -- Derives Public Key from Private Key if none provided. Trivial in some -- Crypto schemes (i.e. Elliptic curve ones). -- Checks that Public Key provided matches the Public Key derived from the Private Key. - -importKeyPair :: SomeScheme -> Maybe PublicKeyBS -> PrivateKeyBS -> Either String SomeKeyPair -importKeyPair (SomeScheme scheme) maybePubBS (PrivBS privBS) = do +importKeyPair :: Maybe PublicKeyBS -> PrivateKeyBS -> Either String Ed25519KeyPair +importKeyPair maybePubBS (PrivBS privBS) = do priv <- fromBS privBS - pub <- case maybePubBS of - Nothing -> maybeToEither - (show (toPPKScheme scheme) ++ " Key Pair import failed: Need Public Key") - (_getPublic scheme priv) - Just (PubBS pubBS) -> do - pubActual <- fromBS pubBS - case (_getPublic scheme priv) of - Nothing -> Right pubActual - Just pubExpect | pubExpect == pubActual -> Right pubActual - | otherwise -> Left $ "Expected PublicKey " - ++ show (toB16Text $ toBS pubExpect) - ++ " but received " - ++ show (toB16Text $ toBS pubActual) - return $ SomeKeyPair $ KeyPair scheme pub priv + let derivedPub = ed25519GetPublicKey priv + suppliedPub <- case maybePubBS of + Nothing -> Right Nothing + Just (PubBS pubBS) -> Just <$> fromBS pubBS + case suppliedPub of + Nothing -> return (derivedPub, priv) + Just pub -> + if pub == derivedPub + then return (derivedPub, priv) + else Left $ "Expected PublicKey " + ++ show (toB16Text $ toBS pub) + ++ " but received " + ++ show (toB16Text $ toBS derivedPub) @@ -457,8 +390,6 @@ ed25519GetPublicKey :: Ed25519.PrivateKey -> Ed25519.PublicKey ed25519GetPublicKey = Ed25519.generatePublic - - instance Eq Ed25519.PublicKey where b == b' = (Ed25519.exportPublic b) == (Ed25519.exportPublic b') instance Ord Ed25519.PublicKey where @@ -487,3 +418,30 @@ instance Serialize Ed25519.Signature where put (Ed25519.Sig s) = S.put s get = Ed25519.Sig <$> (S.get >>= S.getByteString) #endif + + +-- | This type specifies the format of a WebAuthn signature. +data WebAuthnSignature = WebAuthnSignature + { clientDataJSON :: T.Text + , authenticatorData :: T.Text + , signature :: T.Text + } deriving (Show, Generic) + +instance A.FromJSON WebAuthnSignature where + parseJSON = A.withObject "WebAuthnSignature" $ \o -> do + clientDataJSON <- o .: "clientDataJSON" + authenticatorData <- o .: "authenticatorData" + signature <- o .: "signature" + pure $ WebAuthnSignature {..} + +-- | This type represents a challenge that was used during +-- a WebAuthn "assertion" flow. For signing Pact payloads, this +-- is the PactHash of a transaction. +newtype ClientDataJSON = ClientDataJSON { + challenge :: T.Text + } deriving (Show, Generic) + +instance A.FromJSON ClientDataJSON where + parseJSON = A.withObject "ClientDataJSON" $ \o -> do + challenge <- o .: "challenge" + pure $ ClientDataJSON { challenge } diff --git a/src/Pact/Types/ECDSA.hs b/src/Pact/Types/ECDSA.hs deleted file mode 100644 index 73ccc9ca7..000000000 --- a/src/Pact/Types/ECDSA.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Pact.Types.ECDSA - ( PublicKey - , PrivateKey - , Signature - , genKeyPair - , getPublicKey - , hashAlgoETH - , signETH - , validETH - , formatPublicKeyETH - , exportPublic, importPublic - , exportPrivate, importPrivate - , exportSignature, importSignature - ) where - - -import Data.ByteString (ByteString) - -import Crypto.PubKey.ECC.Generate (generate, generateQ) -import Crypto.PubKey.ECC.ECDSA (PublicKey(..), PrivateKey(..), Signature(..)) -import Crypto.PubKey.ECC.Prim (isPointValid, isPointAtInfinity) -import Crypto.Number.Serialize (i2osp, os2ip) - -import qualified Crypto.Hash as H -import qualified Crypto.PubKey.ECC.Types as ECDSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Data.ByteArray as BA -import qualified Data.ByteString as BS - - - ---------- ETHEREUM SCHEME FUNCTIONS --------- - -curveECDSA :: ECDSA.Curve -curveECDSA = ECDSA.getCurveByName ECDSA.SEC_p256k1 - - -hashAlgoETH :: H.SHA3_256 -hashAlgoETH = H.SHA3_256 - - -genKeyPair :: IO (PublicKey, PrivateKey) -genKeyPair = generate curveECDSA - - -getPublicKey :: PrivateKey -> PublicKey -getPublicKey (PrivateKey curve d) = PublicKey curve (generateQ curve d) - - -signETH :: ByteString -> PublicKey -> PrivateKey -> IO Signature -signETH msg _ priv = ECDSA.sign priv hashAlgoETH msg - - -validETH :: ByteString -> PublicKey -> Signature -> Bool -validETH msg pub sig = ECDSA.verify hashAlgoETH pub sig msg - - --- Algorithm for transforming ECDSA Public Key into Ethereum address --- found here: https://kobl.one/blog/create-full-ethereum-keypair-and-address/ --- Assumes ByteString is not base 16. -formatPublicKeyETH :: ByteString -> ByteString -formatPublicKeyETH pub = BS.drop 12 $ keccak256Hash pub - - - - ---------- ECDSA KEYS AND SIGNATURES FUNCTIONS --------- - -exportPublic :: ECDSA.PublicKey -> ByteString -exportPublic (ECDSA.PublicKey _ point) = - case point of - ECDSA.Point x y -> integerToBS x <> integerToBS y - ECDSA.PointO -> BS.empty - - --- ECDSA Public Key must be uncompressed and 64 bytes long or 65 bytes with 0x04. --- Assumes ByteString is not base 16. --- Source: https://kobl.one/blog/create-full-ethereum-keypair-and-address/ - -importPublic :: ByteString -> Maybe PublicKey -importPublic bs | BS.length bs == 65 && - startsWithConstant4 = checkIfValid (BS.drop 1 bs) - | BS.length bs == 64 = checkIfValid bs - | otherwise = Nothing - where startsWithConstant4 = - (BS.take 1 bs) == (integerToBS 0x04) - point b = ECDSA.Point (bsToInteger xBS) (bsToInteger yBS) - where (xBS, yBS) = BS.splitAt 32 b - checkIfValid b - | isPointValid curveECDSA (point b) && - not (isPointAtInfinity (point b)) = Just $ PublicKey curveECDSA (point b) - | otherwise = Nothing - - - - -exportPrivate :: ECDSA.PrivateKey -> ByteString -exportPrivate (PrivateKey _ p) = integerToBS p - - --- ECDSA Private Key must be 32 bytes and not begin with 0x00 (null byte) --- Assumes ByteString is not base 16. --- Source: https://kobl.one/blog/create-full-ethereum-keypair-and-address/ --- http://hackage.haskell.org/package/cryptonite-0.25/docs/src/Crypto-PubKey-ECC-Generate.html#generate - -importPrivate :: ByteString -> Maybe PrivateKey -importPrivate bs | not startsNullByte && - BS.length bs == 32 = checkIfValid - | otherwise = Nothing - where startsNullByte = - (BS.take 1 bs) == (integerToBS 0x00) - i = bsToInteger bs - n = ECDSA.ecc_n (ECDSA.common_curve curveECDSA) - checkIfValid - | i >= 1 && i <= n = Just $ PrivateKey curveECDSA i - | otherwise = Nothing - - - - -exportSignature :: ECDSA.Signature -> ByteString -exportSignature (Signature r s) = (integerToBS r) <> (integerToBS s) - - --- Assumes ByteString is not base 16. - -importSignature :: ByteString -> Maybe Signature -importSignature bs | BS.length bs == 64 = Just makeSignature - | otherwise = Nothing - where (rBS, sBS) = BS.splitAt 32 bs - makeSignature = Signature (bsToInteger rBS) (bsToInteger sBS) - - - - ---------- ECDSA HELPER FUNCTIONS --------- - -keccak256Hash :: ByteString -> ByteString -keccak256Hash = - BS.pack . BA.unpack . (H.hash :: BA.Bytes -> H.Digest H.Keccak_256) . BA.pack . BS.unpack - - -integerToBS :: Integer -> ByteString -integerToBS = i2osp - - -bsToInteger :: ByteString -> Integer -bsToInteger = os2ip diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs index a851102a4..9e6c3c25f 100644 --- a/src/Pact/Types/Runtime.hs +++ b/src/Pact/Types/Runtime.hs @@ -198,6 +198,8 @@ data ExecutionFlag | FlagDisableRuntimeReturnTypeChecking -- | Disable Pact 4.8 Features | FlagDisablePact48 + -- | Disable Pact 4.9 Features + | FlagDisablePact49 deriving (Eq,Ord,Show,Enum,Bounded) -- | Flag string representation diff --git a/src/Pact/Types/Scheme.hs b/src/Pact/Types/Scheme.hs index 9df9e1ce8..d0dbbd4db 100644 --- a/src/Pact/Types/Scheme.hs +++ b/src/Pact/Types/Scheme.hs @@ -18,6 +18,7 @@ import GHC.Generics import Control.DeepSeq import Data.Kind (Type) import Data.Serialize +import qualified Data.Text as T import Data.Aeson import Test.QuickCheck @@ -28,20 +29,29 @@ import qualified Pact.JSON.Encode as J --------- PPKSCHEME DATA TYPE --------- -data PPKScheme = ED25519 | ETH +data PPKScheme = ED25519 | WebAuthn deriving (Show, Eq, Ord, Generic, Bounded, Enum) - instance NFData PPKScheme instance Serialize PPKScheme +instance ToJSON PPKScheme where + toJSON ED25519 = "ED25519" + toJSON WebAuthn = "WebAuthn" + + toEncoding ED25519 = toEncoding @T.Text "ED25519" + toEncoding WebAuthn = toEncoding @T.Text "WebAuthn" + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + instance FromJSON PPKScheme where parseJSON = withText "PPKScheme" parseText {-# INLINE parseJSON #-} + instance ParseText PPKScheme where parseText s = case s of "ED25519" -> return ED25519 - "ETH" -> return ETH + "WebAuthn" -> return WebAuthn _ -> fail $ "Unsupported PPKScheme: " ++ show s {-# INLINE parseText #-} @@ -50,7 +60,7 @@ instance Arbitrary PPKScheme where instance J.Encode PPKScheme where build ED25519 = J.text "ED25519" - build ETH = J.text "ETH" + build WebAuthn = J.text "WebAuthn" {-# INLINE build #-} @@ -62,7 +72,7 @@ defPPKScheme = ED25519 data SPPKScheme :: PPKScheme -> Type where SED25519 :: SPPKScheme 'ED25519 - SETH :: SPPKScheme 'ETH + SWebAuthn :: SPPKScheme 'WebAuthn instance Show (SPPKScheme a) where show SED25519 = show ED25519 - show SETH = show ETH + show SWebAuthn = show WebAuthn diff --git a/src/Pact/Types/Util.hs b/src/Pact/Types/Util.hs index 6021da0c4..160ad1984 100644 --- a/src/Pact/Types/Util.hs +++ b/src/Pact/Types/Util.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Pact.Types.Util @@ -156,8 +157,8 @@ parseB16JSON = withText "Base16" parseB16Text parseB16Text :: Text -> Parser ByteString parseB16Text t = case B16.decode (encodeUtf8 t) of - (s,leftovers) | leftovers == B.empty -> return s - | otherwise -> fail $ "Base16 decode failed: " ++ show t + Right bs -> return bs + Left _ -> fail $ "Base16 decode failed: " ++ show t {-# INLINE parseB16Text #-} parseB16TextOnly :: Text -> Either String ByteString @@ -331,4 +332,3 @@ arbitraryIdent = cons syms = "%#+-_&$@<>=^?*!|/~" letters = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZñûüùúūÛÜÙÚŪß" digits = "0123456789" - diff --git a/tests/ClientSpec.hs b/tests/ClientSpec.hs index 487931f5a..5a47d83d4 100644 --- a/tests/ClientSpec.hs +++ b/tests/ClientSpec.hs @@ -16,18 +16,19 @@ import Pact.Server.API import Servant.Client import Pact.Types.Runtime import Pact.Types.PactValue +import Pact.Types.Crypto (genKeyPair) import Utils simpleServerCmd :: IO (Command Text) simpleServerCmd = do - simpleKeys <- genKeys + simpleKeys <- genKeyPair mkExec "(+ 1 2)" Null def [(simpleKeys,[])] Nothing (Just "test1") simpleServerCmdWithPactErr :: IO (Command Text) simpleServerCmdWithPactErr = do - simpleKeys <- genKeys + simpleKeys <- genKeyPair mkExec "(+ 1 2 3)" Null def [(simpleKeys,[])] Nothing (Just "test1") spec :: Spec diff --git a/tests/PactContinuationSpec.hs b/tests/PactContinuationSpec.hs index 2ddd672ce..3cc0d5805 100644 --- a/tests/PactContinuationSpec.hs +++ b/tests/PactContinuationSpec.hs @@ -165,7 +165,7 @@ _runArgs args = withArgs (words args) $ hspec spec testOldNestedPacts :: Spec testOldNestedPacts = do it "throws error when multiple defpact executions occur in same transaction" $ do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (threeStepPactCode "nestedPact") @@ -235,7 +235,7 @@ testNestedPactContinuation = do testSimpleServerCmd :: IO (Maybe (CommandResult Hash)) testSimpleServerCmd = do - simpleKeys <- genKeys + simpleKeys <- genKeyPair cmd <- mkExec "(+ 1 2)" Null def [(simpleKeys,[])] Nothing (Just "test1") allResults <- runAll [cmd] return $ HM.lookup (cmdToRequestKey cmd) allResults @@ -243,7 +243,7 @@ testSimpleServerCmd = do testCorrectNextStep :: Text -> Text -> [ExecutionFlag] -> Expectation testCorrectNextStep code command flags = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith code executePactCmd <- makeExecCmdWith command @@ -334,7 +334,7 @@ threeStepNestedPactCode moduleName = testIncorrectNextStep :: Text -> Text -> [ExecutionFlag] -> Expectation testIncorrectNextStep code command flags = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith code @@ -354,7 +354,7 @@ testIncorrectNextStep code command flags = do testLastStep :: Text -> Text -> [ExecutionFlag] -> Expectation testLastStep code command flags = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith code @@ -379,7 +379,7 @@ testLastStep code command flags = do testErrStep :: Text -> Text -> [ExecutionFlag] -> Expectation testErrStep code command flags = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith code @@ -465,7 +465,7 @@ testPactRollback = do testCorrectRollbackStep :: Expectation testCorrectRollbackStep = do let moduleName = "testCorrectRollbackStep" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (pactWithRollbackCode moduleName) @@ -504,7 +504,7 @@ pactWithRollbackCode moduleName = testIncorrectRollbackStep :: Expectation testIncorrectRollbackStep = do let moduleName = "testIncorrectRollbackStep" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (pactWithRollbackCode moduleName) @@ -529,7 +529,7 @@ testIncorrectRollbackStep = do testRollbackErr :: Expectation testRollbackErr = do let moduleName = "testRollbackErr" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (pactWithRollbackErrCode moduleName) @@ -566,7 +566,7 @@ pactWithRollbackErrCode moduleName = testNoRollbackFunc :: Expectation testNoRollbackFunc = do let moduleName = "testNoRollbackFunc" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (threeStepPactCode moduleName) @@ -663,7 +663,7 @@ testNestedPactYield = do -- a fresh server to prove that a new pact coming through -- SPV can start from step 1. step0 = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd' (Just "xchain") adminKeys moduleCmd <- makeExecCmdWith nestedPactCrossChainYield @@ -740,7 +740,7 @@ testNestedPactYield = do testValidYield :: Text -> (Text -> Text) -> [ExecutionFlag] -> Expectation testValidYield moduleName mkCode flags = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (mkCode moduleName) @@ -825,7 +825,7 @@ nestedPactWithYield moduleName = testNoYield :: Text -> (Text -> Text) -> [ExecutionFlag] -> Expectation testNoYield moduleName mkCode flags = do -- let moduleName = "testNoYield" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (mkCode moduleName) @@ -897,7 +897,7 @@ nestedPactWithYieldErr moduleName = testResetYield :: Text -> (Text -> Text) -> [ExecutionFlag] -> Expectation testResetYield moduleName mkCode flags = do -- let moduleName = "testResetYield" - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd adminKeys moduleCmd <- makeExecCmdWith (mkCode moduleName) @@ -997,7 +997,7 @@ testCrossChainYield blessCode expectFailure mkSpvSupport backCompat spvFlags = s -- a fresh server to prove that a new pact coming through -- SPV can start from step 1. step0 = do - adminKeys <- genKeys + adminKeys <- genKeyPair let makeExecCmdWith = makeExecCmd' (Just "xchain") adminKeys moduleCmd <- makeExecCmdWith (pactCrossChainYield "") @@ -1351,38 +1351,44 @@ failsWith' cmd r = shouldMatch cmd (resultShouldBe $ Left r) runResults :: r -> ReaderT r m a -> m a runResults rs act = runReaderT act rs -makeExecCmd :: SomeKeyPair -> Text -> IO (Command Text) +makeExecCmd :: Ed25519KeyPair -> Text -> IO (Command Text) makeExecCmd keyPairs code = makeExecCmd' Nothing keyPairs code -makeExecCmd' :: Maybe Text -> SomeKeyPair -> Text -> IO (Command Text) +makeExecCmd' :: Maybe Text -> Ed25519KeyPair -> Text -> IO (Command Text) makeExecCmd' nonce keyPairs code = mkExec code (object ["admin-keyset" .= [formatPubKeyForCmd keyPairs]]) def [(keyPairs,[])] Nothing nonce -formatPubKeyForCmd :: SomeKeyPair -> T.Text -formatPubKeyForCmd kp = toB16Text $ formatPublicKey kp +formatPubKeyForCmd :: Ed25519KeyPair -> Value +formatPubKeyForCmd kp = toJSON $ toB16Text $ getPublic kp makeContCmd - :: SomeKeyPair -- signing pair - -> Bool -- isRollback - -> Value -- data - -> Command Text -- cmd to get pact Id from - -> Int -- step - -> Text -- nonce + :: Ed25519KeyPair -- signing pair + -> Bool -- isRollback + -> Value -- data + -> Command Text -- cmd to get pact Id from + -> Int -- step + -> Text -- nonce -> IO (Command Text) makeContCmd = makeContCmd' Nothing makeContCmd' :: Maybe ContProof - -> SomeKeyPair -- signing pair - -> Bool -- isRollback - -> Value -- data - -> Command Text -- cmd to get pact Id from - -> Int -- step - -> Text -- nonce + -> Ed25519KeyPair + -- ^ signing pair + -> Bool + -- ^ isRollback + -> Value + -- ^ data + -> Command Text + -- ^ cmd to get pact Id from + -> Int + -- ^ step + -> Text + -- ^ nonce -> IO (Command Text) makeContCmd' contProofM keyPairs isRollback cmdData pactExecCmd step nonce = mkCont (getPactId pactExecCmd) step isRollback cmdData def [(keyPairs,[])] (Just nonce) contProofM Nothing diff --git a/tests/SchemeSpec.hs b/tests/SchemeSpec.hs index 4b67172b1..d45237c67 100644 --- a/tests/SchemeSpec.hs +++ b/tests/SchemeSpec.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module SchemeSpec (spec) where import Test.Hspec import System.IO.Error +import qualified Data.ByteString.Base16 as Base16 +import Data.Either (fromRight) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Text.Encoding import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -17,7 +22,7 @@ import qualified Data.ByteString.Base16 as B16 import Pact.ApiReq import Pact.Types.Crypto import Pact.Types.Command -import Pact.Types.Util (toB16Text, fromJSON') +import Pact.Types.Util (toB16Text, fromJSON', fromText') import Pact.Types.RPC import Pact.Types.Hash import Pact.JSON.Legacy.Value @@ -27,22 +32,16 @@ import qualified Pact.JSON.Encode as J ---- HELPER DATA TYPES AND FUNCTIONS ---- getByteString :: ByteString -> ByteString -getByteString = fst . B16.decode +getByteString = fromRight (error "Expected valid base-16") . B16.decode type Address = Maybe Text -getKeyPairComponents :: SomeKeyPairCaps -> (PublicKeyBS, PrivateKeyBS, Address, PPKScheme) +getKeyPairComponents :: Ed25519KeyPairCaps -> (PublicKeyBS, PrivateKeyBS, Address, PPKScheme) getKeyPairComponents (kp,_) = (PubBS $ getPublic kp, PrivBS $ getPrivate kp, - addy, - scheme) - where - scheme = kpToPPKScheme kp - addy = case scheme of - ED25519 -> Nothing - ETH -> Just $ toB16Text $ formatPublicKey kp - + Nothing, + ED25519) someED25519Pair :: (PublicKeyBS, PrivateKeyBS, Address, PPKScheme) someED25519Pair = (PubBS $ getByteString @@ -52,17 +51,21 @@ someED25519Pair = (PubBS $ getByteString Nothing, ED25519) +anotherED25519Pair :: (PublicKeyBS, PrivateKeyBS, Address, PPKScheme) +anotherED25519Pair = (PubBS $ getByteString + "6866b33e7935752bb972f363fe0567902616075878392ff7159f5fd4a2672827", + PrivBS $ getByteString + "7693e641ae2bbe9ea802c736f42027b03f86afe63cae315e7169c9c496c17331", + Just "6866b33e7935752bb972f363fe0567902616075878392ff7159f5fd4a2672827", + ED25519) - - -someETHPair :: (PublicKeyBS, PrivateKeyBS, Address, PPKScheme) -someETHPair = (PubBS $ getByteString - "836b35a026743e823a90a0ee3b91bf615c6a757e2b60b9e1dc1826fd0dd16106f7bc1e8179f665015f43c6c81f39062fc2086ed849625c06e04697698b21855e", - PrivBS $ getByteString - "208065a247edbe5df4d86fbdc0171303f23a76961be9f6013850dd2bdc759bbb", - Just $ "0bed7abd61247635c1973eb38474a2516ed1d884", - ETH) - +someWebAuthnSignature :: (UserSig, PublicKeyBS) +someWebAuthnSignature = (sig, pubKey) + where + sig = UserSig "{\"authenticatorData\":\"+cNxurbmvuKrkAKBTgIRX89NPS7FT5KydvqIN951zwoBAAAADQ==\",\"clientDataJSON\":\"eyJ0eXBlIjoid2ViYXV0aG4uZ2V0IiwiY2hhbGxlbmdlIjoiTkFDbG5makJiT2o3R2ZuRTg2YzJOZVZHaTBZUkRKcllidUF0cmhFUzJiYyIsIm9yaWdpbiI6Imh0dHBzOi8vZ3JlZy10ZXN0aW5nLTIwMjMtMDItMDcuZ2l0aHViLmlvIiwiY3Jvc3NPcmlnaW4iOmZhbHNlfQ\",\"signature\":\"MEYCIQDwQF19+Wjxs0boANssWEKoUFKhwHgiaycIeU5kRlY+RwIhAIAfCOUDVHr5aCrVQ1pbvCEw1xkeF0s4yjD48sDe9uO7\"}" + pubKey = case Base16.decode "a5010203262001215820025b213619e0cbeadf7a4c62784f865d61c4da9268c724fa133efcf90ca7e00222582062ab25b410da272d9f2505b509bf599ac04f34888fad7cbb107d368add79edf1" of + Left _ -> error "Hex pubkey is valid." + Right k -> PubBS k toApiKeyPairs :: [(PublicKeyBS, PrivateKeyBS, Address, PPKScheme)] -> [ApiKeyPair] toApiKeyPairs kps = map makeAKP kps @@ -70,7 +73,7 @@ toApiKeyPairs kps = map makeAKP kps ApiKeyPair priv (Just pub) add (Just scheme) Nothing -mkCommandTest :: [SomeKeyPairCaps] -> [Signer] -> Text -> IO (Command ByteString) +mkCommandTest :: [Ed25519KeyPairCaps] -> [Signer] -> Text -> IO (Command ByteString) mkCommandTest kps signers code = mkCommand' kps $ toExecPayload signers code @@ -100,11 +103,10 @@ spec :: Spec spec = describe "working with crypto schemes" $ do describe "test importing Key Pair for each Scheme" testKeyPairImport describe "test default scheme in ApiKeyPair" testDefSchemeApiKeyPair - describe "test for correct address in ApiKeyPair" testAddrApiKeyPair describe "test PublicKey import" testPublicKeyImport - describe "test UserSig creation and verificaton" testUserSig describe "test signature non-malleability" testSigNonMalleability describe "testSigsRoundtrip" testSigsRoundtrip + describe "test webauthn signature verification" verifyWebAuthnSignature testKeyPairImport :: Spec testKeyPairImport = do @@ -112,11 +114,6 @@ testKeyPairImport = do kp <- mkKeyPairs (toApiKeyPairs [someED25519Pair]) (map getKeyPairComponents kp) `shouldBe` [someED25519Pair] - it "imports ETH Key Pair" $ do - kp <- mkKeyPairs (toApiKeyPairs [someETHPair]) - (map getKeyPairComponents kp) `shouldBe` [someETHPair] - - testDefSchemeApiKeyPair :: Spec testDefSchemeApiKeyPair = @@ -129,51 +126,30 @@ testDefSchemeApiKeyPair = -testAddrApiKeyPair :: Spec -testAddrApiKeyPair = - it "throws error when address provided in API doesn't match derived address" $ do - let (pub, priv, _, scheme) = someETHPair - apiKP = ApiKeyPair priv (Just pub) - (Just "9f491e44a3f87df60d6cb0eefd5a9083ae6c3f32") (Just scheme) - Nothing - mkKeyPairs [apiKP] `shouldThrow` isUserError - - - testPublicKeyImport :: Spec testPublicKeyImport = do it "derives PublicKey from the PrivateKey when PublicKey not provided" $ do - let (_, priv, addr, scheme) = someETHPair + let (_, priv, addr, scheme) = someED25519Pair apiKP = ApiKeyPair priv Nothing addr (Just scheme) Nothing kp <- mkKeyPairs [apiKP] - (map getKeyPairComponents kp) `shouldBe` [someETHPair] + (map getKeyPairComponents kp) `shouldBe` [someED25519Pair] it "throws error when PublicKey provided does not match derived PublicKey" $ do - let (_, priv, addr, scheme) = someETHPair + let (_, priv, addr, scheme) = someED25519Pair fakePub = PubBS $ getByteString "c640e94730fb7b7fce01b11086645741fcb5174d1c634888b9d146613730243a171833259cd7dab9b3435421dcb2816d3efa55033ff0899de6cc8b1e0b20e56c" apiKP = ApiKeyPair priv (Just fakePub) addr (Just scheme) Nothing mkKeyPairs [apiKP] `shouldThrow` isUserError -testUserSig :: Spec -testUserSig = do - it "successfully verifies user-provided ETH Signature" $ do - let hsh = hash "(somePactFunction)" - userSig = UserSig - "780c2a6d11baae240a2888c4cfa7243dabba26b6121e68d0ea3b3dff779024c0c847eff27c6499ea29e7aea5f5744b98e550f6e3f7514d08c6cc2230564a1339" - [signer] <- toSigners [someETHPair] - (verifyUserSig hsh userSig signer) `shouldBe` True - - it "fails UserSig validation when UserSig has unexpected Address" $ do let hsh = hash "(somePactFunction)" - (_,_,wrongAddr,_) = someETHPair + (_,_,wrongAddr,_) = anotherED25519Pair [signer] <- toSigners [someED25519Pair] - [(kp,_)] <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] - sig <- sign kp (toUntypedHash hsh) + [((pubKey, privKey),_)] <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] + sig <- sign pubKey privKey (toUntypedHash hsh) let myUserSig = UserSig (toB16Text sig) wrongSigner = Lens.set siAddress wrongAddr signer (verifyUserSig hsh myUserSig wrongSigner) `shouldBe` False @@ -183,10 +159,10 @@ testUserSig = do it "fails UserSig validation when UserSig has unexpected Scheme" $ do let hsh = hash "(somePactFunction)" [signer] <- toSigners [someED25519Pair] - [(kp,_)] <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] - sig <- sign kp (toUntypedHash hsh) + [((pubKey, privKey),_)] <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] + sig <- sign pubKey privKey (toUntypedHash hsh) let myUserSig = UserSig (toB16Text sig) - wrongScheme = ETH + wrongScheme = WebAuthn wrongSigner = Lens.set siScheme (Just wrongScheme) signer (verifyUserSig hsh myUserSig wrongSigner) `shouldBe` False @@ -210,8 +186,8 @@ testUserSig = do testSigNonMalleability :: Spec testSigNonMalleability = do it "fails when invalid signature provided for signer specified in the payload" $ do - wrongSigners <- toSigners [someED25519Pair] - kps <- mkKeyPairs $ toApiKeyPairs [someETHPair] + wrongSigners <- toSigners [anotherED25519Pair] + kps <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] cmdWithWrongSig <- mkCommandTest kps wrongSigners "(somePactFunction)" shouldBeProcFail (verifyCommand cmdWithWrongSig) @@ -219,8 +195,8 @@ testSigNonMalleability = do it "fails when number of signatures does not match number of payload signers" $ do - [signer] <- toSigners [someETHPair] - [kp] <- mkKeyPairs $ toApiKeyPairs [someETHPair] + [signer] <- toSigners [anotherED25519Pair] + [kp] <- mkKeyPairs $ toApiKeyPairs [anotherED25519Pair] [wrongKp] <- mkKeyPairs $ toApiKeyPairs [someED25519Pair] cmdWithWrongNumSig <- mkCommandTest [kp, wrongKp] [signer] "(somePactFunction)" @@ -241,3 +217,65 @@ testSigsRoundtrip = it "SigsRoundtrip succeeds" $ do combineSigsRes <- combineSigs ["tests/sign-scripts/add-sigs.yaml", "tests/sign-scripts/bare-sig.yaml"] False combineSigsExpected <- BS.readFile "tests/sign-scripts/combineSigsExpected.yaml" T.strip (decodeUtf8 combineSigsRes) `shouldBe` T.strip (decodeUtf8 combineSigsExpected) + +-- This test uses example public keys, clientData and authenticatorData from a +-- real WebAuthn browser session from a test user. +verifyWebAuthnSignature :: Spec +verifyWebAuthnSignature = describe "WebAuthn signature" $ do + it "should verify a webauthn signature" $ do + let + (webAuthnSig, PubBS pubKey) = someWebAuthnSignature + pubKeyBase16 = T.decodeUtf8 $ Base16.encode pubKey + cmdHash' = case fromText' $ T.pack "NAClnfjBbOj7GfnE86c2NeVGi0YRDJrYbuAtrhES2bc" of + Right h -> h + Left _ -> error "Hash is valid" + signer = Signer + { _siScheme = Just WebAuthn + , _siPubKey = pubKeyBase16 + , _siAddress = Nothing + , _siCapList = [] + } + verifyUserSig cmdHash' webAuthnSig signer `shouldBe` True + it "should require a matching pubkey" $ do + let + (webAuthnSig, _) = someWebAuthnSignature + (PubBS otherPubKey, _, _, _) = someED25519Pair + pubKeyBase16 = T.decodeUtf8 $ Base16.encode otherPubKey + cmdHash' :: TypedHash Blake2b_256 = case fromText' $ T.pack "NAClnfjBbOj7GfnE86c2NeVGi0YRDJrYbuAtrhES2bc" of + Right h -> h + Left _ -> error "Hash is valid" + signer = Signer + { _siScheme = Just WebAuthn + , _siPubKey = pubKeyBase16 + , _siAddress = Nothing + , _siCapList = [] + } + verifyUserSig cmdHash' webAuthnSig signer `shouldBe` False + it "should require a matching cmdHash" $ do + let + (webAuthnSig, PubBS pubKey) = someWebAuthnSignature + pubKeyBase16 = T.decodeUtf8 $ Base16.encode pubKey + cmdHash' :: TypedHash Blake2b_256 = case fromText' $ T.pack "3fbc092db9350757e2ab4f7ee9792bfcd2f5220ada5a4bc684487f60c6034369" of + Right h -> h + Left _ -> error "Hash is valid" + signer = Signer + { _siScheme = Just WebAuthn + , _siPubKey = pubKeyBase16 + , _siAddress = Nothing + , _siCapList = [] + } + verifyUserSig cmdHash' webAuthnSig signer `shouldBe` False + it "should require webauthn scheme" $ do + let + (webAuthnSig, PubBS pubKey) = someWebAuthnSignature + pubKeyBase16 = T.decodeUtf8 $ Base16.encode pubKey + cmdHash' :: TypedHash Blake2b_256 = case fromText' $ T.pack "NAClnfjBbOj7GfnE86c2NeVGi0YRDJrYbuAtrhES2bc" of + Right h -> h + Left _ -> error "Hash is valid" + signer = Signer + { _siScheme = Nothing + , _siPubKey = pubKeyBase16 + , _siAddress = Nothing + , _siCapList = [] + } + verifyUserSig cmdHash' webAuthnSig signer `shouldBe` False diff --git a/tests/Utils.hs b/tests/Utils.hs index 88299eeb0..dc7617987 100644 --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -8,7 +8,6 @@ module Utils , testFlags , backCompatFlags , nestedDefPactFlags -, genKeys , testDir ) where @@ -30,7 +29,6 @@ import System.IO.Unsafe import Pact.Server.API import Pact.Server.Server -import Pact.Types.Crypto as Crypto import Pact.Types.Runtime import Pact.Types.SPV @@ -46,9 +44,6 @@ testMgr = unsafePerformIO $ HTTP.newManager HTTP.defaultManagerSettings -- -------------------------------------------------------------------------- -- -- Constants -genKeys :: IO SomeKeyPair -genKeys = genKeyPair defaultScheme - testDir :: FilePath testDir = "tests/" diff --git a/tests/pact/base64.repl b/tests/pact/base64.repl index d8ad62b1c..787294f81 100644 --- a/tests/pact/base64.repl +++ b/tests/pact/base64.repl @@ -1,5 +1,7 @@ ; round trip +(env-exec-config ["DisablePact49"]) + (expect "Base64 decode sanity check" "hello world!" @@ -22,30 +24,42 @@ (expect-failure "base64 decoding fails on non base64-encoded input" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid padding near offset 16" (base64-decode "aGVsbG8gd29ybGQh%")) (expect-failure "base64 decoding fails on garbage input 1" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid unicode" (base64-decode "aaa")) (expect-failure "base64 decoding fails on garbage input 2" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid unicode" (base64-decode "asdflk")) (expect-failure "base64 decoding fails on garbage input 3" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid base64 encoding near offset 0" (base64-decode "!@#$%&")) (expect-failure "base64 decoding fails on garbage input 4" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid base64 encoding near offset 0" (base64-decode "\x0237")) (expect-failure "base64 decoding fails on garbage input 5" - "Could not decode string" + "Could not decode string: Base64URL decode failed: invalid base64 encoding near offset 0" (base64-decode "+\x0000")) + +(expect + "base64 decoding succeeds on non-canonical encodings" + "d" + (base64-decode "ZE==")) + +(env-exec-config []) + +(expect-failure + "base64 decoding fails on non-canonical encodings" + "Could not base64-decode string" + (base64-decode "ZE==")) diff --git a/tests/pact/lib.repl b/tests/pact/lib.repl index 49c60f3ee..62b975501 100644 --- a/tests/pact/lib.repl +++ b/tests/pact/lib.repl @@ -3,13 +3,6 @@ (expect "env-hash" "Set tx hash to YQo" (env-hash "YQo")) -;; versions of base64-bytestring < 1.2 accept invalid base64 encodings. The -;; following test case is expected to fail after upgrading to -;; base64-bytestring > 1.2.0.0. This would be a breaking change and it must -;; be guaranteed that mainnet history isn't affected. -;; (expect-failure "env-hash invalid base64" (env-hash "aa")) -(expect "env-hash invalid base64" "Set tx hash to aa" (env-hash "aa")) - ;; TODO use expect-that for above tests (expect-that "expect-that test" (< 2) (+ 1 2)) diff --git a/tests/pact/scheme.repl b/tests/pact/scheme.repl deleted file mode 100644 index 2482857b7..000000000 --- a/tests/pact/scheme.repl +++ /dev/null @@ -1,88 +0,0 @@ -(begin-tx) -(env-exec-config ['DisablePact44]) -(env-data { "ED25519All": ["7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804" - "ac69d9856821f11b8e6ca5cdd84a98ec3086493fd6407e74ea9038407ec9eba9"] }) -(define-keyset "ked25519All" (read-keyset "ED25519All")) - - -(env-data { "ethAll": ["db8304f325524279d9a34706932a6a07ebfc5c97" - "9f491e44a3f87df60d6cb0eefd5a9083ae6c3f32" - "1dc3794f3079b380e26b26a5835c04b9497d0908" - "bc6314c12b78a21d2fd6a8eec8e78936ce9a86e1" - "612ac19e1ac0e5feb47737560930adeba57baf3f" - "24f3ae0fc699ff2287365684a50cdaa8e69996dd"] }) -(define-keyset "kethAll" (read-keyset "ethAll")) - - -(define-keyset "k" (sig-keyset)) -(module scheme "k" - (defun test-all-ed25519 () - (enforce-keyset "ked25519All")) - (defun test-all-eth () - (enforce-keyset "kethAll")) -) -(commit-tx) - - - -;; Test that all PPKScheme's Public Keys transformed into expected Address - -(begin-tx) -(use scheme) - -(env-keys [(format-address "ED25519" - "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804") - (format-address "ED25519" - "ac69d9856821f11b8e6ca5cdd84a98ec3086493fd6407e74ea9038407ec9eba9") ]) -(expect "ED25519 public keys transformed into expected address" true (test-all-ed25519) ) - - -(env-keys [(format-address "ETH" - "8281c43fe803b508e2f3fdae7aa2c22db9c337e62806658c5fa67b137a5f82bafc74ea853feddf85c89d61c31f191f7e398a3b793004a7a7380ac72e2861ed33") - (format-address "ETH" - "c640e94730fb7b7fce01b11086645741fcb5174d1c634888b9d146613730243a171833259cd7dab9b3435421dcb2816d3efa55033ff0899de6cc8b1e0b20e56c") - (format-address "ETH" - "0e72033edfce78e0b74d07bb275312179af22ae38feaccecfbdd8728f816e5c938aed5015098af1dd0a135681118410f95f9036b2f16ff51a1bf3d6d23faa82b") - (format-address "ETH" - "558c704562332c798b1858f3a3e443dcf630d072e348a4466195c72a107b88cb588b49a70c36c41f4e2488b21b8f376f464b02074bea1f68ddb3c325465cf5a3") - (format-address "ETH" - "ef082370011f8c0f6ac2b5ab965b84f7141a1057ce55b9cc815f8d339b7b8168713e4a4b51982307f827199bbd9d6c94be3f93def86601c74772a52ca9631251") - (format-address "ETH" - "3ff4aa2504039f415b9e1a4f745da396a26f60c9370d5ef2f0c0778852f5e3b9d05780ea52bc0448714516c0315d0907f22419439613d0087d76e580c39b4a7a") ]) -(expect "ETH public keys transformed into expected address" true (test-all-eth)) - -(commit-tx) - - -(begin-tx) -(expect-failure "Fails with invalid scheme" (format-address "IVALIDSCHEME" "SomePublicKey")) -(expect-failure "Fails when Public Key not hex encoded" (format-address "ETH" "SomeNonB16PublicKey")) - -(expect-failure "Fails with invalid ED25519 Public Key" (format-address "ED25519" "8281c43fe803b508e2f3fdae7aa2c22db9c337e62806658c5fa67b137a5f82bafc74ea853feddf85c89d61c31f191f7e398a3b793004a7a7380ac72e2861ed33")) -(expect-failure "Fails with invalid ETH Public Key" (format-address "ETH" "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804")) -(expect-failure "Fails with empty ED25519 Public Key" (format-address "ED25519" "")) -(expect-failure "Fails with empty ETH Public Key" (format-address "ETH" "")) - - -;; ED25519 Unit Tests -(expect "ED25519 Address is equivalent to its Public Key" - "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804" - (format-address "ED25519" - "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804")) - -;; Source: https://kobl.one/blog/create-full-ethereum-keypair-and-address/ -;; ETH Unit Tests -(expect "ECDSA Public Key converted to valid Ethereum Address" - "0bed7abd61247635c1973eb38474a2516ed1d884" - (format-address "ETH" "836b35a026743e823a90a0ee3b91bf615c6a757e2b60b9e1dc1826fd0dd16106f7bc1e8179f665015f43c6c81f39062fc2086ed849625c06e04697698b21855e")) - -;; ECDSA Unit Tests -(expect "65 bytes ECDSA Public Key begining with 0x04 == 64 bytes ECDSA Public Key" true - (= (format-address "ETH" "836b35a026743e823a90a0ee3b91bf615c6a757e2b60b9e1dc1826fd0dd16106f7bc1e8179f665015f43c6c81f39062fc2086ed849625c06e04697698b21855e") - (format-address "ETH" "04836b35a026743e823a90a0ee3b91bf615c6a757e2b60b9e1dc1826fd0dd16106f7bc1e8179f665015f43c6c81f39062fc2086ed849625c06e04697698b21855e") )) -(expect-failure "Fails when 65 bytes ECDSA Public begins with anything other than 0x04" - (format-address "ETH" "05836b35a026743e823a90a0ee3b91bf615c6a757e2b60b9e1dc1826fd0dd16106f7bc1e8179f665015f43c6c81f39062fc2086ed849625c06e04697698b21855e")) -(expect-failure "Fails with valid ECC public key, but invalid ECDSA public key" - (format-address "ETH" "ce986528af7141a1d30ddac009b57ff5ab945d7767969f42821c1bd8")) - -(commit-tx)