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