{-# 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 ((forall x. Script elem -> Rep (Script elem) x)
-> (forall x. Rep (Script elem) x -> Script elem)
-> Generic (Script elem)
forall x. Rep (Script elem) x -> Script elem
forall x. Script elem -> Rep (Script elem) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall elem x. Rep (Script elem) x -> Script elem
forall elem x. Script elem -> Rep (Script elem) x
$cfrom :: forall elem x. Script elem -> Rep (Script elem) x
from :: forall x. Script elem -> Rep (Script elem) x
$cto :: forall elem x. Rep (Script elem) x -> Script elem
to :: forall x. Rep (Script elem) x -> Script elem
Generic, Int -> Script elem -> ShowS
[Script elem] -> ShowS
Script elem -> String
(Int -> Script elem -> ShowS)
-> (Script elem -> String)
-> ([Script elem] -> ShowS)
-> Show (Script elem)
forall elem. Show elem => Int -> Script elem -> ShowS
forall elem. Show elem => [Script elem] -> ShowS
forall elem. Show elem => Script elem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall elem. Show elem => Int -> Script elem -> ShowS
showsPrec :: Int -> Script elem -> ShowS
$cshow :: forall elem. Show elem => Script elem -> String
show :: Script elem -> String
$cshowList :: forall elem. Show elem => [Script elem] -> ShowS
showList :: [Script elem] -> ShowS
Show, Script elem -> Script elem -> Bool
(Script elem -> Script elem -> Bool)
-> (Script elem -> Script elem -> Bool) -> Eq (Script elem)
forall elem. Eq elem => Script elem -> Script elem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall elem. Eq elem => Script elem -> Script elem -> Bool
== :: Script elem -> Script elem -> Bool
$c/= :: forall elem. Eq elem => Script elem -> Script elem -> Bool
/= :: Script elem -> Script elem -> Bool
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 KeyHash -> ByteString
serializeScript Script KeyHash
script =
    ByteString
multisigTag ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Encoding -> ByteString
CBOR.toStrictByteString (Script KeyHash -> Encoding
toCBOR Script KeyHash
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 :: ByteString
multisigTag = ByteString
"\00"

    toCBOR :: Script KeyHash -> CBOR.Encoding
    toCBOR :: Script KeyHash -> Encoding
toCBOR = \case
        RequireSignatureOf (KeyHash KeyRole
_ ByteString
verKeyHash) ->
            Word -> Word -> Encoding
encodeMultiscriptCtr Word
0 Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
CBOR.encodeBytes ByteString
verKeyHash
        RequireAllOf [Script KeyHash]
contents ->
            Word -> Word -> Encoding
encodeMultiscriptCtr Word
1 Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Script KeyHash -> Encoding) -> [Script KeyHash] -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldable Script KeyHash -> Encoding
toCBOR [Script KeyHash]
contents
        RequireAnyOf [Script KeyHash]
contents ->
            Word -> Word -> Encoding
encodeMultiscriptCtr Word
2 Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Script KeyHash -> Encoding) -> [Script KeyHash] -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldable Script KeyHash -> Encoding
toCBOR [Script KeyHash]
contents
        RequireSomeOf Word8
m [Script KeyHash]
contents -> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
            [ Word -> Word -> Encoding
encodeMultiscriptCtr Word
3 Word
3
            , Int -> Encoding
CBOR.encodeInt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger Word8
m)
            , (Script KeyHash -> Encoding) -> [Script KeyHash] -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldable Script KeyHash -> Encoding
toCBOR [Script KeyHash]
contents
            ]
        ActiveFromSlot Natural
slotNum ->
            Word -> Word -> Encoding
encodeMultiscriptCtr Word
4 Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
CBOR.encodeWord64 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
slotNum)
        ActiveUntilSlot Natural
slotNum ->
            Word -> Word -> Encoding
encodeMultiscriptCtr Word
5 Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
CBOR.encodeWord64 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
slotNum)

    encodeMultiscriptCtr :: Word -> Word -> CBOR.Encoding
    encodeMultiscriptCtr :: Word -> Word -> Encoding
encodeMultiscriptCtr Word
ctrIndex Word
listLen =
        Word -> Encoding
CBOR.encodeListLen Word
listLen Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
ctrIndex

    encodeFoldable :: (Foldable f) => (a -> CBOR.Encoding) -> f a -> CBOR.Encoding
    encodeFoldable :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldable a -> Encoding
encode' f a
xs = Word -> Encoding -> Encoding
wrapArray Word
len Encoding
contents
      where
        (Word
len, Encoding
contents) = ((Word, Encoding) -> a -> (Word, Encoding))
-> (Word, Encoding) -> f a -> (Word, Encoding)
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Encoding) -> a -> (Word, Encoding)
forall {a}. Num a => (a, Encoding) -> a -> (a, Encoding)
go (Word
0, Encoding
forall a. Monoid a => a
mempty) f a
xs
        go :: (a, Encoding) -> a -> (a, Encoding)
go (!a
l, !Encoding
enc) a
next = (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Encoding
enc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encode' a
next)

        wrapArray :: Word -> CBOR.Encoding -> CBOR.Encoding
        wrapArray :: Word -> Encoding -> Encoding
wrapArray Word
len' Encoding
contents'
            | Word
len' Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
23 = Word -> Encoding
CBOR.encodeListLen Word
len' Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents'
            | Bool
otherwise  = Encoding
CBOR.encodeListLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents' Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeBreak

-- | Represents the cosigner of the script, ie., party that co-shares the script.
--
-- @since 3.2.0
newtype Cosigner = Cosigner Word8
    deriving ((forall x. Cosigner -> Rep Cosigner x)
-> (forall x. Rep Cosigner x -> Cosigner) -> Generic Cosigner
forall x. Rep Cosigner x -> Cosigner
forall x. Cosigner -> Rep Cosigner x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Cosigner -> Rep Cosigner x
from :: forall x. Cosigner -> Rep Cosigner x
$cto :: forall x. Rep Cosigner x -> Cosigner
to :: forall x. Rep Cosigner x -> Cosigner
Generic, Eq Cosigner
Eq Cosigner =>
(Cosigner -> Cosigner -> Ordering)
-> (Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Cosigner)
-> (Cosigner -> Cosigner -> Cosigner)
-> Ord Cosigner
Cosigner -> Cosigner -> Bool
Cosigner -> Cosigner -> Ordering
Cosigner -> Cosigner -> Cosigner
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Cosigner -> Cosigner -> Ordering
compare :: Cosigner -> Cosigner -> Ordering
$c< :: Cosigner -> Cosigner -> Bool
< :: Cosigner -> Cosigner -> Bool
$c<= :: Cosigner -> Cosigner -> Bool
<= :: Cosigner -> Cosigner -> Bool
$c> :: Cosigner -> Cosigner -> Bool
> :: Cosigner -> Cosigner -> Bool
$c>= :: Cosigner -> Cosigner -> Bool
>= :: Cosigner -> Cosigner -> Bool
$cmax :: Cosigner -> Cosigner -> Cosigner
max :: Cosigner -> Cosigner -> Cosigner
$cmin :: Cosigner -> Cosigner -> Cosigner
min :: Cosigner -> Cosigner -> Cosigner
Ord, Cosigner -> Cosigner -> Bool
(Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Bool) -> Eq Cosigner
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cosigner -> Cosigner -> Bool
== :: Cosigner -> Cosigner -> Bool
$c/= :: Cosigner -> Cosigner -> Bool
/= :: Cosigner -> Cosigner -> Bool
Eq)
instance Hashable Cosigner
instance NFData Cosigner

instance Show Cosigner where
    show :: Cosigner -> String
