{-# LANGUAGE BangPatterns #-}
{-# 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 #-}

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

    , KeyHash (..)
    , KeyRole (..)
    , keyHashFromBytes
    , keyHashFromText
    , keyHashToText
    , ErrKeyHashFromText
    , prettyErrKeyHashFromText
    ) where

import Prelude

import Cardano.Address.Derivation
    ( XPub, credentialHashSize, hashCredential, xpubFromBytes, xpubToBytes )
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.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 qualified HaskellWorks.Data.Aeson.Compat as J
import qualified HaskellWorks.Data.Aeson.Compat.Map as JM
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.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
$cto :: forall elem x. Rep (Script elem) x -> Script elem
$cfrom :: forall elem x. Script elem -> Rep (Script elem) x
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
showList :: [Script elem] -> ShowS
$cshowList :: forall elem. Show elem => [Script elem] -> ShowS
show :: Script elem -> String
$cshow :: forall elem. Show elem => Script elem -> String
showsPrec :: Int -> Script elem -> ShowS
$cshowsPrec :: forall elem. Show elem => Int -> 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
/= :: Script elem -> Script elem -> Bool
$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
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 :: (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 (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
$cto :: forall x. Rep Cosigner x -> Cosigner
$cfrom :: forall x. Cosigner -> Rep Cosigner x
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
min :: Cosigner -> Cosigner -> Cosigner
$cmin :: Cosigner -> Cosigner -> Cosigner
max :: Cosigner -> Cosigner -> Cosigner
$cmax :: Cosigner -> Cosigner -> Cosigner
>= :: Cosigner -> Cosigner -> Bool
$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
compare :: Cosigner -> Cosigner -> Ordering
$ccompare :: Cosigner -> Cosigner -> Ordering
$cp1Ord :: Eq Cosigner
Ord, Cosigner -> Cosigner -> Bool
(Cosigner -> Cosigner -> Bool)
-> (Cosigner -> Cosigner -> Bool) -> Eq Cosigner
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cosigner -> Cosigner -> Bool
$c/= :: Cosigner -> Cosigner -> Bool
== :: Cosigner -> Cosigner -> Bool
$c== :: 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
$cto :: forall x. Rep ScriptTemplate x -> ScriptTemplate
$cfrom :: forall x. ScriptTemplate -> Rep ScriptTemplate x
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
showList :: [ScriptTemplate] -> ShowS
$cshowList :: [ScriptTemplate] -> ShowS
show :: ScriptTemplate -> String
$cshow :: ScriptTemplate -> String
showsPrec :: Int -> ScriptTemplate -> ShowS
$cshowsPrec :: Int -> ScriptTemplate -> ShowS
Show, ScriptTemplate -> ScriptTemplate -> Bool
(ScriptTemplate -> ScriptTemplate -> Bool)
-> (ScriptTemplate -> ScriptTemplate -> Bool) -> Eq ScriptTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptTemplate -> ScriptTemplate -> Bool
$c/= :: ScriptTemplate -> ScriptTemplate -> Bool
== :: ScriptTemplate -> ScriptTemplate -> Bool
$c== :: 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
$cto :: forall x. Rep ScriptHash x -> ScriptHash
$cfrom :: forall x. ScriptHash -> Rep ScriptHash x
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
showList :: [ScriptHash] -> ShowS
$cshowList :: [ScriptHash] -> ShowS
show :: ScriptHash -> String
$cshow :: ScriptHash -> String
showsPrec :: Int -> ScriptHash -> ShowS
$cshowsPrec :: Int -> 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
min :: ScriptHash -> ScriptHash -> ScriptHash
$cmin :: ScriptHash -> ScriptHash -> ScriptHash
max :: ScriptHash -> ScriptHash -> ScriptHash
$cmax :: ScriptHash -> ScriptHash -> ScriptHash
>= :: ScriptHash -> ScriptHash -> Bool
$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
compare :: ScriptHash -> ScriptHash -> Ordering
$ccompare :: ScriptHash -> ScriptHash -> Ordering
$cp1Ord :: Eq ScriptHash
Ord, ScriptHash -> ScriptHash -> Bool
(ScriptHash -> ScriptHash -> Bool)
-> (ScriptHash -> ScriptHash -> Bool) -> Eq ScriptHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptHash -> ScriptHash -> Bool
$c/= :: ScriptHash -> ScriptHash -> Bool
== :: ScriptHash -> ScriptHash -> Bool
$c== :: 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

data KeyRole = Payment | Delegation | Policy | Unknown
    deriving ((forall x. KeyRole -> Rep KeyRole x)
-> (forall x. Rep KeyRole x -> KeyRole) -> Generic KeyRole
forall x. Rep KeyRole x -> KeyRole
forall x. KeyRole -> Rep KeyRole x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep KeyRole x -> KeyRole
$cfrom :: forall x. KeyRole -> Rep KeyRole x
Generic, Int -> KeyRole -> ShowS
[KeyRole] -> ShowS
KeyRole -> String
(Int -> KeyRole -> ShowS)
-> (KeyRole -> String) -> ([KeyRole] -> ShowS) -> Show KeyRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyRole] -> ShowS
$cshowList :: [KeyRole] -> ShowS
show :: KeyRole -> String
$cshow :: KeyRole -> String
showsPrec :: Int -> KeyRole -> ShowS
$cshowsPrec :: Int -> KeyRole -> ShowS
Show, Eq KeyRole
Eq KeyRole
-> (KeyRole -> KeyRole -> Ordering)
-> (KeyRole -> KeyRole -> Bool)
-> (KeyRole -> KeyRole -> Bool)
-> (KeyRole -> KeyRole -> Bool)
-> (KeyRole -> KeyRole -> Bool)
-> (KeyRole -> KeyRole -> KeyRole)
-> (KeyRole -> KeyRole -> KeyRole)
-> Ord KeyRole
KeyRole -> KeyRole -> Bool
KeyRole -> KeyRole -> Ordering
KeyRole -> KeyRole -> KeyRole
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
min :: KeyRole -> KeyRole -> KeyRole
$cmin :: KeyRole -> KeyRole -> KeyRole
max :: KeyRole -> KeyRole -> KeyRole
$cmax :: KeyRole -> KeyRole -> KeyRole
>= :: KeyRole -> KeyRole -> Bool
$c>= :: KeyRole -> KeyRole -> Bool
> :: KeyRole -> KeyRole -> Bool
$c> :: KeyRole -> KeyRole -> Bool
<= :: KeyRole -> KeyRole -> Bool
$c<= :: KeyRole -> KeyRole -> Bool
< :: KeyRole -> KeyRole -> Bool
$c< :: KeyRole -> KeyRole -> Bool
compare :: KeyRole -> KeyRole -> Ordering
$ccompare :: KeyRole -> KeyRole -> Ordering
$cp1Ord :: Eq KeyRole
Ord, KeyRole -> KeyRole -> Bool
(KeyRole -> KeyRole -> Bool)
-> (KeyRole -> KeyRole -> Bool) -> Eq KeyRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyRole -> KeyRole -> Bool
$c/= :: KeyRole -> KeyRole -> Bool
== :: KeyRole -> KeyRole -> Bool
$c== :: KeyRole -> KeyRole -> Bool
Eq)
instance NFData KeyRole

-- | A 'KeyHash' type represents verification key hash that participate in building
-- multi-signature script. The hash is expected to have size of 28-byte.
--
-- @since 3.0.0
data KeyHash = KeyHash
    { KeyHash -> KeyRole
role :: KeyRole
    , KeyHash -> ByteString
digest :: ByteString }
    deriving ((forall x. KeyHash -> Rep KeyHash x)
-> (forall x. Rep KeyHash x -> KeyHash) -> Generic KeyHash
forall x. Rep KeyHash x -> KeyHash
forall x. KeyHash -> Rep KeyHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep KeyHash x -> KeyHash
$cfrom :: forall x. KeyHash -> Rep KeyHash x
Generic, Int -> KeyHash -> ShowS
[KeyHash] -> ShowS
KeyHash -> String
(Int -> KeyHash -> ShowS)
-> (KeyHash -> String) -> ([KeyHash] -> ShowS) -> Show KeyHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyHash] -> ShowS
$cshowList :: [KeyHash] -> ShowS
show :: KeyHash -> String
$cshow :: KeyHash -> String
showsPrec :: Int -> KeyHash -> ShowS
$cshowsPrec :: Int -> KeyHash -> ShowS
Show, Eq KeyHash
Eq KeyHash
-> (KeyHash -> KeyHash -> Ordering)
-> (KeyHash -> KeyHash -> Bool)
-> (KeyHash -> KeyHash -> Bool)
-> (KeyHash -> KeyHash -> Bool)
-> (KeyHash -> KeyHash -> Bool)
-> (KeyHash -> KeyHash -> KeyHash)
-> (KeyHash -> KeyHash -> KeyHash)
-> Ord KeyHash
KeyHash -> KeyHash -> Bool
KeyHash -> KeyHash -> Ordering
KeyHash -> KeyHash -> KeyHash
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
min :: KeyHash -> KeyHash -> KeyHash
$cmin :: KeyHash -> KeyHash -> KeyHash
max :: KeyHash -> KeyHash -> KeyHash
$cmax :: KeyHash -> KeyHash -> KeyHash
>= :: KeyHash -> KeyHash -> Bool
$c>= :: KeyHash -> KeyHash -> Bool
> :: KeyHash -> KeyHash -> Bool
$c> :: KeyHash -> KeyHash -> Bool
<= :: KeyHash -> KeyHash -> Bool
$c<= :: KeyHash -> KeyHash -> Bool
< :: KeyHash -> KeyHash -> Bool
$c< :: KeyHash -> KeyHash -> Bool
compare :: KeyHash -> KeyHash -> Ordering
$ccompare :: KeyHash -> KeyHash -> Ordering
$cp1Ord :: Eq KeyHash
Ord, KeyHash -> KeyHash -> Bool
(KeyHash -> KeyHash -> Bool)
-> (KeyHash -> KeyHash -> Bool) -> Eq KeyHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyHash -> KeyHash -> Bool
$c/= :: KeyHash -> KeyHash -> Bool
== :: KeyHash -> KeyHash -> Bool
$c== :: KeyHash -> KeyHash -> Bool
Eq)
instance NFData KeyHash

-- | Construct an 'KeyHash' from raw 'ByteString' (28 bytes).
--
-- @since 3.0.0
keyHashFromBytes :: (KeyRole, ByteString) -> Maybe KeyHash
keyHashFromBytes :: (KeyRole, ByteString) -> Maybe KeyHash
keyHashFromBytes (KeyRole
cred, ByteString
bytes)
    | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
credentialHashSize = Maybe KeyHash
forall a. Maybe a
Nothing
    | Bool
otherwise = KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just (KeyHash -> Maybe KeyHash) -> KeyHash -> Maybe KeyHash
forall a b. (a -> b) -> a -> b
$ KeyRole -> ByteString -> KeyHash
KeyHash KeyRole
cred ByteString
bytes

-- | Encode a 'KeyHash' to bech32 'Text' or hex is key role unknown.
--
-- @since 3.0.0
keyHashToText :: KeyHash -> Text
keyHashToText :: KeyHash -> Text
keyHashToText (KeyHash KeyRole
cred ByteString
keyHash) = case KeyRole
cred of
    KeyRole
Payment ->
        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.addr_shared_vkh) ByteString
