diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index f646c7e..4cd1aed 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -9,7 +9,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['8.8.4', '8.10.7', '9.0.2'] + ghc: ['9.6.4'] cabal: ['3.8'] os: ['ubuntu-20.04', 'ubuntu-22.04', 'macOS-latest'] @@ -29,12 +29,20 @@ jobs: ghc --version cabal --version - # Project Setup - - name: Create cabal.project.local - if: matrix.ghc == '9.0.2' || matrix.ghc == '8.10.7' + # System dependencies + - if: startsWith(matrix.os, 'macOS') + name: Set up system depdendencies run: | + brew install openssl + cat > cabal.project.local <= 4.13 && < 5 @@ -68,7 +70,6 @@ library , http-client , http-client-tls , http-types - , kadena-signing-api , katip , lens , lens-aeson @@ -79,6 +80,7 @@ library , network-uri , optparse-applicative , pact + , pact-json , process , resource-pool , retry @@ -86,6 +88,7 @@ library , scientific , servant , servant-client + , split , stm , stm-linkedlist , string-conv @@ -149,7 +152,6 @@ test-suite kda-tool-tests , http-client , http-client-tls , http-types - , kadena-signing-api , katip , lens , lens-aeson @@ -160,12 +162,14 @@ test-suite kda-tool-tests , network-uri , optparse-applicative , pact + , pact-json , process , resource-pool , retry , scientific , servant , servant-client + , split , stm , stm-linkedlist , string-conv diff --git a/src/AppMain.hs b/src/AppMain.hs index 47f8d0d..a327df2 100644 --- a/src/AppMain.hs +++ b/src/AppMain.hs @@ -9,11 +9,11 @@ module AppMain where import Control.Monad.IO.Class import Data.Aeson import Data.Default +import Data.String (fromString) import Katip import Network.HTTP.Client hiding (withConnection) import Network.HTTP.Client.TLS import Options.Applicative -import Options.Applicative.Help.Pretty hiding (()) import System.Directory import System.FilePath import System.IO @@ -81,7 +81,7 @@ appMain = do , header "kda - Command line tool for interacting with the Kadena blockchain" , footerDoc (Just theFooter) ] - theFooter = string $ unlines + theFooter = fromString $ unlines [ "Run the following command to enable tab completion:" , "" , "source <(kda --bash-completion-script `which kda`)" diff --git a/src/Commands/GenTx.hs b/src/Commands/GenTx.hs index d60de9a..b7ef37a 100644 --- a/src/Commands/GenTx.hs +++ b/src/Commands/GenTx.hs @@ -27,6 +27,7 @@ import Network.HTTP.Client.TLS import Network.HTTP.Types.Status --import Pact.ApiReq import qualified Pact.ApiReq as Pact +import qualified Pact.JSON.Encode as J import Pact.Types.Command import Pact.Types.SigData import System.IO @@ -100,7 +101,7 @@ genFromContents op tplContents useOldOutput = do cmds :: [Command Text] <- mapM (fmap snd . lift . Pact.mkApiReqCmd True "") apiReqs let chooseFormat i = if useOldOutput - then pure $ encodeText i + then pure $ encodeText $ J.toJsonViaEncode i else fmap encodeText $ sdToCsd i let outs :: [Text] = catMaybes $ map (chooseFormat <=< hush . commandToSigData) cmds let outPat = maybe (defaultOutPat augmentedVars) T.pack $ _genData_outFilePat gd diff --git a/src/Commands/Keygen.hs b/src/Commands/Keygen.hs index 517298a..d03cf14 100644 --- a/src/Commands/Keygen.hs +++ b/src/Commands/Keygen.hs @@ -15,15 +15,16 @@ import Pact.Types.Crypto import Keys import Types.KeyType import Utils +import Data.Base16.Types (extractBase16) ------------------------------------------------------------------------------ keygenCommand :: KeyType -> IO () keygenCommand kt = do case kt of Plain -> do - kp <- genKeyPair defaultScheme - putStrLn $ "public: " ++ T.unpack (encodeBase16 $ getPublic kp) - putStrLn $ "secret: " ++ T.unpack (encodeBase16 $ getPrivate kp) + kp <- genKeyPair + putStrLn $ "public: " ++ T.unpack (extractBase16 $ encodeBase16 $ getPublic kp) + putStrLn $ "secret: " ++ T.unpack (extractBase16 $ encodeBase16 $ getPrivate kp) HD -> do let toPhrase = T.unwords . M.elems . mkPhraseMapFromMnemonic let prettyErr err = "ERROR generating menmonic: " <> tshow err diff --git a/src/Commands/Local.hs b/src/Commands/Local.hs index 4334cab..051005d 100644 --- a/src/Commands/Local.hs +++ b/src/Commands/Local.hs @@ -11,6 +11,7 @@ import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Trans import Data.Aeson +import Data.Aeson.Key import Data.Aeson.Lens import Data.Bifunctor import qualified Data.ByteString.Lazy as LB @@ -47,7 +48,7 @@ localCommand e (LocalCmdArgs args verifySigs shortOutput) = do printf "%s: testing %d commands on %d chains\n" (schemeHostPortToText shp) (length txs) (length groups) responses <- lift $ mapM (localNodeQuery le verifySigs n) txs - pure $ schemeHostPortToText shp .= map responseToValue responses + pure $ fromText (schemeHostPortToText shp) .= map responseToValue responses case res of Left er -> putStrLn er >> exitFailure Right results -> do diff --git a/src/Commands/Poll.hs b/src/Commands/Poll.hs index f16a592..dc7c05c 100644 --- a/src/Commands/Poll.hs +++ b/src/Commands/Poll.hs @@ -10,6 +10,7 @@ import Control.Error import Control.Monad import Control.Monad.Trans import Data.Aeson +import Data.Aeson.Key import Data.Bifunctor import qualified Data.ByteString.Lazy as LB import Data.Function @@ -46,7 +47,7 @@ pollCommand e args = do printf "%s: polling %d commands to %d chains\n" (schemeHostPortToText shp) (length txs) (length groups) responses <- lift $ mapM (\ts -> pollNode le n (txChain $ NE.head ts) (_transaction_hash <$> ts)) groups - pure $ schemeHostPortToText shp .= map responseToValue responses + pure $ fromText (schemeHostPortToText shp) .= map responseToValue responses case res of Left er -> putStrLn er >> exitFailure Right results -> T.putStrLn $ toS $ encode $ Object $ mconcat results diff --git a/src/Commands/Send.hs b/src/Commands/Send.hs index bd54cd6..280ef74 100644 --- a/src/Commands/Send.hs +++ b/src/Commands/Send.hs @@ -9,6 +9,7 @@ import Control.Error import Control.Monad import Control.Monad.Trans import Data.Aeson +import Data.Aeson.Key import Data.Bifunctor import qualified Data.ByteString.Lazy as LB import Data.Function @@ -48,7 +49,7 @@ sendCommand e args = do printf "%s: sending %d commands to %d chains\n" (schemeHostPortToText shp) (length txs) (length groups) responses <- lift $ mapM (sendToNode le n) groups - pure $ schemeHostPortToText shp .= map responseToValue responses + pure $ fromText (schemeHostPortToText shp) .= map responseToValue responses case res of Left er -> putStrLn er >> exitFailure Right results -> T.putStrLn $ toS $ encode $ Object $ mconcat results diff --git a/src/Commands/Sign.hs b/src/Commands/Sign.hs index ee14222..e746a9a 100644 --- a/src/Commands/Sign.hs +++ b/src/Commands/Sign.hs @@ -10,6 +10,7 @@ import qualified Cardano.Crypto.Wallet as Crypto import Control.Error import qualified Crypto.Hash as Crypto import Control.Monad.Except +import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteArray as BA import Data.List @@ -89,7 +90,7 @@ signYamlFile kkey mindex enc msgFile = do let pubHex = PublicKeyHex $ toB16 $ BA.convert pub if S.member pubHex signingKeys then do - let sig = UserSig $ toB16 $ BA.convert $ sign sec (calcHash $ encodeUtf8 cmd) + let sig = ED25519Sig $ toB16 $ BA.convert $ sign sec (calcHash $ encodeUtf8 cmd) hClose mh let newSigs = addSig pubHex sig sigs let csd2 = CommandSigData newSigs cmd @@ -110,7 +111,7 @@ tryHdIndex msgFile csd xprv mpass mind = do cmdBS = encodeUtf8 cmd signingKeys = S.fromList $ map _s_pubKey $ unSignatureList startingSigs signPairs = getSigningInds signingKeys xprv mpass (maybe [0..100] (:[]) mind) - f (esec, pub) = addSig pub (UserSig $ sigToText $ signHD esec (fromMaybe "" mpass) (calcHash cmdBS)) + f (esec, pub) = addSig pub (ED25519Sig $ sigToText $ signHD esec (fromMaybe "" mpass) (calcHash cmdBS)) newSigs = foldr f startingSigs signPairs let csd2 = CommandSigData newSigs cmd num1 = countSigs csd diff --git a/src/Commands/WalletSign.hs b/src/Commands/WalletSign.hs index 0c78534..a6a952f 100644 --- a/src/Commands/WalletSign.hs +++ b/src/Commands/WalletSign.hs @@ -8,6 +8,8 @@ module Commands.WalletSign ------------------------------------------------------------------------------ import Control.Error import Control.Lens +import Control.Monad +import Control.Monad.Trans import Control.Monad.Except import Data.Aeson.Lens import Data.List @@ -35,6 +37,7 @@ import Text.Printf import Types.Encoding import Types.Env import Utils +import Pact.JSON.Legacy.Value (LegacyValue(_getLegacyValue)) ------------------------------------------------------------------------------ walletSignCommand :: Env -> WalletSignArgs -> IO () @@ -161,7 +164,7 @@ csdToSigningRequest csd = do Continuation _ -> Left "Cannot sign CONT transactions with the old signing API" Exec m -> do let code = _pcCode $ _pmCode m - d = _pmData m ^? _Object + d = _getLegacyValue (_pmData m) ^? _Object let caps = map mkDappCap $ S.toList $ S.fromList $ concatMap _siCapList $ _pSigners p let n = Just $ _pNonce p meta = _pMeta p diff --git a/src/Kadena/SigningApi.hs b/src/Kadena/SigningApi.hs new file mode 100644 index 0000000..6124376 --- /dev/null +++ b/src/Kadena/SigningApi.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Kadena.SigningApi where + +import Control.Applicative((<|>)) +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import GHC.Generics +import Pact.Types.Capability (SigCapability(..)) +import Pact.Types.ChainMeta (TTLSeconds(..)) +import Pact.Types.Runtime (GasLimit(..), ChainId, PublicKeyText) +import Pact.Types.Command (Command) +import Servant.API + +import Kadena.SigningTypes + +-- | Values of this type are supplied by the dapp author to the wallet so the +-- wallet knows what capabilities need to be granted for the transaction. +data DappCap = DappCap + { _dappCap_role :: Text + -- ^ Short name for this capability that is meaningful to the user + , _dappCap_description :: Text + -- ^ More detailed information that the user might need to know + , _dappCap_cap :: SigCapability + -- ^ The actual capability + } deriving (Eq,Ord,Show,Generic) + +instance ToJSON DappCap where + toJSON = genericToJSON compactEncoding + toEncoding = genericToEncoding compactEncoding + +instance FromJSON DappCap where + parseJSON = genericParseJSON compactEncoding + +data SigningRequest = SigningRequest + { _signingRequest_code :: Text + , _signingRequest_data :: Maybe Object + , _signingRequest_caps :: [DappCap] + , _signingRequest_nonce :: Maybe Text + , _signingRequest_chainId :: Maybe ChainId + , _signingRequest_gasLimit :: Maybe GasLimit + , _signingRequest_ttl :: Maybe TTLSeconds + , _signingRequest_sender :: Maybe AccountName + , _signingRequest_extraSigners :: Maybe [PublicKeyText] + } deriving (Show, Generic) + +instance ToJSON SigningRequest where + toJSON = genericToJSON compactEncoding + toEncoding = genericToEncoding compactEncoding + +instance FromJSON SigningRequest where + parseJSON = genericParseJSON compactEncoding + +data SigningResponse = SigningResponse + { _signingResponse_body :: Command Text + , _signingResponse_chainId :: ChainId + } deriving (Eq, Show, Generic) + +instance ToJSON SigningResponse where + toJSON = genericToJSON compactEncoding + toEncoding = genericToEncoding compactEncoding + +instance FromJSON SigningResponse where + parseJSON = genericParseJSON compactEncoding + +-------------------------------------------------------------------------------- +newtype QuickSignRequest = QuickSignRequest + { _quickSignRequest_csds :: [CommandSigData] + } deriving (Show, Eq, Generic) + +instance ToJSON QuickSignRequest where + toJSON a = object ["cmdSigDatas" .= _quickSignRequest_csds a] + +instance FromJSON QuickSignRequest where + parseJSON = withObject "QuickSignRequest" $ \o -> do + cmd <- o .: "cmdSigDatas" + pure $ QuickSignRequest cmd + +data QuickSignResponse = + QSR_Response [CSDResponse] + | QSR_Error QuicksignError + deriving (Show, Eq, Generic) + +instance ToJSON QuickSignResponse where + toJSON a = case a of + QSR_Response responses -> object ["responses" .= responses] + QSR_Error e -> object ["error" .= e] + +instance FromJSON QuickSignResponse where + parseJSON = withObject "QuickSignResponse" $ \o -> do + (fmap QSR_Response $ o .: "responses") + <|> (fmap QSR_Error $ o.: "error") +-------------------------------------------------------------------------------- + +type SigningApi = "v1" :> V1SigningApi +type V1SigningApi = "sign" :> ReqBody '[JSON] SigningRequest :> Post '[JSON] SigningResponse + :<|> "quicksign" :> ReqBody '[JSON] QuickSignRequest :> Post '[JSON] QuickSignResponse + +signingAPI :: Proxy SigningApi +signingAPI = Proxy diff --git a/src/Kadena/SigningTypes.hs b/src/Kadena/SigningTypes.hs new file mode 100644 index 0000000..31589d6 --- /dev/null +++ b/src/Kadena/SigningTypes.hs @@ -0,0 +1,228 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Kadena.SigningTypes where + +import Control.Lens hiding ((.=)) +import Control.Monad +import qualified Data.Aeson as A +import Data.Aeson.Types +import qualified Data.ByteString.Lazy as BSL +import Data.Char as Char +import qualified Data.List.Split as L +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Generics + +import Pact.ApiReq +import qualified Pact.JSON.Encode as J +import Pact.Types.Capability (SigCapability(..)) +import Pact.Types.ChainMeta +import Pact.Types.Command +import Pact.Types.Hash +import Pact.Parse +import Pact.Types.Runtime (GasLimit(..), ChainId, NetworkId, PublicKeyText) +-- TODO: Rip out sig data dependency +import Pact.Types.SigData (PublicKeyHex(..)) + +-- The spec calls this `Signer` but it clashes too much with Pact`s `Signer` type +data CSDSigner = CSDSigner + { _s_pubKey :: PublicKeyHex + , _s_userSig :: Maybe UserSig + } deriving (Eq, Ord, Show, Generic) + +instance ToJSON CSDSigner where + toJSON (CSDSigner (PublicKeyHex pkh) mSig) = object $ + [ "pubKey" .= pkh + , "sig" .= sig + ] + where sig = mSig <&> \case + ED25519Sig s -> s + WebAuthnSig s -> T.decodeUtf8 $ BSL.toStrict $ J.encode s + +instance FromJSON CSDSigner where + parseJSON v = flip (withObject "Signer") v $ \o -> do + pk <- o .: "pubKey" + mSigTxt ::(Maybe Text) <- o.:? "sig" + mSig <- forM mSigTxt $ \sigTxt -> parseJSON $ object ["sig" .= sigTxt] + pure $ CSDSigner pk mSig + +-------------------------------------------------------------------------------- +newtype SignatureList = + SignatureList { unSignatureList :: [CSDSigner] } + deriving (Eq, Ord, Show, Semigroup, Monoid, Generic) + +instance ToJSON SignatureList where + toJSON = toJSONList . unSignatureList + +instance FromJSON SignatureList where + parseJSON = fmap SignatureList . parseJSON + +-------------------------------------------------------------------------------- +data CommandSigData = CommandSigData + { _csd_sigs :: SignatureList + , _csd_cmd :: Text + } deriving (Eq,Ord,Show,Generic) + +instance ToJSON CommandSigData where + toJSON (CommandSigData s c) = object $ + [ "sigs" .= s + , "cmd" .= c + ] + +instance FromJSON CommandSigData where + parseJSON = withObject "CommandSigData" $ \o -> do + s <- o .: "sigs" + -- TODO should we validate that this is actually a stringified payload here? + c <- o .: "cmd" + pure $ CommandSigData s c + +-------------------------------------------------------------------------------- +data SigningOutcome = + SO_Success PactHash + | SO_Failure Text + | SO_NoSig + deriving (Eq,Ord,Show,Generic) + +instance ToJSON SigningOutcome where + toJSON a = case a of + SO_Success h -> object ["result" .= ("success" :: Text), "hash" .= hashTxt ] + where hashTxt = hashToText $ toUntypedHash h + SO_Failure msg -> object ["result" .= ("failure" :: Text), "msg" .= msg ] + SO_NoSig -> object ["result" .= ("noSig" :: Text)] + +instance FromJSON SigningOutcome where + parseJSON = withObject "SigningOutcome" $ \o -> do + r <- o .: "result" + case r::Text of + "success" -> SO_Success <$> o .: "hash" + "failure" -> SO_Failure <$> o .: "msg" + "noSig" -> pure SO_NoSig + _ -> fail "ill-formed SigningOutcome" + +data CSDResponse = CSDResponse + { _csdr_csd :: CommandSigData + , _csdr_outcome :: SigningOutcome + } deriving (Eq,Ord,Show, Generic) + +instance ToJSON CSDResponse where + toJSON (CSDResponse csd o) = object $ + [ "commandSigData" .= csd + , "outcome" .= o + ] + +instance FromJSON CSDResponse where + parseJSON = withObject "CSDResponse" $ \o -> do + CSDResponse + <$> o .: "commandSigData" + <*> o .: "outcome" + +data QuicksignError = + QuicksignError_Reject + | QuicksignError_EmptyList + | QuicksignError_Other Text + deriving (Eq,Ord,Show,Generic) + +instance ToJSON QuicksignError where + toJSON a = case a of + QuicksignError_Reject -> object ["type" .= ("reject" :: Text)] + QuicksignError_EmptyList -> object ["type" .= ("emptyList" :: Text)] + QuicksignError_Other msg -> object ["type" .= ("other" :: Text) + , "msg" .= msg + ] + +instance FromJSON QuicksignError where + parseJSON = withObject "QuicksignError" $ \o -> do + t <- o .: "type" + case t::Text of + "reject" -> pure QuicksignError_Reject + "emptyList" -> pure QuicksignError_EmptyList + "other" -> fmap QuicksignError_Other $ o .: "msg" + _ -> fail "ill-formed QuicksignError" + +-------------------------------------------------------------------------------- +commandSigDataToCommand :: CommandSigData -> Either String (Command Text) +commandSigDataToCommand = fmap fst . commandSigDataToParsedCommand + +commandSigDataToParsedCommand :: CommandSigData -> Either String (Command Text, Payload PublicMeta ParsedCode) +commandSigDataToParsedCommand (CommandSigData (SignatureList sigList) c) = do + payload :: Payload PublicMeta ParsedCode <- traverse parsePact =<< A.eitherDecodeStrict' (T.encodeUtf8 c) + let sigMap = M.fromList $ (\(CSDSigner k v) -> (k, v)) <$> sigList + -- It is ok to use a map here because we're iterating over the signers list and only using the map for lookup. + sigs = catMaybes $ map (\signer -> join $ M.lookup (PublicKeyHex $ _siPubKey signer) sigMap) $ _pSigners payload + h = hash (T.encodeUtf8 c) + pure (Command c sigs h, payload) + +-------------------------------------------------------------------------------- +newtype AccountName = AccountName + { unAccountName :: Text + } deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +-- | Smart constructor for account names. The only restriction in the coin +-- contract (as it stands) appears to be that accounts can't be an empty string +mkAccountName :: Text -> Either Text AccountName +mkAccountName n = + if not (isValidCharset n) then Left "Invalid Character detected. Must be Latin1, no spaces, control characters or '|'" + else if not (isCorrectSize n) then Left "Incorrect length. Must be between 3 and 256 characters in length." + else Right $ AccountName n + +isCorrectSize :: Text -> Bool +isCorrectSize n = let l = T.length n in l >= 3 && l <= 256 + +isValidCharset :: Text -> Bool +isValidCharset = T.all isValidAccountNameCharacter + +isValidAccountNameCharacter :: Char -> Bool +isValidAccountNameCharacter char = Char.isLatin1 char + && not ( Char.isControl char || + char == '\NUL' + ) + +-- | Aeson encoding options for compact encoding. +-- +-- We pass on the most compact sumEncoding as it could be unsound for certain types. +-- +-- But we assume the following naming of constructor names (sum typs) and +-- field names (records): _TypeName_Blah and _typename_blah. +-- +-- In particular we assume that only the string after the last underscore is +-- significant for distinguishing field names/constructor names. If this +-- assumption is not met this encoding might not result in the same decoding. +compactEncoding :: Options +compactEncoding = defaultOptions + { A.fieldLabelModifier = shortener + , A.allNullaryToStringTag = True + , A.constructorTagModifier = shortener + , A.omitNothingFields = True + , A.sumEncoding = ObjectWithSingleField + , A.unwrapUnaryRecords = True + , A.tagSingleConstructors = False + } + where + -- As long as names are not empty or just underscores this head should be fine: + shortener = head . reverse . filter (/= "") . L.splitOn "_" + +------------------- ORPHANS ------------------- +-- We're defining these orphans here because Pact moved away from `ToJSON` to +-- pact-json's Encode typeclass, which is equivalent to aeson's `ToJSON` typeclass. +-- If these orphans conflict with future ToJSON instances, we can remove them. + +instance ToJSON SigCapability where toJSON = J.toJsonViaEncode +instance ToJSON PublicKeyText where toJSON = J.toJsonViaEncode +instance ToJSON TTLSeconds where toJSON = J.toJsonViaEncode +instance ToJSON GasLimit where toJSON = J.toJsonViaEncode +instance ToJSON ChainId where toJSON = J.toJsonViaEncode +instance ToJSON NetworkId where toJSON = J.toJsonViaEncode +instance J.Encode a => ToJSON (Command a) where toJSON = J.toJsonViaEncode +instance ToJSON ApiSigner where toJSON = J.toJsonViaEncode +instance ToJSON ApiPublicMeta where toJSON = J.toJsonViaEncode +instance ToJSON UserSig where toJSON = J.toJsonViaEncode \ No newline at end of file diff --git a/src/Keys.hs b/src/Keys.hs index f2d6f9a..080bb60 100644 --- a/src/Keys.hs +++ b/src/Keys.hs @@ -39,6 +39,7 @@ import System.IO.Echo import Text.Read (readMaybe) ------------------------------------------------------------------------------ import Utils +import Data.Base16.Types (extractBase16) ------------------------------------------------------------------------------ mnemonicToRoot :: MnemonicPhrase -> Crypto.XPrv @@ -169,7 +170,7 @@ decodeMnemonic t = do decodeEncryptedMnemonic :: Text -> IO (Either String KadenaKey) decodeEncryptedMnemonic t = do - case Crypto.xprv =<< fmapL T.unpack (B16.decodeBase16 (T.encodeUtf8 t)) of + case Crypto.xprv =<< fmapL T.unpack (B16.decodeBase16Untyped (T.encodeUtf8 t)) of Left _ -> pure $ Left "Could not decode HD key" Right xprv -> do hSetBuffering stderr NoBuffering @@ -232,10 +233,10 @@ textTo :: IsString a => Text -> a textTo = fromString . T.unpack toB16 :: ByteString -> Text -toB16 = B16.encodeBase16 +toB16 = extractBase16 . B16.encodeBase16 fromB16 :: Text -> Either Text ByteString -fromB16 txt = B16.decodeBase16 $ T.encodeUtf8 txt +fromB16 txt = B16.decodeBase16Untyped $ T.encodeUtf8 txt readNatural :: String -> Maybe Natural readNatural = readMaybe diff --git a/src/TxTemplate.hs b/src/TxTemplate.hs index 1e92e71..97bb5c6 100644 --- a/src/TxTemplate.hs +++ b/src/TxTemplate.hs @@ -7,8 +7,8 @@ module TxTemplate where import Control.Applicative import Control.Monad import qualified Data.Aeson as A -import qualified Data.Aeson.Parser as A import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Attoparsec.ByteString.Char8 as Atto import Data.Bifunctor import Data.Either import qualified Data.HashMap.Strict as HM @@ -125,9 +125,9 @@ replicateSingleArr _ v = v parseTextValue :: (Text, Text) -> Either String (Text, MU.Value) parseTextValue (k,vt) = do let bs = encodeUtf8 vt - num = A.Number <$> Atto.parseOnly (A.scientific <* Atto.endOfInput) bs + num = A.Number <$> Atto.parseOnly (Atto.scientific <* Atto.endOfInput) bs str = Right $ A.String vt - v <- first addLoc $ A.eitherDecodeStrict bs <|> num <|> str + v <- first addLoc $ A.eitherDecodeStrict bs <> num <> str v2 <- case v of A.Number _ -> pure $ A.String vt A.String _ -> pure v diff --git a/src/Types/Encoding.hs b/src/Types/Encoding.hs index 1967fa4..47e4d08 100644 --- a/src/Types/Encoding.hs +++ b/src/Types/Encoding.hs @@ -48,15 +48,15 @@ textToEncoding = \case genericDecode :: Encoding -> ByteString -> Either Text ByteString genericDecode Raw = Right -genericDecode B16 = decodeBase16 -genericDecode B64 = B64.decodeBase64 -genericDecode B64Url = B64Url.decodeBase64 +genericDecode B16 = decodeBase16Untyped +genericDecode B64 = B64.decodeBase64Untyped +genericDecode B64Url = B64Url.decodeBase64Untyped genericDecode Yaml = decodeYamlBS -- We don't actually use the result of this case decodeYamlBS :: ByteString -> Either Text ByteString decodeYamlBS bs = do v :: Value <- first (T.pack . snd) $ YA.decode1Strict bs - let mhash = hush . B64Url.decodeBase64 . encodeUtf8 =<< (v ^? key "hash" . _String) + let mhash = hush . B64Url.decodeBase64Untyped . encodeUtf8 =<< (v ^? key "hash" . _String) mcmd = encodeUtf8 <$> (v ^? key "cmd" . _String) case (mhash, mcmd) of (Nothing, Nothing) -> Left "YAML must contain a key 'hash' and/or 'cmd'" diff --git a/src/Types/Env.hs b/src/Types/Env.hs index 013bd07..7279a25 100644 --- a/src/Types/Env.hs +++ b/src/Types/Env.hs @@ -15,6 +15,7 @@ import Chainweb.Api.ChainId import Chainweb.Api.Transaction import Control.Error import Control.Lens (makeLenses) +import Control.Monad import Control.Monad.Reader import Data.Aeson hiding (Encoding) import Data.Binary.Builder @@ -384,9 +385,9 @@ filePatP = strOption $ mconcat , short 'o' , metavar "OUT_PAT" , helpDoc $ Just $ mconcat - [ text "Pattern to use for output filenames" + [ "Pattern to use for output filenames" , hardline - , text "(example: \"tx-{{chain}}.yaml\")" + , "(example: \"tx-{{chain}}.yaml\")" ] ] diff --git a/src/Types/TxInputs.hs b/src/Types/TxInputs.hs index 7561841..9eca299 100644 --- a/src/Types/TxInputs.hs +++ b/src/Types/TxInputs.hs @@ -6,6 +6,7 @@ module Types.TxInputs where import Control.Applicative import Control.Error import Data.Aeson as A +import Data.Aeson.Key as A import Data.Aeson.Types import qualified Data.ByteString.Lazy as LB import Data.Text (Text) @@ -13,8 +14,12 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Pact.ApiReq +import Kadena.SigningTypes () +import qualified Pact.JSON.Encode as J +import Pact.JSON.Legacy.Value import Pact.Types.Lang import Pact.Types.RPC +import Pact.Types.Verifier ------------------------------------------------------------------------------ data PactTxType = PttExec | PttCont @@ -39,7 +44,7 @@ data ExecInputs = ExecInputs , _execInputs_dataOrFile :: Either Value FilePath } deriving (Eq,Show) -execInputsPairs :: (Monoid a, KeyValue a) => ExecInputs -> a +execInputsPairs :: (Monoid a, KeyValue e a) => ExecInputs -> a execInputsPairs ei = mconcat [ either ("code" .=) ("codeFile" .=) $ _execInputs_codeOrFile ei , either ("data" .=) ("dataFile" .=) $ _execInputs_dataOrFile ei @@ -59,6 +64,7 @@ data TxInputs = TxInputs { _txInputs_type :: PactTxType , _txInputs_payload :: Either ContMsg ExecInputs , _txInputs_signers :: Maybe [ApiSigner] + , _txInputs_verifiers :: Maybe [Verifier ParsedVerifierProof] , _txInputs_nonce :: Maybe Text , _txInputs_meta :: ApiPublicMeta , _txInputs_networkId :: NetworkId @@ -74,13 +80,14 @@ txInputsToApiReq txi = do (let PactId pid = _cmPactId c in hush $ fromText' pid) (Just $ _cmStep c) (Just $ _cmRollback c) - (Just $ _cmData c) + (Just $ _getLegacyValue $ _cmData c) (_cmProof c) Nothing Nothing Nothing Nothing (Just $ fromMaybe [] $ _txInputs_signers txi) + (Just $ fromMaybe [] $ _txInputs_verifiers txi) (_txInputs_nonce txi) (Just $ _txInputs_meta txi) n @@ -99,6 +106,7 @@ txInputsToApiReq txi = do Nothing Nothing (Just $ fromMaybe [] $ _txInputs_signers txi) + (Just $ fromMaybe [] $ _txInputs_verifiers txi) (_txInputs_nonce txi) (Just $ _txInputs_meta txi) n @@ -113,7 +121,7 @@ instance ToJSON TxInputs where toJSON ti = A.Object $ payloadPairs <> mconcat [ "type" .= _txInputs_type ti , "signers" .= fromMaybe [] (_txInputs_signers ti) - , "nonce" .?= _txInputs_nonce ti + , "nonce" .??= _txInputs_nonce ti -- TODO Not sure if this should be "meta" or "publicMeta". I think it should -- be "meta" because we want to move people towards the key used in the @@ -125,9 +133,13 @@ instance ToJSON TxInputs where ] where payloadPairs = either contMsgJsonPairs execInputsPairs $ _txInputs_payload ti - k .?= v = case v of + k .??= v = case v of Nothing -> mempty Just v' -> k .= v' + contMsgJsonPairs contMsg = case J.toJsonViaEncode contMsg of + A.Object o -> o + _ -> error "contMsgJsonPairs: impossible" + instance FromJSON TxInputs where @@ -154,6 +166,7 @@ instance FromJSON TxInputs where <$> pure t <*> pure p <*> o .:? "signers" + <*> o .:? "verifiers" <*> o .:? "nonce" <*> pure m <*> o .: "networkId" @@ -161,7 +174,7 @@ instance FromJSON TxInputs where parseMaybePair :: FromJSON a => A.Object - -> Text + -> A.Key -> Parser (Maybe (Either a FilePath)) parseMaybePair o name = do mn <- o .:? name @@ -171,4 +184,4 @@ parseMaybePair o name = do (Nothing,Nothing) -> pure Nothing (Just n,Nothing) -> pure $ Just $ Left n (Nothing,Just f) -> pure $ Just $ Right f - (Just _,Just _) -> fail $ T.unpack ("Cannot have both " <> name <> " and " <> nameFile) + (Just _,Just _) -> fail $ T.unpack ("Cannot have both " <> A.toText name <> " and " <> A.toText nameFile) diff --git a/src/Utils.hs b/src/Utils.hs index 49f8204..1403588 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -41,6 +41,7 @@ import Options.Applicative hiding (Parser) import Pact.Types.Command import System.Directory import System.FilePath +import Data.Vector.Internal.Check (HasCallStack) ------------------------------------------------------------------------------ tshow :: Show a => a -> Text @@ -144,15 +145,23 @@ commandSigDataToTransaction requireSigs csd = do pure $ mkTransaction pc (map userSigToSig sigs) where addDummy = maybe (if requireSigs then Nothing else Just dummySig) Just - dummySig = UserSig "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + dummySig = ED25519Sig "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + +convertViaJson :: (ToJSON a, FromJSON b) => a -> Either String b +convertViaJson = eitherDecode . encode + +convertViaJson' :: HasCallStack => (ToJSON a, FromJSON b) => a -> b +convertViaJson' a = case convertViaJson a of + Left e -> error $ "Failed to convert via JSON:" ++ e + Right b -> b -- | Converts chainweb-api's 'Sig' type to Pact's 'UserSig'. userSigToSig :: UserSig -> Sig -userSigToSig = Sig . _usSig +userSigToSig = convertViaJson' -- | Converts Pact's 'UserSig' type to chainweb-api's 'Sig'. sigToUserSig :: Sig -> UserSig -sigToUserSig = UserSig . unSig +sigToUserSig = convertViaJson' --data SigData a = SigData -- { _sigDataHash :: PactHash