show = Text -> String
T.unpack (Text -> String) -> (Cosigner -> Text) -> Cosigner -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosigner -> Text
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
    { ScriptTemplate -> Map Cosigner XPub
cosigners :: Map Cosigner XPub
    , ScriptTemplate -> Script Cosigner
template :: Script Cosigner
    } deriving ((forall x. ScriptTemplate -> Rep ScriptTemplate x)
-> (forall x. Rep ScriptTemplate x -> ScriptTemplate)
-> Generic ScriptTemplate
forall x. Rep ScriptTemplate x -> ScriptTemplate
forall x. ScriptTemplate -> Rep ScriptTemplate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptTemplate -> Rep ScriptTemplate x
from :: forall x. ScriptTemplate -> Rep ScriptTemplate x
$cto :: forall x. Rep ScriptTemplate x -> ScriptTemplate
to :: forall x. Rep ScriptTemplate x -> ScriptTemplate
Generic, Int -> ScriptTemplate -> ShowS
[ScriptTemplate] -> ShowS
ScriptTemplate -> String
(Int -> ScriptTemplate -> ShowS)
-> (ScriptTemplate -> String)
-> ([ScriptTemplate] -> ShowS)
-> Show ScriptTemplate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptTemplate -> ShowS
showsPrec :: Int -> ScriptTemplate -> ShowS
$cshow :: ScriptTemplate -> String
show :: ScriptTemplate -> String
$cshowList :: [ScriptTemplate] -> ShowS
showList :: [ScriptTemplate] -> ShowS
Show, ScriptTemplate -> ScriptTemplate -> Bool
(ScriptTemplate -> ScriptTemplate -> Bool)
-> (ScriptTemplate -> ScriptTemplate -> Bool) -> Eq ScriptTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptTemplate -> ScriptTemplate -> Bool
== :: ScriptTemplate -> ScriptTemplate -> Bool
$c/= :: ScriptTemplate -> ScriptTemplate -> Bool
/= :: ScriptTemplate -> ScriptTemplate -> Bool
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 :: Script KeyHash -> ScriptHash
toScriptHash = ByteString -> ScriptHash
ScriptHash (ByteString -> ScriptHash)
-> (Script KeyHash -> ByteString) -> Script KeyHash -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashCredential (ByteString -> ByteString)
-> (Script KeyHash -> ByteString) -> Script KeyHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script KeyHash -> ByteString
serializeScript

-- | A 'ScriptHash' type represents script hash. The hash is expected to have size of
-- 28-byte.
--
-- @since 3.0.0
newtype ScriptHash = ScriptHash { ScriptHash -> ByteString
unScriptHash :: ByteString }
    deriving ((forall x. ScriptHash -> Rep ScriptHash x)
-> (forall x. Rep ScriptHash x -> ScriptHash) -> Generic ScriptHash
forall x. Rep ScriptHash x -> ScriptHash
forall x. ScriptHash -> Rep ScriptHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptHash -> Rep ScriptHash x
from :: forall x. ScriptHash -> Rep ScriptHash x
$cto :: forall x. Rep ScriptHash x -> ScriptHash
to :: forall x. Rep ScriptHash x -> ScriptHash
Generic, Int -> ScriptHash -> ShowS
[ScriptHash] -> ShowS
ScriptHash -> String
(Int -> ScriptHash -> ShowS)
-> (ScriptHash -> String)
-> ([ScriptHash] -> ShowS)
-> Show ScriptHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptHash -> ShowS
showsPrec :: Int -> ScriptHash -> ShowS
$cshow :: ScriptHash -> String
show :: ScriptHash -> String
$cshowList :: [ScriptHash] -> ShowS
showList :: [ScriptHash] -> ShowS
Show, Eq ScriptHash
Eq ScriptHash =>
(ScriptHash -> ScriptHash -> Ordering)
-> (ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> ScriptHash)
-> (ScriptHash -> ScriptHash -> ScriptHash)
-> Ord ScriptHash
ScriptHash -> ScriptHash -> Bool
ScriptHash -> ScriptHash -> Ordering
ScriptHash -> ScriptHash -> ScriptHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ScriptHash -> ScriptHash -> Ordering
compare :: ScriptHash -> ScriptHash -> Ordering
$c< :: ScriptHash -> ScriptHash -> Bool
< :: ScriptHash -> ScriptHash -> Bool
$c<= :: ScriptHash -> ScriptHash -> Bool
<= :: ScriptHash -> ScriptHash -> Bool
$c> :: ScriptHash -> ScriptHash -> Bool
> :: ScriptHash -> ScriptHash -> Bool
$c>= :: ScriptHash -> ScriptHash -> Bool
>= :: ScriptHash -> ScriptHash -> Bool
$cmax :: ScriptHash -> ScriptHash -> ScriptHash
max :: ScriptHash -> ScriptHash -> ScriptHash
$cmin :: ScriptHash -> ScriptHash -> ScriptHash
min :: ScriptHash -> ScriptHash -> ScriptHash
Ord, ScriptHash -> ScriptHash -> Bool
(ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> Bool) -> Eq ScriptHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptHash -> ScriptHash -> Bool
== :: ScriptHash -> ScriptHash -> Bool
$c/= :: ScriptHash -> ScriptHash -> Bool
/= :: ScriptHash -> ScriptHash -> Bool
Eq)
instance NFData ScriptHash

-- | Construct an 'ScriptHash' from raw 'ByteString' (28 bytes).
--
-- @since 3.0.0
scriptHashFromBytes :: ByteString -> Maybe ScriptHash
scriptHashFromBytes :: ByteString -> Maybe ScriptHash
scriptHashFromBytes ByteString
bytes
    | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
credentialHashSize = Maybe ScriptHash
forall a. Maybe a
Nothing
    | Bool
otherwise = ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just (ScriptHash -> Maybe ScriptHash) -> ScriptHash -> Maybe ScriptHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ScriptHash
ScriptHash ByteString
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 -> KeyRole -> Maybe GovernanceType -> Text
scriptHashToText (ScriptHash ByteString
scriptHash) KeyRole
cred Maybe GovernanceType
govType = case KeyRole
cred of
    KeyRole
Representative -> case Maybe GovernanceType
govType of
        Just GovernanceType
CIP0105 ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.drep_script) ByteString
scriptHash
        Maybe GovernanceType
_ ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.drep) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
appendByte ByteString
scriptHash
    KeyRole
CommitteeCold -> case Maybe GovernanceType
govType of
        Just GovernanceType
CIP0105 ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.cc_cold_script) ByteString
scriptHash
        Maybe GovernanceType
_ ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.cc_cold) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
appendByte ByteString
scriptHash
    KeyRole
CommitteeHot -> case Maybe GovernanceType
govType of
        Just GovernanceType
CIP0105 ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.cc_hot_script) ByteString
scriptHash
        Maybe GovernanceType
_ ->
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.cc_hot) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
appendByte ByteString
scriptHash
    KeyRole
Unknown ->
        ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode Encoding
forall a. AbstractEncoding a
EBase16 ByteString
scriptHash
    KeyRole
_ ->
        ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString -> ByteString
encode (HumanReadablePart -> Encoding
forall a. a -> AbstractEncoding a
EBech32 HumanReadablePart
CIP5.script) ByteString
scriptHash
  where
    appendByte :: ByteString -> ByteString
appendByte ByteString
payload =  ByteString -> (Word8 -> ByteString) -> Maybe Word8 -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
payload (Word8 -> ByteString -> ByteString
`BS.cons` ByteString
payload) Maybe Word8
bytePrefix
    bytePrefix :: Maybe Word8
bytePrefix = case KeyRole
cred of
        KeyRole
Representative -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
0b00100011
        KeyRole
CommitteeCold -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
0b00010011
        KeyRole
CommitteeHot -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
0b00000011
        KeyRole
_ -> Maybe Word8
forall a. Maybe a
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 :: Text -> Either ErrScriptHashFromText ScriptHash
scriptHashFromText Text
txt =
    case (ByteString -> Either String ByteString
fromBase16 (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
txt) of
        Right ByteString
bs ->
            if ByteString -> Int -> Bool
checkBSLength ByteString
bs Int
28 then
                ScriptHash -> Either ErrScriptHashFromText ScriptHash
forall a. a -> Either ErrScriptHashFromText a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptHash -> Either ErrScriptHashFromText ScriptHash)
-> ScriptHash -> Either ErrScriptHashFromText ScriptHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ScriptHash
ScriptHash ByteString
bs
            else
                ErrScriptHashFromText -> Either ErrScriptHashFromText ScriptHash
forall a b. a -> Either a b
Left ErrScriptHashFromText
ErrScriptHashFromTextInvalidHex
        Left String
_ -> do
            (HumanReadablePart
hrp, DataPart
dp) <- (DecodingError -> ErrScriptHashFromText)
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either ErrScriptHashFromText (HumanReadablePart, DataPart)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ErrScriptHashFromText -> DecodingError -> ErrScriptHashFromText
forall a b. a -> b -> a
const ErrScriptHashFromText
ErrScriptHashFromTextInvalidString) (Either DecodingError (HumanReadablePart, DataPart)
 -> Either ErrScriptHashFromText (HumanReadablePart, DataPart))
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either ErrScriptHashFromText (HumanReadablePart, DataPart)
forall a b. (a -> b) -> a -> b
$
                Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