keyHash
    KeyRole
Delegation ->
        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.stake_shared_vkh) ByteString
keyHash
    KeyRole
Policy ->
        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.policy_vkh) ByteString
keyHash
    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
keyHash

-- | Construct a 'KeyHash' from 'Text'. It should be
-- Bech32 encoded text with one of following hrp:
-- - `addr_shared_vkh`
-- - `stake_shared_vkh`
-- - `addr_vkh`
-- - `stake_vkh`
-- - `policy_vkh`
-- - `addr_shared_vk`
-- - `stake_shared_vk`
-- - `addr_vk`
-- - `stake_vk`
-- - `addr_shared_xvk`
-- - `stake_shared_xvk`
-- - `addr_xvk`
-- - `stake_xvk`
-- - `policy_vk`
-- - `policy_xvk`
-- Raw keys will be hashed on the fly, whereas hash that are directly
-- provided will remain as such.
-- If if hex is encountered Unknown policy key is assumed
--
-- @since 3.1.0
keyHashFromText :: Text -> Either ErrKeyHashFromText KeyHash
keyHashFromText :: Text -> Either ErrKeyHashFromText KeyHash
keyHashFromText 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
                KeyHash -> Either ErrKeyHashFromText KeyHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash -> Either ErrKeyHashFromText KeyHash)
