cardano-addresses-4.0.0: lib/Cardano/Address/Script.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK prune #-}
-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0
module Cardano.Address.Script
(
-- * Script
Script (..)
, serializeScript
, foldScript
-- * Script template
, ScriptTemplate (..)
, Cosigner (..)
, cosignerToText
-- * Validation
, ValidationLevel (..)
, ErrValidateScript (..)
, ErrRecommendedValidateScript (..)
, ErrValidateScriptTemplate (..)
, validateScript
, validateScriptTemplate
, validateScriptOfTemplate
, prettyErrValidateScript
, prettyErrValidateScriptTemplate
-- * Hashing
, ScriptHash (..)
, toScriptHash
, scriptHashFromBytes
, scriptHashToText
, scriptHashFromText
, prettyErrScriptHashFromText
) where
import Prelude
import Cardano.Address.Derivation
( XPub, credentialHashSize, hashCredential, xpubFromBytes, xpubToBytes )
import Cardano.Address.KeyHash
( GovernanceType (..)
, KeyHash (..)
, KeyRole (..)
, keyHashFromText
, prettyErrKeyHashFromText
)
import Codec.Binary.Encoding
( AbstractEncoding (..), encode, fromBase16 )
import Control.Applicative
( (<|>) )
import Control.DeepSeq
( NFData )
import Control.Monad
( foldM, unless, when )
import Data.Aeson
( FromJSON (..)
, ToJSON (..)
, Value (..)
, object
, withObject
, withText
, (.:)
, (.:?)
, (.=)
)
import Data.Aeson.Key
( fromText, toText )
import Data.Aeson.Types
( Parser )
import Data.Bifunctor
( first )
import Data.ByteString
( ByteString )
import Data.Either.Combinators
( maybeToRight )
import Data.Foldable
( asum, foldl', traverse_ )
import Data.Functor.Identity
( Identity (..) )
import Data.Hashable
( Hashable )
import Data.Kind
( Type )
import Data.Map.Strict
( Map )
import Data.Text
( Text )
import Data.Traversable
( for )
import Data.Word
( Word8 )
import GHC.Generics
( Generic )
import Numeric.Natural
( Natural )
import qualified Cardano.Codec.Bech32.Prefixes as CIP5
import qualified Cardano.Codec.Cbor as CBOR
import qualified Codec.Binary.Bech32 as Bech32
import qualified Codec.CBOR.Encoding as CBOR
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Types as Json
import qualified Data.ByteString as BS
import qualified Data.HashSet as Set
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Read as T
-- | A 'Script' type represents multi signature script. The script embodies conditions
-- that need to be satisfied to make it valid.
--
-- @since 3.0.0
data Script (elem :: Type)
= RequireSignatureOf !elem
| RequireAllOf ![Script elem]
| RequireAnyOf ![Script elem]
| RequireSomeOf Word8 ![Script elem]
| ActiveFromSlot Natural
| ActiveUntilSlot Natural
deriving stock (Generic, Show, Eq)
instance NFData elem => NFData (Script elem)
-- | This function realizes what cardano-node's `Api.serialiseToCBOR script` realizes
-- This is basically doing the symbolically following:
-- toCBOR [0,multisigScript]
--
-- @since 3.0.0
serializeScript :: Script KeyHash -> ByteString
serializeScript script =
multisigTag <> CBOR.toStrictByteString (toCBOR script)
where
-- | Magic number representing the tag of the native multi-signature script
-- language. For each script language included, a new tag is chosen.
multisigTag :: ByteString
multisigTag = "\00"
toCBOR :: Script KeyHash -> CBOR.Encoding
toCBOR = \case
RequireSignatureOf (KeyHash _ verKeyHash) ->
encodeMultiscriptCtr 0 2 <> CBOR.encodeBytes verKeyHash
RequireAllOf contents ->
encodeMultiscriptCtr 1 2 <> encodeFoldable toCBOR contents
RequireAnyOf contents ->
encodeMultiscriptCtr 2 2 <> encodeFoldable toCBOR contents
RequireSomeOf m contents -> mconcat
[ encodeMultiscriptCtr 3 3
, CBOR.encodeInt (fromInteger $ toInteger m)
, encodeFoldable toCBOR contents
]
ActiveFromSlot slotNum ->
encodeMultiscriptCtr 4 2 <> CBOR.encodeWord64 (fromInteger $ toInteger slotNum)
ActiveUntilSlot slotNum ->
encodeMultiscriptCtr 5 2 <> CBOR.encodeWord64 (fromInteger $ toInteger slotNum)
encodeMultiscriptCtr :: Word -> Word -> CBOR.Encoding
encodeMultiscriptCtr ctrIndex listLen =
CBOR.encodeListLen listLen <> CBOR.encodeWord ctrIndex
encodeFoldable :: (Foldable f) => (a -> CBOR.Encoding) -> f a -> CBOR.Encoding
encodeFoldable encode' xs = wrapArray len contents
where
(len, contents) = foldl' go (0, mempty) xs
go (!l, !enc) next = (l + 1, enc <> encode' next)
wrapArray :: Word -> CBOR.Encoding -> CBOR.Encoding
wrapArray len' contents'
| len' <= 23 = CBOR.encodeListLen len' <> contents'
| otherwise = CBOR.encodeListLenIndef <> contents' <> CBOR.encodeBreak
-- | Represents the cosigner of the script, ie., party that co-shares the script.
--
-- @since 3.2.0
newtype Cosigner = Cosigner Word8
deriving (Generic, Ord, Eq)
instance Hashable Cosigner
instance NFData Cosigner
instance Show Cosigner where
show = T.unpack . cosignerToText
-- | Represents the script template that show the structure of the script and determines
-- the expected place of verification keys corresponding to given cosigners.
--
-- @since 3.2.0
data ScriptTemplate = ScriptTemplate
{ cosigners :: Map Cosigner XPub
, template :: Script Cosigner
} deriving (Generic, Show, Eq)
instance NFData ScriptTemplate
-- | Computes the hash of a given script, by first serializing it to CBOR.
--
-- @since 3.0.0
toScriptHash :: Script KeyHash -> ScriptHash
toScriptHash = ScriptHash . hashCredential . serializeScript
-- | A 'ScriptHash' type represents script hash. The hash is expected to have size of
-- 28-byte.
--
-- @since 3.0.0
newtype ScriptHash = ScriptHash { unScriptHash :: ByteString }
deriving (Generic, Show, Ord, Eq)
instance NFData ScriptHash
-- | Construct an 'ScriptHash' from raw 'ByteString' (28 bytes).
--
-- @since 3.0.0
scriptHashFromBytes :: ByteString -> Maybe ScriptHash
scriptHashFromBytes bytes
| BS.length bytes /= credentialHashSize = Nothing
| otherwise = Just $ ScriptHash bytes
-- | Encode a 'ScriptHash' to bech32 'Text' or hex if key role is unknown.
-- In the case of governance role, if one wants to include additional byte
-- as specified in [CIP-0129](https://github.com/cardano-foundation/CIPs/blob/master/CIP-0129/README.md)
-- unless the function is called with CIP0105.
--
-- One byte is prepended to script hash only in governance context. The rules how to contruct it are summarized
-- below
--
-- drep 0010....
-- hot 0000.... key type
-- cold 0001....
--
-- scripthash ....0011 credential type
--
-- This is on top of X_script, where X={drep, cc_hot, cc_hot}, which lacks the additional byte.
-- In `scriptHashFromText` we additionally
-- support reading legacy X which also lacks the additional byte, and has the same payload as
-- as the corresponding X_script.
--
-- @since 4.0.0
scriptHashToText :: ScriptHash -> KeyRole -> Maybe GovernanceType -> Text
scriptHashToText (ScriptHash scriptHash) cred govType = case cred of
Representative -> case govType of
Just CIP0105 ->
T.decodeUtf8 $ encode (EBech32 CIP5.drep_script) scriptHash
_ ->
T.decodeUtf8 $ encode (EBech32 CIP5.drep) $ appendByte scriptHash
CommitteeCold -> case govType of
Just CIP0105 ->
T.decodeUtf8 $ encode (EBech32 CIP5.cc_cold_script) scriptHash
_ ->
T.decodeUtf8 $ encode (EBech32 CIP5.cc_cold) $ appendByte scriptHash
CommitteeHot -> case govType of
Just CIP0105 ->
T.decodeUtf8 $ encode (EBech32 CIP5.cc_hot_script) scriptHash
_ ->
T.decodeUtf8 $ encode (EBech32 CIP5.cc_hot) $ appendByte scriptHash
Unknown ->
T.decodeUtf8 $ encode EBase16 scriptHash
_ ->
T.decodeUtf8 $ encode (EBech32 CIP5.script) scriptHash
where
appendByte payload = maybe payload (`BS.cons` payload) bytePrefix
bytePrefix = case cred of
Representative -> Just 0b00100011
CommitteeCold -> Just 0b00010011
CommitteeHot -> Just 0b00000011
_ -> Nothing
-- | Construct a 'ScriptHash' from 'Text'. It should be
-- Bech32 encoded text with one of following hrp:
-- - `script`
-- - `drep`
-- - `cc_cold`
-- - `cc_hot`
-- - `drep_script`
-- - `cc_cold_script`
-- - `cc_hot_script`
-- If if hex is encountered it is converted in rawly fashion
--
-- @since 4.0.0
scriptHashFromText :: Text -> Either ErrScriptHashFromText ScriptHash
scriptHashFromText txt =
case (fromBase16 $ T.encodeUtf8 txt) of
Right bs ->
if checkBSLength bs 28 then
pure $ ScriptHash bs
else
Left ErrScriptHashFromTextInvalidHex
Left _ -> do
(hrp, dp) <- first (const ErrScriptHashFromTextInvalidString) $
Bech32.decodeLenient txt
maybeToRight ErrScriptHashFromTextWrongDataPart (Bech32.dataPartToBytes dp)
>>= maybeToRight ErrScriptHashFromTextWrongHrp . convertBytes hrp
>>= maybeToRight ErrScriptHashFromTextWrongPayload . scriptHashFromBytes
where
convertBytes hrp bytes
| hrp == CIP5.drep && checkBSLength bytes 29 =
let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
-- drep 0010....
-- scripthash ....0011
in if fstByte == 0b00100011 then
Just payload
else
Nothing
| hrp == CIP5.drep_script && checkBSLength bytes 28 =
Just bytes
| hrp == CIP5.cc_cold && checkBSLength bytes 29 =
let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
-- cold 0001....
-- scripthash ....0011
in if fstByte == 0b00010011 then
Just payload
else
Nothing
| hrp == CIP5.cc_cold_script && checkBSLength bytes 28 =
Just bytes
| hrp == CIP5.cc_hot && checkBSLength bytes 29 =
let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
-- hot 0000....
-- scripthash ....0011
in if fstByte == 0b00000011 then
Just payload
else
Nothing
| hrp == CIP5.cc_hot_script && checkBSLength bytes 28 =
Just bytes
| hrp == CIP5.script && checkBSLength bytes 28 =
Just bytes
| otherwise = Nothing
checkBSLength :: ByteString -> Int -> Bool
checkBSLength bytes expLength =
BS.length bytes == expLength
-- Validation level. Required level does basic check that will make sure the script
-- is accepted in ledger. Recommended level collects a number of checks that will
-- warn about dangerous, unwise and redundant things present in the script.
--
-- @since 3.2.0
data ValidationLevel = RequiredValidation | RecommendedValidation
deriving (Show, Eq, Generic)
instance NFData ValidationLevel
-- Possible errors when deserializing a script hash from text.
--
-- @since 4.0.0
data ErrScriptHashFromText
= ErrScriptHashFromTextInvalidString
| ErrScriptHashFromTextWrongPayload
| ErrScriptHashFromTextWrongHrp
| ErrScriptHashFromTextWrongDataPart
| ErrScriptHashFromTextInvalidHex
deriving (Show, Eq)
-- Possible errors when deserializing a script hash from text.
--
-- @since 4.0.0
prettyErrScriptHashFromText :: ErrScriptHashFromText -> String
prettyErrScriptHashFromText = \case
ErrScriptHashFromTextInvalidString ->
"Invalid encoded string: must be either bech32 or hex-encoded."
ErrScriptHashFromTextWrongPayload ->
"Script hash must contain exactly 28-byte payload and one specific prepended byte."
ErrScriptHashFromTextWrongHrp ->
"Invalid human-readable prefix: must be 'drep', 'cc_hot' or 'cc_cold'."
ErrScriptHashFromTextWrongDataPart ->
"Script hash is Bech32-encoded but has an invalid data part."
ErrScriptHashFromTextInvalidHex ->
"Invalid hex-encoded string: must be 28 bytes."
--
-- Script folding
--
-- | 'Script' folding
--
-- @since 3.2.0
foldScript :: (a -> b -> b) -> b -> Script a -> b
foldScript fn zero = \case
RequireSignatureOf k -> fn k zero
RequireAllOf xs -> foldMScripts xs
RequireAnyOf xs -> foldMScripts xs
RequireSomeOf _ xs -> foldMScripts xs
ActiveFromSlot _ -> zero
ActiveUntilSlot _ -> zero
where
foldMScripts =
runIdentity . foldM (\acc -> Identity . foldScript fn acc) zero
--
-- Script validation
--
-- | Validate a 'Script', semantically
--
-- @since 3.0.0
validateScript
:: ValidationLevel
-> Script KeyHash
-> Either ErrValidateScript ()
validateScript level script = do
let validateKeyHash (KeyHash _ bytes) =
(BS.length bytes == credentialHashSize)
let allSigs = foldScript (:) [] script
unless (L.all validateKeyHash allSigs) $ Left WrongKeyHash
when (L.length (L.nub $ map role allSigs) > 1) $
Left NotUniformKeyType
requiredValidation script
when (level == RecommendedValidation) $
first NotRecommended (recommendedValidation script)
requiredValidation
:: Script elem
-> Either ErrValidateScript ()
requiredValidation script =
unless (check script) $ Left LedgerIncompatible
where
check = \case
RequireSignatureOf _ -> True
RequireAllOf xs ->
L.all check xs
RequireAnyOf xs ->
L.any check xs
RequireSomeOf m xs ->
m <= sum (fmap (\x -> if check x then 1 else 0) xs)
ActiveFromSlot _ -> True
ActiveUntilSlot _ -> True
recommendedValidation
:: Eq elem
=> Script elem
-> Either ErrRecommendedValidateScript ()
recommendedValidation = \case
RequireSignatureOf _ -> pure ()
RequireAllOf script -> do
when (L.null (omitTimelocks script)) $ Left EmptyList
when (hasDuplicate script) $ Left DuplicateSignatures
when (redundantTimelocks script) $ Left RedundantTimelocks
when (timelockTrap script) $ Left TimelockTrap
traverse_ recommendedValidation script
RequireAnyOf script -> do
when (hasDuplicate script) $ Left DuplicateSignatures
when (redundantTimelocks script) $ Left RedundantTimelocks
when (redundantTimelocksInAny script) $ Left RedundantTimelocks
traverse_ recommendedValidation script
RequireSomeOf m script -> do
when (m == 0) $ Left MZero
when (length (omitTimelocks script) < fromIntegral m) $ Left ListTooSmall
when (hasDuplicate script) $ Left DuplicateSignatures
when (redundantTimelocks script) $ Left RedundantTimelocks
traverse_ recommendedValidation script
ActiveFromSlot _ -> pure ()
ActiveUntilSlot _ -> pure ()
where
hasDuplicate xs =
length sigs /= length (L.nub sigs)
where
sigs = [ sig | RequireSignatureOf sig <- xs ]
hasTimelocks = \case
ActiveFromSlot _ -> True
ActiveUntilSlot _ -> True
_ -> False
redundantTimelocks xs = case L.filter hasTimelocks xs of
[] -> False
[_] -> False
[_, _] -> False
_ -> True
-- situation where any [active_until slot1, active_from slot2]
-- (a) acceptable when slot1 < slot2 as either it is satisfied
-- (0, slot1) or <slot2, +inf)
-- (b) otherwise redundant as it is always satified
redundantTimelocksInAny xs = case L.filter hasTimelocks xs of
[] -> False
[_] -> False
[ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 >= s1
[ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 >= s1
_ -> True
-- situation where all [active_until slot1, active_from slot2]
-- (a) trap when slot1 < slot2 as both can never be satisfied
-- (0, slot1)
-- (slot2, +inf)
-- (b) acceptable when slot1 == slot2
-- then all satisfied at slot1
-- (c) acceptable when slot1 >= slot2
-- then all satisfied at <slot2, slot1)
timelockTrap xs = case L.filter hasTimelocks xs of
[ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 < s1
[ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 < s1
_ -> False
omitTimelocks = filter (not . hasTimelocks)
--
-- ScriptTemplate validation
--
-- | Validate a 'ScriptTemplate', semantically
--
-- @since 3.2.0
validateScriptTemplate
:: ValidationLevel
-> ScriptTemplate
-> Either ErrValidateScriptTemplate ()
validateScriptTemplate level (ScriptTemplate cosigners_ script) = do
first WrongScript (validateScriptOfTemplate level script)
check NoCosignerInScript (nonEmpty scriptCosigners)
check NoCosignerXPub (nonEmpty cosignerKeys)
check DuplicateXPubs (Set.size cosignerKeys == Map.size cosigners_)
check UnknownCosigner (cosignerSet `Set.isSubsetOf` scriptCosigners)
check MissingCosignerXPub (scriptCosigners `Set.isSubsetOf` cosignerSet)
where
scriptCosigners = Set.fromList $ foldScript (:) [] script
cosignerKeys = Set.fromList $ Map.elems cosigners_
cosignerSet = Set.fromList $ Map.keys cosigners_
-- throws error if condition doesn't apply
check err cond = unless cond (Left err)
nonEmpty = not . Set.null
-- | Validate a script in 'ScriptTemplate'
--
-- @since 3.5.0
validateScriptOfTemplate
:: ValidationLevel
-> Script Cosigner
-> Either ErrValidateScript ()
validateScriptOfTemplate level script = do
requiredValidation script
when (level == RecommendedValidation ) $
first NotRecommended (recommendedValidation script)
-- | Possible validation errors when validating a script
--
-- @since 3.0.0
data ErrValidateScript
= LedgerIncompatible
| WrongKeyHash
| NotUniformKeyType
| Malformed
| NotRecommended ErrRecommendedValidateScript
deriving (Eq, Show)
-- | Possible recommended validation errors when validating a script
--
-- @since 3.2.0
data ErrRecommendedValidateScript
= EmptyList
| ListTooSmall
| MZero
| DuplicateSignatures
| RedundantTimelocks
| TimelockTrap
deriving (Eq, Show)
-- | Possible validation errors when validating a script template
--
-- @since 3.2.0
data ErrValidateScriptTemplate
= WrongScript ErrValidateScript
| DuplicateXPubs
| UnknownCosigner
| MissingCosignerXPub
| NoCosignerInScript
| NoCosignerXPub
deriving (Eq, Show)
-- | Pretty-print a script validation error.
--
-- @since 3.0.0
prettyErrValidateScript
:: ErrValidateScript
-> String
prettyErrValidateScript = \case
LedgerIncompatible ->
"The script is ill-formed and is not going to be accepted by the ledger."
WrongKeyHash ->
"The hash of verification key is expected to have "
<> show credentialHashSize <> " bytes."
NotUniformKeyType ->
"All keys of a script must have the same role: payment, delegation, policy, \
\representative, committee cold or committee hot."
Malformed ->
"Parsing of the script failed. The script should be composed of nested \
\lists, the verification keys should be bech32-encoded with prefix \
\'X_vkh', 'X_vk', 'X_xvk' where X is 'addr_shared', 'stake_shared', 'policy', \
\'drep', 'cc_cold' or 'cc_hot' and timelocks must use non-negative \
\numbers as slots."
NotRecommended EmptyList ->
"The list inside a script is empty or only contains timelocks \
\(which is not recommended)."
NotRecommended MZero ->
"At least's coefficient is 0 (which is not recommended)."
NotRecommended ListTooSmall ->
"At least's coefficient is larger than the number of non-timelock \
\elements in the list (which is not recommended)."
NotRecommended DuplicateSignatures ->
"The list inside a script has duplicate keys (which is not recommended)."
NotRecommended RedundantTimelocks ->
"Some timelocks used are redundant (which is not recommended)."
NotRecommended TimelockTrap ->
"The timelocks used are contradictory when used with 'all' (which is not recommended)."
-- | Pretty-print a script template validation error.
--
-- @since 3.2.0
prettyErrValidateScriptTemplate
:: ErrValidateScriptTemplate
-> String
prettyErrValidateScriptTemplate = \case
WrongScript err -> prettyErrValidateScript err
DuplicateXPubs ->
"The cosigners in a script template must stand behind an unique extended public key."
MissingCosignerXPub ->
"Each cosigner in a script template must have an extended public key."
NoCosignerInScript ->
"The script of a template must have at least one cosigner defined."
NoCosignerXPub ->
"The script template must have at least one cosigner with an extended public key."
UnknownCosigner ->
"The specified cosigner must be present in the script of the template."
--
-- Internal
--
-- Examples of Script jsons:
--"addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
--"stake_shared_vkh1nqc00hvlc6cq0sfhretk0rmzw8dywmusp8retuqnnxzajtzhjg5"
--{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
-- ]
--}
--{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , {"any": [ "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
-- , "addr_shared_vkh175wsm9ckhm3snwcsn72543yguxeuqm7v9r6kl6gx57h8gdydcd9"
-- ]
-- }
-- ]
--}
--{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , {"some": { "from" :[ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
-- , "addr_shared_vkh175wsm9ckhm3snwcsn72543yguxeuqm7v9r6kl6gx57h8gdydcd9"
-- ]
-- , "at_least" : 2
-- }
-- }
-- ]
--}
--{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , {"active_from": 120 }
-- ]
--}
--{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
-- , any [{"active_until": 100 }, {"active_from": 120 }]
-- ]
--}
instance ToJSON elem => ToJSON (Script elem) where
toJSON (RequireSignatureOf content) = toJSON content
toJSON (RequireAllOf content) =
object ["all" .= fmap toJSON content]
toJSON (RequireAnyOf content) =
object ["any" .= fmap toJSON content]
toJSON (RequireSomeOf count scripts) =
object ["some" .= object ["at_least" .= count, "from" .= scripts]]
toJSON (ActiveFromSlot slot) =
object ["active_from" .= slot]
toJSON (ActiveUntilSlot slot) =
object ["active_until" .= slot]
instance FromJSON (Script KeyHash) where
parseJSON v =
fromScriptJson parseKey backtrack v
where
parseKey = withText "Script KeyHash" $
either
(fail . prettyErrKeyHashFromText)
(pure . RequireSignatureOf)
. keyHashFromText
-- NOTE: Because we use an alternative sum to define all parsers, in
-- case all parser fails, only the last error is returned which can be
-- very misleading. For example, sending {"any": []} yields an error
-- telling us that the key `"some"` is missing.
--
-- To cope with this, we add a last parser 'backtrack' which always
-- fail but with a more helpful error which tries its best at
-- identifying the right constructor.
backtrack = \case
Object o -> do
mAny <- o .:? "any" :: Parser (Maybe Value)
mAll <- o .:? "all" :: Parser (Maybe Value)
mSome <- o .:? "some" :: Parser (Maybe Value)
case (mAny, mAll, mSome) of
(Just{}, Nothing, Nothing) -> parseAnyOf v
(Nothing, Just{}, Nothing) -> parseAllOf v
(Nothing, Nothing, Just{}) -> parseAtLeast v
(Nothing, Nothing, Nothing) -> fail
"Found object with unknown key. Expecting 'any', 'all' or 'some'"
( _, _, _) -> fail
"Found multiple keys 'any', 'all' and/or 'some' at the same level"
String{} ->
parseKey v
_ ->
Json.typeMismatch "Object or String" v
fromScriptJson
:: FromJSON (Script elem)
=> (Value -> Parser (Script elem))
-> (Value -> Parser (Script elem))
-> Value
-> Parser (Script elem)
fromScriptJson parseElem backtrack v =
asum
[ parseElem v
, parseAnyOf v
, parseAllOf v
, parseAtLeast v
, parseActiveFrom v
, parseActiveUntil v
] <|> backtrack v
parseAnyOf
:: FromJSON (Script elem)
=> Value
-> Parser (Script elem)
parseAnyOf = withObject "Script AnyOf" $ \o ->
RequireAnyOf <$> o .: "any"
parseAllOf
:: FromJSON (Script elem)
=> Value
-> Parser (Script elem)
parseAllOf = withObject "Script AllOf" $ \o ->
RequireAllOf <$> o .: "all"
parseAtLeast
:: FromJSON (Script elem)
=> Value
-> Parser (Script elem)
parseAtLeast = withObject "Script SomeOf" $ \o -> do
some <- o .: "some"
RequireSomeOf <$> some .: "at_least" <*> some .: "from"
parseActiveFrom
:: Value
-> Parser (Script elem)
parseActiveFrom = withObject "Script ActiveFrom" $ \o ->
ActiveFromSlot <$> o .: "active_from"
parseActiveUntil
:: Value
-> Parser (Script elem)
parseActiveUntil = withObject "Script ActiveUntil" $ \o ->
ActiveUntilSlot <$> o .: "active_until"
cosignerToText :: Cosigner -> Text
cosignerToText (Cosigner ix) = "cosigner#"<> T.pack (show ix)
instance ToJSON Cosigner where
toJSON = String . cosignerToText
instance FromJSON Cosigner where
parseJSON = withText "Cosigner" $ \txt -> case T.splitOn "cosigner#" txt of
["",numTxt] -> case T.decimal numTxt of
Right (num,"") -> do
when (num < minBound @Word8 || num > maxBound @Word8) $
fail "Cosigner number should be between '0' and '255'"
pure $ Cosigner num
_ -> fail "Cosigner should be enumerated with number"
_ -> fail "Cosigner should be of the form: cosigner#num"
encodeXPub :: XPub -> Value
encodeXPub = String . T.decodeUtf8 . encode EBase16 . xpubToBytes
parseXPub :: Value -> Parser XPub
parseXPub = withText "XPub" $ \txt ->
case fromBase16 (T.encodeUtf8 txt) of
Left err -> fail err
Right hex -> case xpubFromBytes hex of
Nothing -> fail "Extended public key cannot be retrieved from a given hex bytestring"
Just validXPub -> pure validXPub
instance ToJSON ScriptTemplate where
toJSON (ScriptTemplate cosigners' template') =
object [ "cosigners" .= object (fmap (first fromText . toPair) (Map.toList cosigners'))
, "template" .= toJSON template']
where
toPair (cosigner', xpub) =
( cosignerToText cosigner'
, encodeXPub xpub )
instance FromJSON (Script Cosigner) where
parseJSON v = fromScriptJson parserCosigner backtrack v
where
parserCosigner o = do
cosigner <- parseJSON @Cosigner o
pure $ RequireSignatureOf cosigner
backtrack = \case
Object o -> do
mAny <- o .:? "any" :: Parser (Maybe Value)
mAll <- o .:? "all" :: Parser (Maybe Value)
mSome <- o .:? "some" :: Parser (Maybe Value)
mCos <- o .:? "cosigner" :: Parser (Maybe Value)
case (mAny, mAll, mSome, mCos) of
(Just{}, Nothing, Nothing, Nothing) -> parseAnyOf v
(Nothing, Just{}, Nothing, Nothing) -> parseAllOf v
(Nothing, Nothing, Just{}, Nothing) -> parseAtLeast v
(Nothing, Nothing, Nothing, Just{}) -> parserCosigner v
(Nothing, Nothing, Nothing, Nothing) -> fail
"Found object with unknown key. Expecting 'any', 'all', 'some' or 'cosigner'"
( _, _, _, _) -> fail
"Found multiple keys 'any', 'all', 'cosigner' and/or 'some' at the same level"
_ ->
Json.typeMismatch "Object only" v
instance FromJSON ScriptTemplate where
parseJSON = withObject "ScriptTemplate" $ \o -> do
template' <- parseJSON <$> o .: "template"
cosigners' <- parseCosignerPairs <$> o .: "cosigners"
ScriptTemplate . Map.fromList <$> cosigners' <*> template'
where
parseCosignerPairs = withObject "Cosigner pairs" $ \o ->
case KeyMap.toList o of
[] -> fail "Cosigners object array should not be empty"
cs -> for (reverse cs) $ \(numTxt, str) -> do
cosigner' <- parseJSON @Cosigner (String (toText numTxt))
xpub <- parseXPub str
pure (cosigner', xpub)