txt

            ErrScriptHashFromText
-> Maybe ByteString -> Either ErrScriptHashFromText ByteString
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrScriptHashFromText
ErrScriptHashFromTextWrongDataPart (DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dp)
                Either ErrScriptHashFromText ByteString
-> (ByteString -> Either ErrScriptHashFromText ByteString)
-> Either ErrScriptHashFromText ByteString
forall a b.
Either ErrScriptHashFromText a
-> (a -> Either ErrScriptHashFromText b)
-> Either ErrScriptHashFromText b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrScriptHashFromText
-> Maybe ByteString -> Either ErrScriptHashFromText ByteString
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrScriptHashFromText
ErrScriptHashFromTextWrongHrp (Maybe ByteString -> Either ErrScriptHashFromText ByteString)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Either ErrScriptHashFromText ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HumanReadablePart -> ByteString -> Maybe ByteString
convertBytes HumanReadablePart
hrp
                Either ErrScriptHashFromText ByteString
-> (ByteString -> Either ErrScriptHashFromText ScriptHash)
-> Either ErrScriptHashFromText ScriptHash
forall a b.
Either ErrScriptHashFromText a
-> (a -> Either ErrScriptHashFromText b)
-> Either ErrScriptHashFromText b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrScriptHashFromText
-> Maybe ScriptHash -> Either ErrScriptHashFromText ScriptHash
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrScriptHashFromText
ErrScriptHashFromTextWrongPayload (Maybe ScriptHash -> Either ErrScriptHashFromText ScriptHash)
-> (ByteString -> Maybe ScriptHash)
-> ByteString
-> Either ErrScriptHashFromText ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ScriptHash
scriptHashFromBytes
 where
    convertBytes :: HumanReadablePart -> ByteString -> Maybe ByteString
convertBytes HumanReadablePart
hrp ByteString
bytes
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.drep Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
29 =
              let (Word8
fstByte, ByteString
payload) = (ByteString -> Word8)
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ((ByteString, ByteString) -> (Word8, ByteString))
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
1 ByteString
bytes
              --   drep          0010....
              --   scripthash    ....0011
              in if Word8
fstByte Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0b00100011 then
                  ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
payload
                 else
                  Maybe ByteString
forall a. Maybe a
Nothing
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.drep_script Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.cc_cold Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
29 =
              let (Word8
fstByte, ByteString
payload) = (ByteString -> Word8)
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ((ByteString, ByteString) -> (Word8, ByteString))
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
1 ByteString
bytes
              --   cold          0001....
              --   scripthash    ....0011
              in if Word8
fstByte Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0b00010011 then
                  ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
payload
                 else
                  Maybe ByteString
forall a. Maybe a
Nothing
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.cc_cold_script Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.cc_hot Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
29 =
              let (Word8
fstByte, ByteString
payload) = (ByteString -> Word8)
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ((ByteString, ByteString) -> (Word8, ByteString))
-> (ByteString, ByteString) -> (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
1 ByteString
bytes
              --   hot           0000....
              --   scripthash    ....0011
              in if Word8
fstByte Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0b00000011 then
                  ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
payload
                 else
                  Maybe ByteString
forall a. Maybe a
Nothing
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.cc_hot_script Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.script Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
        | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing
    checkBSLength :: ByteString -> Int -> Bool
    checkBSLength :: ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
expLength =
        ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 (Int -> ValidationLevel -> ShowS
[ValidationLevel] -> ShowS
ValidationLevel -> String
(Int -> ValidationLevel -> ShowS)
-> (ValidationLevel -> String)
-> ([ValidationLevel] -> ShowS)
-> Show ValidationLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationLevel -> ShowS
showsPrec :: Int -> ValidationLevel -> ShowS
$cshow :: ValidationLevel -> String
show :: ValidationLevel -> String
$cshowList :: [ValidationLevel] -> ShowS
showList :: [ValidationLevel] -> ShowS
Show, ValidationLevel -> ValidationLevel -> Bool
(ValidationLevel -> ValidationLevel -> Bool)
-> (ValidationLevel -> ValidationLevel -> Bool)
-> Eq ValidationLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationLevel -> ValidationLevel -> Bool
== :: ValidationLevel -> ValidationLevel -> Bool
$c/= :: ValidationLevel -> ValidationLevel -> Bool
/= :: ValidationLevel -> ValidationLevel -> Bool
Eq, (forall x. ValidationLevel -> Rep ValidationLevel x)
-> (forall x. Rep ValidationLevel x -> ValidationLevel)
-> Generic ValidationLevel
forall x. Rep ValidationLevel x -> ValidationLevel
forall x. ValidationLevel -> Rep ValidationLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationLevel -> Rep ValidationLevel x
from :: forall x. ValidationLevel -> Rep ValidationLevel x
$cto :: forall x. Rep ValidationLevel x -> ValidationLevel
to :: forall x. Rep ValidationLevel x -> ValidationLevel
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 (Int -> ErrScriptHashFromText -> ShowS
[ErrScriptHashFromText] -> ShowS
ErrScriptHashFromText -> String
(Int -> ErrScriptHashFromText -> ShowS)
-> (ErrScriptHashFromText -> String)
-> ([ErrScriptHashFromText] -> ShowS)
-> Show ErrScriptHashFromText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrScriptHashFromText -> ShowS
showsPrec :: Int -> ErrScriptHashFromText -> ShowS
$cshow :: ErrScriptHashFromText -> String
show :: ErrScriptHashFromText -> String
$cshowList :: [ErrScriptHashFromText] -> ShowS
showList :: [ErrScriptHashFromText] -> ShowS
Show, ErrScriptHashFromText -> ErrScriptHashFromText -> Bool
(ErrScriptHashFromText -> ErrScriptHashFromText -> Bool)
-> (ErrScriptHashFromText -> ErrScriptHashFromText -> Bool)
-> Eq ErrScriptHashFromText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrScriptHashFromText -> ErrScriptHashFromText -> Bool
== :: ErrScriptHashFromText -> ErrScriptHashFromText -> Bool
$c/= :: ErrScriptHashFromText -> ErrScriptHashFromText -> Bool
/= :: ErrScriptHashFromText -> ErrScriptHashFromText -> Bool
Eq)

-- Possible errors when deserializing a script hash from text.
--
-- @since 4.0.0
prettyErrScriptHashFromText :: ErrScriptHashFromText -> String
prettyErrScriptHashFromText :: ErrScriptHashFromText -> String
prettyErrScriptHashFromText = \case
    ErrScriptHashFromText
ErrScriptHashFromTextInvalidString ->
        String
"Invalid encoded string: must be either bech32 or hex-encoded."
    ErrScriptHashFromText
ErrScriptHashFromTextWrongPayload ->
        String
"Script hash must contain exactly 28-byte payload and one specific prepended byte."
    ErrScriptHashFromText
ErrScriptHashFromTextWrongHrp ->
        String
"Invalid human-readable prefix: must be 'drep', 'cc_hot' or 'cc_cold'."
    ErrScriptHashFromText
ErrScriptHashFromTextWrongDataPart ->
        String
"Script hash is Bech32-encoded but has an invalid data part."
    ErrScriptHashFromText
ErrScriptHashFromTextInvalidHex ->
        String
"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 :: forall a b. (a -> b -> b) -> b -> Script a -> b
foldScript a -> b -> b
fn b
zero = \case
    RequireSignatureOf a
k -> a -> b -> b
fn a
k b
zero
    RequireAllOf [Script a]
xs      -> [Script a] -> b
foldMScripts [Script a]
xs
    RequireAnyOf [Script a]
xs      -> [Script a] -> b
foldMScripts [Script a]
xs
    RequireSomeOf Word8
_ [Script a]
xs   -> [Script a] -> b
foldMScripts [Script a]
xs
    ActiveFromSlot Natural
_     -> b
zero
    ActiveUntilSlot Natural
_    -> b
zero
  where
    foldMScripts :: [Script a] -> b
foldMScripts =
        Identity b -> b
forall a. Identity a -> a
runIdentity (Identity b -> b) -> ([Script a] -> Identity b) -> [Script a] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Script a -> Identity b) -> b -> [Script a] -> Identity b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\b
acc -> b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (Script a -> b) -> Script a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> b) -> b -> Script a -> b
forall a b. (a -> b -> b) -> b -> Script a -> b
foldScript a -> b -> b
fn b
acc) b
zero