-> KeyHash -> Either ErrKeyHashFromText KeyHash
forall a b. (a -> b) -> a -> b
$ KeyRole -> ByteString -> KeyHash
KeyHash KeyRole
Unknown ByteString
bs
            else if ByteString -> Int -> Bool
checkBSLength ByteString
bs Int
32 then
                KeyHash -> Either ErrKeyHashFromText KeyHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash -> Either ErrKeyHashFromText KeyHash)
-> KeyHash -> Either ErrKeyHashFromText KeyHash
forall a b. (a -> b) -> a -> b
$ KeyRole -> ByteString -> KeyHash
KeyHash KeyRole
Unknown (ByteString -> ByteString
hashCredential ByteString
bs)
            else if ByteString -> Int -> Bool
checkBSLength ByteString
bs Int
64 then
                KeyHash -> Either ErrKeyHashFromText KeyHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash -> Either ErrKeyHashFromText KeyHash)
-> KeyHash -> Either ErrKeyHashFromText KeyHash
forall a b. (a -> b) -> a -> b
$ KeyRole -> ByteString -> KeyHash
KeyHash KeyRole
Unknown (ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bs)
            else
                ErrKeyHashFromText -> Either ErrKeyHashFromText KeyHash
forall a b. a -> Either a b
Left ErrKeyHashFromText
ErrKeyHashFromTextInvalidHex
        Left String