--
-- Script validation
--

-- | Validate a 'Script', semantically
--
-- @since 3.0.0
validateScript
    :: ValidationLevel
    -> Script KeyHash
    -> Either ErrValidateScript ()
validateScript :: ValidationLevel -> Script KeyHash -> Either ErrValidateScript ()
validateScript ValidationLevel
level Script KeyHash
script = do
    let validateKeyHash :: KeyHash -> Bool
validateKeyHash (KeyHash KeyRole
_ ByteString
bytes) =
            (ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
credentialHashSize)
    let allSigs :: [KeyHash]
allSigs = (KeyHash -> [KeyHash] -> [KeyHash])
-> [KeyHash] -> Script KeyHash -> [KeyHash]
forall a b. (a -> b -> b) -> b -> Script a -> b
foldScript (:) [] Script KeyHash
script
    Bool -> Either ErrValidateScript () -> Either ErrValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((KeyHash -> Bool) -> [KeyHash] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.all KeyHash -> Bool
validateKeyHash [KeyHash]
allSigs) (Either ErrValidateScript () -> Either ErrValidateScript ())
-> Either ErrValidateScript () -> Either ErrValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrValidateScript -> Either ErrValidateScript ()
forall a b. a -> Either a b
Left ErrValidateScript
WrongKeyHash

    Bool -> Either ErrValidateScript () -> Either ErrValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([KeyRole] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([KeyRole] -> [KeyRole]
forall a. Eq a => [a] -> [a]
L.nub ([KeyRole] -> [KeyRole]) -> [KeyRole] -> [KeyRole]
forall a b. (a -> b) -> a -> b
$ (KeyHash -> KeyRole) -> [KeyHash] -> [KeyRole]
forall a b. (a -> b) -> [a] -> [b]
map KeyHash -> KeyRole
role [KeyHash]
allSigs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Either ErrValidateScript () -> Either ErrValidateScript ())
-> Either ErrValidateScript () -> Either ErrValidateScript ()
forall a b. (a -> b) -> a -> b
$
        ErrValidateScript -> Either ErrValidateScript ()
forall a b. a -> Either a b
Left ErrValidateScript
NotUniformKeyType

    Script KeyHash -> Either ErrValidateScript ()
forall elem. Script elem -> Either ErrValidateScript ()
requiredValidation Script KeyHash
script

    Bool -> Either ErrValidateScript () -> Either ErrValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValidationLevel
level ValidationLevel -> ValidationLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ValidationLevel
RecommendedValidation) (Either ErrValidateScript () -> Either ErrValidateScript ())
-> Either ErrValidateScript () -> Either ErrValidateScript ()
forall a b. (a -> b) -> a -> b
$
        (ErrRecommendedValidateScript -> ErrValidateScript)
-> Either ErrRecommendedValidateScript ()
-> Either ErrValidateScript ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrRecommendedValidateScript -> ErrValidateScript
NotRecommended (Script KeyHash -> Either ErrRecommendedValidateScript ()
forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation Script KeyHash
script)

requiredValidation
    :: Script elem
    -> Either ErrValidateScript ()
requiredValidation :: forall elem. Script elem -> Either ErrValidateScript ()
requiredValidation Script elem
script =
    Bool -> Either ErrValidateScript () -> Either ErrValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Script elem -> Bool
forall {elem}. Script elem -> Bool
check Script elem
script) (Either ErrValidateScript () -> Either ErrValidateScript ())
-> Either ErrValidateScript () -> Either ErrValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrValidateScript -> Either ErrValidateScript ()
forall a b. a -> Either a b
Left ErrValidateScript
LedgerIncompatible
  where
    check :: Script elem -> Bool
check = \case
        RequireSignatureOf elem
_ -> Bool
True

        RequireAllOf [Script elem]
xs ->
            (Script elem -> Bool) -> [Script elem] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.all Script elem -> Bool
check [Script elem]
xs

        RequireAnyOf [Script elem]
xs ->
            (Script elem -> Bool) -> [Script elem] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any Script elem -> Bool
check [Script elem]
xs

        RequireSomeOf Word8
m [Script elem]
xs ->
            Word8
m Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= [Word8] -> Word8
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Script elem -> Word8) -> [Script elem] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Script elem
x -> if Script elem -> Bool
check Script elem
x then Word8
1 else Word8
0) [Script elem]
xs)

        ActiveFromSlot Natural
_ -> Bool
True

        ActiveUntilSlot Natural
_ -> Bool
True

recommendedValidation
    :: Eq elem
    => Script elem
    -> Either ErrRecommendedValidateScript ()
recommendedValidation :: forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation = \case
    RequireSignatureOf elem
_ -> () -> Either ErrRecommendedValidateScript ()
forall a. a -> Either ErrRecommendedValidateScript a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    RequireAllOf [Script elem]
script -> do
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null ([Script elem] -> [Script elem]
forall {elem}. [Script elem] -> [Script elem]
omitTimelocks [Script elem]
script)) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
EmptyList
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {a}. Eq a => [Script a] -> Bool
hasDuplicate [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
DuplicateSignatures
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {elem}. [Script elem] -> Bool
redundantTimelocks [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
RedundantTimelocks
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {elem}. [Script elem] -> Bool
timelockTrap [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
TimelockTrap
        (Script elem -> Either ErrRecommendedValidateScript ())
-> [Script elem] -> Either ErrRecommendedValidateScript ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Script elem -> Either ErrRecommendedValidateScript ()
forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation [Script elem]
script

    RequireAnyOf [Script elem]
script -> do
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {a}. Eq a => [Script a] -> Bool
hasDuplicate [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
DuplicateSignatures
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {elem}. [Script elem] -> Bool
redundantTimelocks [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
RedundantTimelocks
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {elem}. [Script elem] -> Bool
redundantTimelocksInAny [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
RedundantTimelocks
        (Script elem -> Either ErrRecommendedValidateScript ())
-> [Script elem] -> Either ErrRecommendedValidateScript ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Script elem -> Either ErrRecommendedValidateScript ()
forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation [Script elem]
script

    RequireSomeOf Word8
m [Script elem]
script -> do
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
MZero
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Script elem] -> [Script elem]
forall {elem}. [Script elem] -> [Script elem]
omitTimelocks [Script elem]
script) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
m) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
ListTooSmall
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {a}. Eq a => [Script a] -> Bool
hasDuplicate [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
DuplicateSignatures
        Bool
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Script elem] -> Bool
forall {elem}. [Script elem] -> Bool
redundantTimelocks [Script elem]
script) (Either ErrRecommendedValidateScript ()
 -> Either ErrRecommendedValidateScript ())
-> Either ErrRecommendedValidateScript ()
-> Either ErrRecommendedValidateScript ()
forall a b. (a -> b) -> a -> b
$ ErrRecommendedValidateScript
-> Either ErrRecommendedValidateScript ()
forall a b. a -> Either a b
Left ErrRecommendedValidateScript
RedundantTimelocks
        (Script elem -> Either ErrRecommendedValidateScript ())
-> [Script elem] -> Either ErrRecommendedValidateScript ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Script elem -> Either ErrRecommendedValidateScript ()
forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation [Script elem]
script

    ActiveFromSlot Natural
_ -> () -> Either ErrRecommendedValidateScript ()
forall a. a -> Either ErrRecommendedValidateScript a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    ActiveUntilSlot Natural
_ -> () -> Either ErrRecommendedValidateScript ()
forall a. a -> Either ErrRecommendedValidateScript a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    hasDuplicate :: [Script a] -> Bool
hasDuplicate [Script a]
xs =
        [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
sigs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> [a]
forall a. Eq a => [a] -> [a]
L.nub [a]
sigs)
      where
        sigs :: [a]
sigs = [ a
sig | RequireSignatureOf a
sig <- [Script a]
xs ]
    hasTimelocks :: Script elem -> Bool
hasTimelocks = \case
        ActiveFromSlot Natural
_ -> Bool
True
        ActiveUntilSlot Natural
_ -> Bool
True
        Script elem
_ -> Bool
False
    redundantTimelocks :: [Script elem] -> Bool
redundantTimelocks [Script elem]
xs = case (Script elem -> Bool) -> [Script elem] -> [Script elem]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Script elem -> Bool
forall {elem}. Script elem -> Bool
hasTimelocks [Script elem]
xs of
        [] -> Bool
False
        [Script elem
_] -> Bool
False
        [Script elem
_, Script elem
_] -> Bool
False
        [Script elem]
_ -> Bool
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 :: [Script elem] -> Bool
redundantTimelocksInAny [Script elem]
xs = case (Script elem -> Bool) -> [Script elem] -> [Script elem]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Script elem -> Bool
forall {elem}. Script elem -> Bool
hasTimelocks [Script elem]
xs of
        [] -> Bool
False
        [Script elem
_] -> Bool
False
        [ActiveFromSlot Natural
s1, ActiveUntilSlot Natural
s2] -> Natural
s2 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
s1
        [ActiveUntilSlot Natural
s2, ActiveFromSlot Natural
s1] -> Natural
s2 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
s1
        [Script elem]
_ -> Bool
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 :: [Script elem] -> Bool
timelockTrap [Script elem]
xs =  case (Script elem -> Bool) -> [Script elem] -> [Script elem]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Script elem -> Bool
forall {elem}. Script elem -> Bool
hasTimelocks [Script elem]
xs of
        [ActiveFromSlot Natural
s1, ActiveUntilSlot Natural
s2] -> Natural
s2 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
s1
        [ActiveUntilSlot Natural
s2, ActiveFromSlot Natural
s1] -> Natural
s2 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
s1
        [Script elem]
_ -> Bool
False
    omitTimelocks :: [Script elem] -> [Script elem]
omitTimelocks = (Script elem -> Bool) -> [Script elem] -> [Script elem]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Script elem -> Bool) -> Script elem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script elem -> Bool
forall {elem}. Script elem -> Bool
hasTimelocks)
--
-- ScriptTemplate validation
--

-- | Validate a 'ScriptTemplate', semantically
--
-- @since 3.2.0
validateScriptTemplate
    :: ValidationLevel
    -> ScriptTemplate
    -> Either ErrValidateScriptTemplate ()
validateScriptTemplate :: ValidationLevel
-> ScriptTemplate -> Either ErrValidateScriptTemplate ()
validateScriptTemplate ValidationLevel
level (ScriptTemplate Map Cosigner XPub
cosigners_ Script Cosigner
script) = do
    (ErrValidateScript -> ErrValidateScriptTemplate)
-> Either ErrValidateScript ()
-> Either ErrValidateScriptTemplate ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrValidateScript -> ErrValidateScriptTemplate
WrongScript (ValidationLevel -> Script Cosigner -> Either ErrValidateScript ()
validateScriptOfTemplate ValidationLevel
level Script Cosigner
script)
    ErrValidateScriptTemplate
-> Bool -> Either ErrValidateScriptTemplate ()
forall {a}. a -> Bool -> Either a ()
check ErrValidateScriptTemplate
NoCosignerInScript (HashSet Cosigner -> Bool
forall {a}. HashSet a -> Bool
nonEmpty HashSet Cosigner
scriptCosigners)
    ErrValidateScriptTemplate
-> Bool -> Either ErrValidateScriptTemplate ()
forall {a}. a -> Bool -> Either a ()
check ErrValidateScriptTemplate
NoCosignerXPub (HashSet XPub -> Bool
forall {a}. HashSet a -> Bool
nonEmpty HashSet XPub
cosignerKeys)
    ErrValidateScriptTemplate
-> Bool -> Either ErrValidateScriptTemplate ()
forall {a}. a -> Bool -> Either a ()
check ErrValidateScriptTemplate
DuplicateXPubs (HashSet XPub -> Int
forall a. HashSet a -> Int
Set.size HashSet XPub
cosignerKeys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map Cosigner XPub -> Int
forall k a. Map k a -> Int
Map.size Map Cosigner XPub
cosigners_)
    ErrValidateScriptTemplate
-> Bool -> Either ErrValidateScriptTemplate ()
forall {a}. a -> Bool -> Either a ()
check ErrValidateScriptTemplate
UnknownCosigner (HashSet Cosigner
cosignerSet HashSet Cosigner -> HashSet Cosigner -> Bool
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool
`Set.isSubsetOf` HashSet Cosigner
scriptCosigners)
    ErrValidateScriptTemplate
-> Bool -> Either ErrValidateScriptTemplate ()
forall {a}. a -> Bool -> Either a ()
check ErrValidateScriptTemplate
MissingCosignerXPub (HashSet Cosigner
scriptCosigners HashSet Cosigner -> HashSet Cosigner -> Bool
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool
`Set.isSubsetOf` HashSet Cosigner
cosignerSet)
  where
    scriptCosigners :: HashSet Cosigner
scriptCosigners = [Cosigner] -> HashSet Cosigner
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Cosigner] -> HashSet Cosigner) -> [Cosigner] -> HashSet Cosigner
forall a b. (a -> b) -> a -> b
$ (Cosigner -> [Cosigner] -> [Cosigner])
-> [Cosigner] -> Script Cosigner -> [Cosigner]
forall a b. (a -> b -> b) -> b -> Script a -> b
foldScript (:) [] Script Cosigner
script
    cosignerKeys :: HashSet XPub
cosignerKeys = [XPub] -> HashSet XPub
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([XPub] -> HashSet XPub) -> [XPub] -> HashSet XPub
forall a b. (a -> b) -> a -> b
$ Map Cosigner XPub -> [XPub]
forall k a. Map k a -> [a]
Map.elems Map Cosigner XPub
cosigners_
    cosignerSet :: HashSet Cosigner
cosignerSet = [Cosigner] -> HashSet Cosigner
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Cosigner] -> HashSet Cosigner) -> [Cosigner] -> HashSet Cosigner
forall a b. (a -> b) -> a -> b
$ Map Cosigner XPub -> [Cosigner]
forall k a. Map k a -> [k]
Map.keys Map Cosigner XPub
cosigners_

    -- throws error if condition doesn't apply
    check :: a -> Bool -> Either a ()
check a
err Bool
cond = Bool -> Either a () -> Either a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cond (a -> Either a ()
forall a b. a -> Either a b
Left a
err)
    nonEmpty :: HashSet a -> Bool
nonEmpty = Bool -> Bool
not (Bool -> Bool) -> (HashSet a -> Bool) -> HashSet a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> Bool
forall {a}. HashSet a -> Bool
Set.null

-- | Validate a script in 'ScriptTemplate'
--
-- @since 3.5.0
validateScriptOfTemplate
    :: ValidationLevel
    -> Script Cosigner
    -> Either ErrValidateScript ()
validateScriptOfTemplate :: ValidationLevel -> Script Cosigner -> Either ErrValidateScript ()
validateScriptOfTemplate ValidationLevel
level Script Cosigner
script = do
    Script Cosigner -> Either ErrValidateScript ()
forall elem. Script elem -> Either ErrValidateScript ()
requiredValidation Script Cosigner
script
    Bool -> Either ErrValidateScript () -> Either ErrValidateScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValidationLevel
level ValidationLevel -> ValidationLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ValidationLevel
RecommendedValidation ) (Either ErrValidateScript () -> Either ErrValidateScript ())
-> Either ErrValidateScript () -> Either ErrValidateScript ()
forall a b. (a -> b) -> a -> b
$
        (ErrRecommendedValidateScript -> ErrValidateScript)
-> Either ErrRecommendedValidateScript ()
-> Either ErrValidateScript ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrRecommendedValidateScript -> ErrValidateScript
NotRecommended (Script Cosigner -> Either ErrRecommendedValidateScript ()
forall elem.
Eq elem =>
Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation Script Cosigner
script)