_ -> do
            (HumanReadablePart
hrp, DataPart
dp) <- (DecodingError -> ErrKeyHashFromText)
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either ErrKeyHashFromText (HumanReadablePart, DataPart)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ErrKeyHashFromText -> DecodingError -> ErrKeyHashFromText
forall a b. a -> b -> a
const ErrKeyHashFromText
ErrKeyHashFromTextInvalidString) (Either DecodingError (HumanReadablePart, DataPart)
 -> Either ErrKeyHashFromText (HumanReadablePart, DataPart))
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either ErrKeyHashFromText (HumanReadablePart, DataPart)
forall a b. (a -> b) -> a -> b
$
                Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
txt

            ErrKeyHashFromText
-> Maybe ByteString -> Either ErrKeyHashFromText ByteString
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrKeyHashFromText
ErrKeyHashFromTextWrongDataPart (DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dp)
                Either ErrKeyHashFromText ByteString
-> (ByteString -> Either ErrKeyHashFromText (KeyRole, ByteString))
-> Either ErrKeyHashFromText (KeyRole, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrKeyHashFromText
-> Maybe (KeyRole, ByteString)
-> Either ErrKeyHashFromText (KeyRole, ByteString)
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrKeyHashFromText
ErrKeyHashFromTextWrongHrp (Maybe (KeyRole, ByteString)
 -> Either ErrKeyHashFromText (KeyRole, ByteString))
-> (ByteString -> Maybe (KeyRole, ByteString))
-> ByteString
-> Either ErrKeyHashFromText (KeyRole, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HumanReadablePart -> ByteString -> Maybe (KeyRole, ByteString)
convertBytes HumanReadablePart
hrp
                Either ErrKeyHashFromText (KeyRole, ByteString)
-> ((KeyRole, ByteString) -> Either ErrKeyHashFromText KeyHash)
-> Either ErrKeyHashFromText KeyHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrKeyHashFromText
-> Maybe KeyHash -> Either ErrKeyHashFromText KeyHash
forall b a. b -> Maybe a -> Either b a
maybeToRight ErrKeyHashFromText
ErrKeyHashFromTextWrongPayload (Maybe KeyHash -> Either ErrKeyHashFromText KeyHash)
-> ((KeyRole, ByteString) -> Maybe KeyHash)
-> (KeyRole, ByteString)
-> Either ErrKeyHashFromText KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyRole, ByteString) -> Maybe KeyHash
keyHashFromBytes
 where
    convertBytes :: HumanReadablePart -> ByteString -> Maybe (KeyRole, ByteString)
convertBytes HumanReadablePart
hrp ByteString
bytes
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_shared_vkh Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_shared_vkh Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_vkh Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_vkh Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.policy_vkh Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
28 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Policy, ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_shared_vk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
32 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString -> ByteString
hashCredential ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_vk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
32 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString -> ByteString
hashCredential ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_shared_xvk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
64 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.addr_xvk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
64 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Payment, ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_shared_vk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
32 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString -> ByteString
hashCredential ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_vk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
32 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString -> ByteString
hashCredential ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_shared_xvk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
64 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.stake_xvk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
64 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Delegation, ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.policy_vk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
32 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Policy, ByteString -> ByteString
hashCredential ByteString
bytes)
        | HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