-- | Possible validation errors when validating a script
--
-- @since 3.0.0
data ErrValidateScript
    = LedgerIncompatible
    | WrongKeyHash
    | NotUniformKeyType
    | Malformed
    | NotRecommended ErrRecommendedValidateScript
    deriving (ErrValidateScript -> ErrValidateScript -> Bool
(ErrValidateScript -> ErrValidateScript -> Bool)
-> (ErrValidateScript -> ErrValidateScript -> Bool)
-> Eq ErrValidateScript
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrValidateScript -> ErrValidateScript -> Bool
== :: ErrValidateScript -> ErrValidateScript -> Bool
$c/= :: ErrValidateScript -> ErrValidateScript -> Bool
/= :: ErrValidateScript -> ErrValidateScript -> Bool
Eq, Int -> ErrValidateScript -> ShowS
[ErrValidateScript] -> ShowS
ErrValidateScript -> String
(Int -> ErrValidateScript -> ShowS)
-> (ErrValidateScript -> String)
-> ([ErrValidateScript] -> ShowS)
-> Show ErrValidateScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrValidateScript -> ShowS
showsPrec :: Int -> ErrValidateScript -> ShowS
$cshow :: ErrValidateScript -> String
show :: ErrValidateScript -> String
$cshowList :: [ErrValidateScript] -> ShowS
showList :: [ErrValidateScript] -> ShowS
Show)

-- | Possible recommended validation errors when validating a script
--
-- @since 3.2.0
data ErrRecommendedValidateScript
    = EmptyList
    | ListTooSmall
    | MZero
    | DuplicateSignatures
    | RedundantTimelocks
    | TimelockTrap
    deriving (ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
(ErrRecommendedValidateScript
 -> ErrRecommendedValidateScript -> Bool)
-> (ErrRecommendedValidateScript
    -> ErrRecommendedValidateScript -> Bool)
-> Eq ErrRecommendedValidateScript
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
== :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
$c/= :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
/= :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
Eq, Int -> ErrRecommendedValidateScript -> ShowS
[ErrRecommendedValidateScript] -> ShowS
ErrRecommendedValidateScript -> String
(Int -> ErrRecommendedValidateScript -> ShowS)
-> (ErrRecommendedValidateScript -> String)
-> ([ErrRecommendedValidateScript] -> ShowS)
-> Show ErrRecommendedValidateScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrRecommendedValidateScript -> ShowS
showsPrec :: Int -> ErrRecommendedValidateScript -> ShowS
$cshow :: ErrRecommendedValidateScript -> String
show :: ErrRecommendedValidateScript -> String
$cshowList :: [ErrRecommendedValidateScript] -> ShowS
showList :: [ErrRecommendedValidateScript] -> ShowS
Show)

-- | Possible validation errors when validating a script template
--
-- @since 3.2.0
data ErrValidateScriptTemplate
    = WrongScript ErrValidateScript
    | DuplicateXPubs
    | UnknownCosigner
    | MissingCosignerXPub
    | NoCosignerInScript
    | NoCosignerXPub
    deriving (ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
(ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool)
-> (ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool)
-> Eq ErrValidateScriptTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
== :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
$c/= :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
/= :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
Eq, Int -> ErrValidateScriptTemplate -> ShowS
[ErrValidateScriptTemplate] -> ShowS
ErrValidateScriptTemplate -> String
(Int -> ErrValidateScriptTemplate -> ShowS)
-> (ErrValidateScriptTemplate -> String)
-> ([ErrValidateScriptTemplate] -> ShowS)
-> Show ErrValidateScriptTemplate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrValidateScriptTemplate -> ShowS
showsPrec :: Int -> ErrValidateScriptTemplate -> ShowS
$cshow :: ErrValidateScriptTemplate -> String
show :: ErrValidateScriptTemplate -> String
$cshowList :: [ErrValidateScriptTemplate] -> ShowS
showList :: [ErrValidateScriptTemplate] -> ShowS
Show)

-- | Pretty-print a script validation error.
--
-- @since 3.0.0
prettyErrValidateScript
    :: ErrValidateScript
    -> String
prettyErrValidateScript :: ErrValidateScript -> String
prettyErrValidateScript = \case
    ErrValidateScript
LedgerIncompatible ->
        String
"The script is ill-formed and is not going to be accepted by the ledger."
    ErrValidateScript
WrongKeyHash ->
        String
"The hash of verification key is expected to have "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
credentialHashSize String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes."
    ErrValidateScript
NotUniformKeyType ->
        String
"All keys of a script must have the same role: payment, delegation, policy, \
        \representative, committee cold or committee hot."
    ErrValidateScript
Malformed ->
        String
"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 ErrRecommendedValidateScript
EmptyList ->
        String
"The list inside a script is empty or only contains timelocks \
        \(which is not recommended)."
    NotRecommended ErrRecommendedValidateScript
MZero ->
        String
"At least's coefficient is 0 (which is not recommended)."
    NotRecommended ErrRecommendedValidateScript
ListTooSmall ->
        String
"At least's coefficient is larger than the number of non-timelock \
        \elements in the list (which is not recommended)."
    NotRecommended ErrRecommendedValidateScript
DuplicateSignatures ->
        String
"The list inside a script has duplicate keys (which is not recommended)."
    NotRecommended ErrRecommendedValidateScript
RedundantTimelocks ->
        String
"Some timelocks used are redundant (which is not recommended)."
    NotRecommended ErrRecommendedValidateScript
TimelockTrap ->
        String
"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 :: ErrValidateScriptTemplate -> String
prettyErrValidateScriptTemplate = \case
    WrongScript ErrValidateScript
err -> ErrValidateScript -> String
prettyErrValidateScript ErrValidateScript
err
    ErrValidateScriptTemplate
DuplicateXPubs ->
        String
"The cosigners in a script template must stand behind an unique extended public key."
    ErrValidateScriptTemplate
MissingCosignerXPub ->
        String
"Each cosigner in a script template must have an extended public key."
    ErrValidateScriptTemplate
NoCosignerInScript ->
        String
"The script of a template must have at least one cosigner defined."
    ErrValidateScriptTemplate
NoCosignerXPub ->
        String
"The script template must have at least one cosigner with an extended public key."
    ErrValidateScriptTemplate
UnknownCosigner ->
        String
"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 :: Script elem -> Value
toJSON (RequireSignatureOf elem
content) = elem -> Value
forall a. ToJSON a => a -> Value
toJSON elem
content
    toJSON (RequireAllOf [Script elem]
content) =
        [Pair] -> Value
object [Key
"all" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Script elem -> Value) -> [Script elem] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Script elem -> Value
forall a. ToJSON a => a -> Value
toJSON [Script elem]
content]
    toJSON (RequireAnyOf [Script elem]
content) =
        [Pair] -> Value
object [Key
"any" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Script elem -> Value) -> [Script elem] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Script elem -> Value
forall a. ToJSON a => a -> Value
toJSON [Script elem]
content]
    toJSON (RequireSomeOf Word8
count [Script elem]
scripts) =
        [Pair] -> Value
object [Key
"some" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"at_least" Key -> Word8 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word8
count, Key
"from" Key -> [Script elem] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Script elem]
scripts]]
    toJSON (ActiveFromSlot Natural
slot) =
        [Pair] -> Value
object [Key
"active_from" Key -> Natural -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural
slot]
    toJSON (ActiveUntilSlot Natural
slot) =
        [Pair] -> Value
object [Key
"active_until" Key -> Natural -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural
slot]

instance FromJSON (Script KeyHash) where
    parseJSON :: Value -> Parser (Script KeyHash)
parseJSON Value
v =
        (Value -> Parser (Script KeyHash))
-> (Value -> Parser (Script KeyHash))
-> Value
-> Parser (Script KeyHash)
forall elem.
FromJSON (Script elem) =>
(Value -> Parser (Script elem))
-> (Value -> Parser (Script elem)) -> Value -> Parser (Script elem)
fromScriptJson Value -> Parser (Script KeyHash)
parseKey Value -> Parser (Script KeyHash)
backtrack Value
v
      where
        parseKey :: Value -> Parser (Script KeyHash)
parseKey = String
-> (Text -> Parser (Script KeyHash))
-> Value
-> Parser (Script KeyHash)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Script KeyHash" ((Text -> Parser (Script KeyHash))
 -> Value -> Parser (Script KeyHash))
-> (Text -> Parser (Script KeyHash))
-> Value
-> Parser (Script KeyHash)
forall a b. (a -> b) -> a -> b
$
            (ErrKeyHashFromText -> Parser (Script KeyHash))
-> (KeyHash -> Parser (Script KeyHash))
-> Either ErrKeyHashFromText KeyHash
-> Parser (Script KeyHash)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (String -> Parser (Script KeyHash)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Script KeyHash))
-> (ErrKeyHashFromText -> String)
-> ErrKeyHashFromText
-> Parser (Script KeyHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrKeyHashFromText -> String
prettyErrKeyHashFromText)
                (Script KeyHash -> Parser (Script KeyHash)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script KeyHash -> Parser (Script KeyHash))
-> (KeyHash -> Script KeyHash)
-> KeyHash
-> Parser (Script KeyHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash -> Script KeyHash
forall elem. elem -> Script elem
RequireSignatureOf)
                (Either ErrKeyHashFromText KeyHash -> Parser (Script KeyHash))
-> (Text -> Either ErrKeyHashFromText KeyHash)
-> Text
-> Parser (Script KeyHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ErrKeyHashFromText KeyHash
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 :: Value -> Parser (Script KeyHash)
backtrack = \case
            Object Object
o -> do
                Maybe Value
mAny  <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"any"  :: Parser (Maybe Value)
                Maybe Value
mAll  <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"all"  :: Parser (Maybe Value)
                Maybe Value
mSome <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"some" :: Parser (Maybe Value)
                case (Maybe Value
mAny, Maybe Value
mAll, Maybe Value
mSome) of
                    (Just{}, Maybe Value
Nothing, Maybe Value
Nothing)  -> Value -> Parser (Script KeyHash)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAnyOf Value
v
                    (Maybe Value
Nothing, Just{}, Maybe Value
Nothing)  -> Value -> Parser (Script KeyHash)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAllOf Value
v
                    (Maybe Value
Nothing, Maybe Value
Nothing, Just{})  -> Value -> Parser (Script KeyHash)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAtLeast Value
v
                    (Maybe Value
Nothing, Maybe Value
Nothing, Maybe Value
Nothing) -> String -> Parser (Script KeyHash)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                        String
"Found object with unknown key. Expecting 'any', 'all' or 'some'"
                    (      Maybe Value
_,       Maybe Value
_,      Maybe Value
_)  -> String -> Parser (Script KeyHash)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                        String
"Found multiple keys 'any', 'all' and/or 'some' at the same level"
            String{} ->
                Value -> Parser (Script KeyHash)
parseKey Value
v
            Value
_ ->
                String -> Value -> Parser (Script KeyHash)
forall a. String -> Value -> Parser a
Json.typeMismatch String
"Object or String" Value
v

fromScriptJson
    :: FromJSON (Script elem)
    => (Value -> Parser (Script elem))
    -> (Value -> Parser (Script elem))
    -> Value
    -> Parser (Script elem)
fromScriptJson :: forall elem.
FromJSON (Script elem) =>
(Value -> Parser (Script elem))
-> (Value -> Parser (Script elem)) -> Value -> Parser (Script elem)
fromScriptJson Value -> Parser (Script elem)
parseElem Value -> Parser (Script elem)
backtrack Value
v =
    [Parser (Script elem)] -> Parser (Script elem)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Value -> Parser (Script elem)
parseElem Value
v
        , Value -> Parser (Script elem)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAnyOf Value
v
        , Value -> Parser (Script elem)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAllOf Value
v
        , Value -> Parser (Script elem)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAtLeast Value
v
        , Value -> Parser (Script elem)
forall elem. Value -> Parser (Script elem)
parseActiveFrom Value
v
        , Value -> Parser (Script elem)
forall elem. Value -> Parser (Script elem)
parseActiveUntil Value
v
        ] Parser (Script elem)
-> Parser (Script elem) -> Parser (Script elem)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Script elem)
backtrack Value
v

parseAnyOf
    :: FromJSON (Script elem)
    => Value
    -> Parser (Script elem)