CIP5.policy_xvk Bool -> Bool -> Bool
&& ByteString -> Int -> Bool
checkBSLength ByteString
bytes Int
64 =
              (KeyRole, ByteString) -> Maybe (KeyRole, ByteString)
forall a. a -> Maybe a
Just (KeyRole
Policy, ByteString -> ByteString
hashCredential (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
32 ByteString
bytes)
        | Bool
otherwise = Maybe (KeyRole, ByteString)
forall a. Maybe a
Nothing
    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
showList :: [ValidationLevel] -> ShowS
$cshowList :: [ValidationLevel] -> ShowS
show :: ValidationLevel -> String
$cshow :: ValidationLevel -> String
showsPrec :: Int -> ValidationLevel -> ShowS
$cshowsPrec :: Int -> ValidationLevel -> ShowS
Show, ValidationLevel -> ValidationLevel -> Bool
(ValidationLevel -> ValidationLevel -> Bool)
-> (ValidationLevel -> ValidationLevel -> Bool)
-> Eq ValidationLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationLevel -> ValidationLevel -> Bool
$c/= :: ValidationLevel -> ValidationLevel -> Bool
== :: ValidationLevel -> ValidationLevel -> Bool
$c== :: 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
$cto :: forall x. Rep ValidationLevel x -> ValidationLevel
$cfrom :: forall x. ValidationLevel -> Rep ValidationLevel x
Generic)
instance NFData ValidationLevel

-- Possible errors when deserializing a key hash from text.
--
-- @since 3.0.0
data ErrKeyHashFromText
    = ErrKeyHashFromTextInvalidString
    | ErrKeyHashFromTextWrongPayload
    | ErrKeyHashFromTextWrongHrp
    | ErrKeyHashFromTextWrongDataPart
    | ErrKeyHashFromTextInvalidHex
    deriving (Int -> ErrKeyHashFromText -> ShowS
[ErrKeyHashFromText] -> ShowS
ErrKeyHashFromText -> String
(Int -> ErrKeyHashFromText -> ShowS)
-> (ErrKeyHashFromText -> String)
-> ([ErrKeyHashFromText] -> ShowS)
-> Show ErrKeyHashFromText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrKeyHashFromText] -> ShowS
$cshowList :: [ErrKeyHashFromText] -> ShowS
show :: ErrKeyHashFromText -> String
$cshow :: ErrKeyHashFromText -> String
showsPrec :: Int -> ErrKeyHashFromText -> ShowS
$cshowsPrec :: Int -> ErrKeyHashFromText -> ShowS
Show, ErrKeyHashFromText -> ErrKeyHashFromText -> Bool
(ErrKeyHashFromText -> ErrKeyHashFromText -> Bool)
-> (ErrKeyHashFromText -> ErrKeyHashFromText -> Bool)
-> Eq ErrKeyHashFromText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrKeyHashFromText -> ErrKeyHashFromText -> Bool
$c/= :: ErrKeyHashFromText -> ErrKeyHashFromText -> Bool
== :: ErrKeyHashFromText -> ErrKeyHashFromText -> Bool
$c== :: ErrKeyHashFromText -> ErrKeyHashFromText -> Bool
Eq)