parseAnyOf :: forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAnyOf = String
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Script AnyOf" ((Object -> Parser (Script elem)) -> Value -> Parser (Script elem))
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [Script elem] -> Script elem
forall elem. [Script elem] -> Script elem
RequireAnyOf ([Script elem] -> Script elem)
-> Parser [Script elem] -> Parser (Script elem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [Script elem]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"any"

parseAllOf
    :: FromJSON (Script elem)
    => Value
    -> Parser (Script elem)
parseAllOf :: forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAllOf = String
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Script AllOf" ((Object -> Parser (Script elem)) -> Value -> Parser (Script elem))
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [Script elem] -> Script elem
forall elem. [Script elem] -> Script elem
RequireAllOf ([Script elem] -> Script elem)
-> Parser [Script elem] -> Parser (Script elem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [Script elem]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"all"

parseAtLeast
    :: FromJSON (Script elem)
    => Value
    -> Parser (Script elem)
parseAtLeast :: forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAtLeast = String
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Script SomeOf" ((Object -> Parser (Script elem)) -> Value -> Parser (Script elem))
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Object
some <- Object
o Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"some"
    Word8 -> [Script elem] -> Script elem
forall elem. Word8 -> [Script elem] -> Script elem
RequireSomeOf (Word8 -> [Script elem] -> Script elem)
-> Parser Word8 -> Parser ([Script elem] -> Script elem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
some Object -> Key -> Parser Word8
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"at_least" Parser ([Script elem] -> Script elem)
-> Parser [Script elem] -> Parser (Script elem)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
some Object -> Key -> Parser [Script elem]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from"

parseActiveFrom
    :: Value
    -> Parser (Script elem)
parseActiveFrom :: forall elem. Value -> Parser (Script elem)
parseActiveFrom = String
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Script ActiveFrom" ((Object -> Parser (Script elem)) -> Value -> Parser (Script elem))
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Natural -> Script elem
forall elem. Natural -> Script elem
ActiveFromSlot (Natural -> Script elem) -> Parser Natural -> Parser (Script elem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"active_from"

parseActiveUntil
    :: Value
    -> Parser (Script elem)
parseActiveUntil :: forall elem. Value -> Parser (Script elem)
parseActiveUntil = String
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Script ActiveUntil" ((Object -> Parser (Script elem)) -> Value -> Parser (Script elem))
-> (Object -> Parser (Script elem))
-> Value
-> Parser (Script elem)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Natural -> Script elem
forall elem. Natural -> Script elem
ActiveUntilSlot (Natural -> Script elem) -> Parser Natural -> Parser (Script elem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"active_until"

cosignerToText :: Cosigner -> Text
cosignerToText :: Cosigner -> Text
cosignerToText (Cosigner Word8
ix) = Text
"cosigner#"Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word8 -> String
forall a. Show a => a -> String
show Word8
ix)

instance ToJSON Cosigner where
    toJSON :: Cosigner -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Cosigner -> Text) -> Cosigner -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosigner -> Text
cosignerToText

instance FromJSON Cosigner where
    parseJSON :: Value -> Parser Cosigner
parseJSON = String -> (Text -> Parser Cosigner) -> Value -> Parser Cosigner
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Cosigner" ((Text -> Parser Cosigner) -> Value -> Parser Cosigner)
-> (Text -> Parser Cosigner) -> Value -> Parser Cosigner
forall a b. (a -> b) -> a -> b
$ \Text
txt -> case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"cosigner#" Text
txt of
        [Text
"",Text
numTxt] ->  case Reader Word8
forall a. Integral a => Reader a
T.decimal Text
numTxt of
            Right (Word8
num,Text
"") -> do
                Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
num Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< forall a. Bounded a => a
minBound @Word8 Bool -> Bool -> Bool
|| Word8
num Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> forall a. Bounded a => a
maxBound @Word8) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
                        String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigner number should be between '0' and '255'"
                Cosigner -> Parser Cosigner
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cosigner -> Parser Cosigner) -> Cosigner -> Parser Cosigner
forall a b. (a -> b) -> a -> b
$ Word8 -> Cosigner
Cosigner Word8
num
            Either String (Word8, Text)
_ -> String -> Parser Cosigner
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigner should be enumerated with number"
        [Text]
_ -> String -> Parser Cosigner
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigner should be of the form: cosigner#num"

encodeXPub :: XPub -> Value
encodeXPub :: XPub -> Value
encodeXPub = Text -> Value
String (Text -> Value) -> (XPub -> Text) -> XPub -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (XPub -> ByteString) -> XPub -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString -> ByteString
encode Encoding
forall a. AbstractEncoding a
EBase16 (ByteString -> ByteString)
-> (XPub -> ByteString) -> XPub -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPub -> ByteString
xpubToBytes

parseXPub :: Value -> Parser XPub
parseXPub :: Value -> Parser XPub
parseXPub = String -> (Text -> Parser XPub) -> Value -> Parser XPub
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"XPub" ((Text -> Parser XPub) -> Value -> Parser XPub)
-> (Text -> Parser XPub) -> Value -> Parser XPub
forall a b. (a -> b) -> a -> b
$ \Text
txt ->
    case ByteString -> Either String ByteString
fromBase16 (Text -> ByteString
T.encodeUtf8 Text
txt) of
        Left String
err -> String -> Parser XPub
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right ByteString
hex -> case ByteString -> Maybe XPub
xpubFromBytes ByteString
hex of
            Maybe XPub
Nothing -> String -> Parser XPub
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Extended public key cannot be retrieved from a given hex bytestring"
            Just XPub
validXPub -> XPub -> Parser XPub
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XPub
validXPub

instance ToJSON ScriptTemplate where
    toJSON :: ScriptTemplate -> Value
toJSON (ScriptTemplate Map Cosigner XPub
cosigners' Script Cosigner
template') =
        [Pair] -> Value
object [ Key
"cosigners" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (((Cosigner, XPub) -> Pair) -> [(Cosigner, XPub)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Key) -> (Text, Value) -> Pair
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
fromText ((Text, Value) -> Pair)
-> ((Cosigner, XPub) -> (Text, Value)) -> (Cosigner, XPub) -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosigner, XPub) -> (Text, Value)
toPair) (Map Cosigner XPub -> [(Cosigner, XPub)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Cosigner XPub
cosigners'))
               , Key
"template" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Script Cosigner -> Value
forall a. ToJSON a => a -> Value
toJSON Script Cosigner
template']
      where
        toPair :: (Cosigner, XPub) -> (Text, Value)
toPair (Cosigner
cosigner', XPub
xpub) =
            ( Cosigner -> Text
cosignerToText Cosigner
cosigner'
            , XPub -> Value
encodeXPub XPub
xpub )

instance FromJSON (Script Cosigner) where
    parseJSON :: Value -> Parser (Script Cosigner)
parseJSON Value
v = (Value -> Parser (Script Cosigner))
-> (Value -> Parser (Script Cosigner))
-> Value
-> Parser (Script Cosigner)
forall elem.
FromJSON (Script elem) =>
(Value -> Parser (Script elem))
-> (Value -> Parser (Script elem)) -> Value -> Parser (Script elem)
fromScriptJson Value -> Parser (Script Cosigner)
parserCosigner Value -> Parser (Script Cosigner)
backtrack Value
v
      where
        parserCosigner :: Value -> Parser (Script Cosigner)
parserCosigner Value
o = do
            Cosigner
cosigner <- forall a. FromJSON a => Value -> Parser a
parseJSON @Cosigner Value
o
            Script Cosigner -> Parser (Script Cosigner)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script Cosigner -> Parser (Script Cosigner))
-> Script Cosigner -> Parser (Script Cosigner)
forall a b. (a -> b) -> a -> b
$ Cosigner -> Script Cosigner
forall elem. elem -> Script elem
RequireSignatureOf Cosigner
cosigner
        backtrack :: Value -> Parser (Script Cosigner)
backtrack = \case
            Object Object
o -> do
                Maybe Value
mAny  <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"any"  :: Parser (Maybe Value)
                Maybe Value
mAll  <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"all"  :: Parser (Maybe Value)
                Maybe Value
mSome <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"some" :: Parser (Maybe Value)
                Maybe Value
mCos <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"cosigner" :: Parser (Maybe Value)
                case (Maybe Value
mAny, Maybe Value
mAll, Maybe Value
mSome, Maybe Value
mCos) of
                    (Just{}, Maybe Value
Nothing, Maybe Value
Nothing, Maybe Value
Nothing)  -> Value -> Parser (Script Cosigner)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAnyOf Value
v
                    (Maybe Value
Nothing, Just{}, Maybe Value
Nothing, Maybe Value
Nothing)  -> Value -> Parser (Script Cosigner)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAllOf Value
v
                    (Maybe Value
Nothing, Maybe Value
Nothing, Just{}, Maybe Value
Nothing)  -> Value -> Parser (Script Cosigner)
forall elem.
FromJSON (Script elem) =>
Value -> Parser (Script elem)
parseAtLeast Value
v
                    (Maybe Value
Nothing, Maybe Value
Nothing, Maybe Value
Nothing, Just{})  -> Value -> Parser (Script Cosigner)
parserCosigner Value
v
                    (Maybe Value
Nothing, Maybe Value
Nothing, Maybe Value
Nothing, Maybe Value
Nothing) -> String -> Parser (Script Cosigner)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                        String
"Found object with unknown key. Expecting 'any', 'all', 'some' or 'cosigner'"
                    (      Maybe Value
_,       Maybe Value
_,      Maybe Value
_,       Maybe Value
_)  -> String -> Parser (Script Cosigner)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                        String
"Found multiple keys 'any', 'all', 'cosigner' and/or 'some' at the same level"
            Value
_ ->
                String -> Value -> Parser (Script Cosigner)
forall a. String -> Value -> Parser a
Json.typeMismatch String
"Object only" Value
v

instance FromJSON ScriptTemplate where
    parseJSON :: Value -> Parser ScriptTemplate
parseJSON = String
-> (Object -> Parser ScriptTemplate)
-> Value
-> Parser ScriptTemplate
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ScriptTemplate" ((Object -> Parser ScriptTemplate)
 -> Value -> Parser ScriptTemplate)
-> (Object -> Parser ScriptTemplate)
-> Value
-> Parser ScriptTemplate
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        Parser (Script Cosigner)
template' <- Value -> Parser (Script Cosigner)
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser (Script Cosigner))
-> Parser Value -> Parser (Parser (Script Cosigner))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"template"
        Parser [(Cosigner, XPub)]
cosigners' <- Value -> Parser [(Cosigner, XPub)]
parseCosignerPairs (Value -> Parser [(Cosigner, XPub)])
-> Parser Value -> Parser (Parser [(Cosigner, XPub)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"cosigners"
        Map Cosigner XPub -> Script Cosigner -> ScriptTemplate
ScriptTemplate (Map Cosigner XPub -> Script Cosigner -> ScriptTemplate)
-> ([(Cosigner, XPub)] -> Map Cosigner XPub)
-> [(Cosigner, XPub)]
-> Script Cosigner
-> ScriptTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Cosigner, XPub)] -> Map Cosigner XPub
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Cosigner, XPub)] -> Script Cosigner -> ScriptTemplate)
-> Parser [(Cosigner, XPub)]
-> Parser (Script Cosigner -> ScriptTemplate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [(Cosigner, XPub)]
cosigners' Parser (Script Cosigner -> ScriptTemplate)
-> Parser (Script Cosigner) -> Parser ScriptTemplate
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Script Cosigner)
template'
      where
        parseCosignerPairs :: Value -> Parser [(Cosigner, XPub)]
parseCosignerPairs = String
-> (Object -> Parser [(Cosigner, XPub)])
-> Value
-> Parser [(Cosigner, XPub)]
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Cosigner pairs" ((Object -> Parser [(Cosigner, XPub)])
 -> Value -> Parser [(Cosigner, XPub)])
-> (Object -> Parser [(Cosigner, XPub)])
-> Value
-> Parser [(Cosigner, XPub)]
forall a b. (a -> b) -> a -> b
$ \Object
o ->
            case Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o of
                [] -> String -> Parser [(Cosigner, XPub)]
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigners object array should not be empty"
                [Pair]
cs -> [Pair]
-> (Pair -> Parser (Cosigner, XPub)) -> Parser [(Cosigner, XPub)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Pair] -> [Pair]
forall a. [a] -> [a]
reverse [Pair]
cs) ((Pair -> Parser (Cosigner, XPub)) -> Parser [(Cosigner, XPub)])
-> (Pair -> Parser (Cosigner, XPub)) -> Parser [(Cosigner, XPub)]
forall a b. (a -> b) -> a -> b
$ \(Key
numTxt, Value
str) -> do
                    Cosigner
cosigner' <- forall a. FromJSON a => Value -> Parser a
parseJSON @Cosigner (Text -> Value
String (Key -> Text
toText Key
numTxt))
                    XPub
xpub <- Value -> Parser XPub
parseXPub Value
str
                    (Cosigner, XPub) -> Parser (Cosigner, XPub)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cosigner
cosigner', XPub
xpub)