-- Possible errors when deserializing a key hash from text.
--
-- @since 3.0.0
prettyErrKeyHashFromText :: ErrKeyHashFromText -> String
prettyErrKeyHashFromText :: ErrKeyHashFromText -> String
prettyErrKeyHashFromText = \case
    ErrKeyHashFromText
ErrKeyHashFromTextInvalidString ->
        String
"Invalid encoded string: must be either bech32 or hex-encoded."
    ErrKeyHashFromText
ErrKeyHashFromTextWrongPayload ->
        String
"Verification key hash must contain exactly 28 bytes."
    ErrKeyHashFromText
ErrKeyHashFromTextWrongHrp ->
        String
"Invalid human-readable prefix: must be 'X_vkh', 'X_vk', 'X_xvk' where X is 'addr_shared', 'stake_shared' or 'policy'."
    ErrKeyHashFromText
ErrKeyHashFromTextWrongDataPart ->
        String
"Verification key hash is Bech32-encoded but has an invalid data part."
    ErrKeyHashFromText
ErrKeyHashFromTextInvalidHex ->
        String
"Invalid hex-encoded string: must be either 28, 32 or 64 bytes"

--
-- Script folding
--

-- | 'Script' folding
--
-- @since 3.2.0
foldScript :: (a -> b -> b) -> b -> Script a -> b
foldScript :: (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 (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 (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 :: 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 (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Script elem -> Word8) -> [Script elem] -> [Word8]
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 :: Script elem -> Either ErrRecommendedValidateScript ()
recommendedValidation = \case
    RequireSignatureOf elem
_ -> () -> Either ErrRecommendedValidateScript ()
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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

    ActiveUntilSlot Natural
_ -> () -> Either ErrRecommendedValidateScript ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    hasDuplicate :: [Script a] -> Bool
hasDuplicate [Script a]
xs =
        [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 (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 (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 (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
/= :: ErrValidateScript -> ErrValidateScript -> Bool
$c/= :: ErrValidateScript -> ErrValidateScript -> Bool
== :: ErrValidateScript -> ErrValidateScript -> Bool
$c== :: 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
showList :: [ErrValidateScript] -> ShowS
$cshowList :: [ErrValidateScript] -> ShowS
show :: ErrValidateScript -> String
$cshow :: ErrValidateScript -> String
showsPrec :: Int -> ErrValidateScript -> ShowS
$cshowsPrec :: Int -> 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
/= :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
$c/= :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
== :: ErrRecommendedValidateScript
-> ErrRecommendedValidateScript -> Bool
$c== :: 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
showList :: [ErrRecommendedValidateScript] -> ShowS
$cshowList :: [ErrRecommendedValidateScript] -> ShowS
show :: ErrRecommendedValidateScript -> String
$cshow :: ErrRecommendedValidateScript -> String
showsPrec :: Int -> ErrRecommendedValidateScript -> ShowS
$cshowsPrec :: Int -> 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
/= :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
$c/= :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
== :: ErrValidateScriptTemplate -> ErrValidateScriptTemplate -> Bool
$c== :: 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
showList :: [ErrValidateScriptTemplate] -> ShowS
$cshowList :: [ErrValidateScriptTemplate] -> ShowS
show :: ErrValidateScriptTemplate -> String
$cshow :: ErrValidateScriptTemplate -> String
showsPrec :: Int -> ErrValidateScriptTemplate -> ShowS
$cshowsPrec :: Int -> 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: either payment or delegation."
    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' or 'policy' 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 [Text
"all" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Script elem -> Value) -> [Script elem] -> [Value]
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 [Text
"any" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Script elem -> Value) -> [Script elem] -> [Value]
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 [Text
"some" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object [Text
"at_least" Text -> Word8 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Word8
count, Text
"from" Text -> [Script elem] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Script elem]
scripts]]
    toJSON (ActiveFromSlot Natural
slot) =
        [Pair] -> Value
object [Text
"active_from" Text -> Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Natural
slot]
    toJSON (ActiveUntilSlot Natural
slot) =
        [Pair] -> Value
object [Text
"active_until" Text -> Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Natural
slot]

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

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 (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 (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 -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"any"  :: Parser (Maybe Value)
                Maybe Value
mAll  <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"all"  :: Parser (Maybe Value)
                Maybe Value
mSome <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 (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 (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 :: (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 (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 :: 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 -> Text -> Parser [Script elem]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"any"

parseAllOf
    :: FromJSON (Script elem)
    => Value
    -> Parser (Script elem)
parseAllOf :: 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 -> Text -> Parser [Script elem]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"all"

parseAtLeast
    :: FromJSON (Script elem)
    => Value
    -> Parser (Script elem)
parseAtLeast :: 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 -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"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 -> Text -> Parser Word8
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"at_least" Parser ([Script elem] -> Script elem)
-> Parser [Script elem] -> Parser (Script elem)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
some Object -> Text -> Parser [Script elem]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"from"

parseActiveFrom
    :: Value
    -> Parser (Script elem)
parseActiveFrom :: 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 -> Text -> Parser Natural
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"active_from"

parseActiveUntil
    :: Value
    -> Parser (Script elem)
parseActiveUntil :: 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 -> Text -> Parser Natural
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"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 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
< Bounded Word8 => Word8
forall a. Bounded a => a
minBound @Word8 Bool -> Bool -> Bool
|| Word8
num Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Bounded Word8 => Word8
forall a. Bounded a => a
maxBound @Word8) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
                        String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigner number should be between '0' and '255'"
                Cosigner -> Parser Cosigner
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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cosigner should be enumerated with number"
        [Text]
_ -> String -> Parser Cosigner
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 (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 (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 (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 [ Text
"cosigners" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object (((Cosigner, XPub) -> Pair) -> [(Cosigner, XPub)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> Pair -> Pair
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
J.textToKey (Pair -> Pair)
-> ((Cosigner, XPub) -> Pair) -> (Cosigner, XPub) -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosigner, XPub) -> Pair
toPair) (Map Cosigner XPub -> [(Cosigner, XPub)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Cosigner XPub
cosigners'))
               , Text
"template" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Script Cosigner -> Value
forall a. ToJSON a => a -> Value
toJSON Script Cosigner
template']
      where
        toPair :: (Cosigner, XPub) -> Pair
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 <- Value -> Parser Cosigner
forall a. FromJSON a => Value -> Parser a
parseJSON @Cosigner Value
o
            Script Cosigner -> Parser (Script Cosigner)
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 -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"any"  :: Parser (Maybe Value)
                Maybe Value
mAll  <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"all"  :: Parser (Maybe Value)
                Maybe Value
mSome <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"some" :: Parser (Maybe Value)
                Maybe Value
mCos <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 (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 (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 -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"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 -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"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 (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 k v. HashMap k v -> [(k, v)]
JM.toList Object
o of
                [] -> String -> Parser [(Cosigner, XPub)]
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
$ \(Text
numTxt, Value
str) -> do
                    Cosigner
cosigner' <- Value -> Parser Cosigner
forall a. FromJSON a => Value -> Parser a
parseJSON @Cosigner (Text -> Value
String (Text -> Text
J.keyToText Text
numTxt))
                    XPub
xpub <- Value -> Parser XPub
parseXPub Value
str
                    (Cosigner, XPub) -> Parser (Cosigner, XPub)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cosigner
cosigner', XPub
xpub)