{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Singular.Registry.Application
Description : The application a registry pins, as a value
License     : Apache-2.0

A registry pins one application policy at boot (#157 genesis-policy-pins).
This module carries what the registry needs to know of an application
without naming any: a name for receipts and refusals, the executable that
folds its terminations, how the policy is fixed, and the decoder and
holding rules. Each executable composes its value and hands it to the
library.

The pin has four forms: a hash given as input (a registry booted for an
application whose script does not depend on the registry identity), a
blueprint validator title applied to the registry identity (the state
policy then the token name), a blueprint validator title pinned as
compiled (the parameterless form the tests use; production registries
are always identity-scoped), or read from the state datum of a registry
that already exists. 'applyPin' derives the pinned bytes and codes for
the first three; the fourth needs the datum, so only 'resolveRegistry'
passes it after reading the datum, and 'configForApplication' refuses it
by name.

Slice 2: the decoder reads a datum into a holding view (or names why it
cannot); the holding rules find this registry's holding of a key among
the outputs at the application address (refusing a foreign or duplicate
one), release a termination (script, redeemer, recipient and amount), add
the application's part to the fold context, and check a request's carried
datum before an insertion is folded. The neutral value carries none of
them; the application value fills them from the envelope and release.
-}
module Singular.Registry.Application
    ( -- * The pin
      ApplicationPin (..)

      -- * The value
    , Application (..)
    , neutralApplication
    , hashPinnedApplication

      -- * The concrete parts
    , DecodedHolding (..)
    , Decoder (..)
    , HoldingRules (..)

      -- * Generic datum bytes, hashes and JSON (no application named)
    , datumCbor
    , datumHash
    , txOutDatum
    , datumToJson
    , datumFromJson

      -- * Deriving from a pin
    , applyPin
    ) where

import Control.Monad (unless, when)
import Data.Aeson (Value)
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Short qualified as SBS
import Data.List (sort)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE

import Cardano.Crypto.Hash.Class (hashToBytes)
import Cardano.Ledger.Api.Scripts.Data
    ( Datum (..)
    , binaryDataToData
    )
import Cardano.Ledger.Api.Tx.Out (TxOut, datumTxOutL)
import Cardano.Ledger.Hashes (extractHash)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Lens.Micro ((^.))
import PlutusCore.Data qualified as PLC
import PlutusTx.Builtins qualified as Builtins
import PlutusTx.Builtins.Internal
    ( BuiltinByteString (..)
    , BuiltinData (..)
    )

import Singular.Registry.Blueprint (NamingCodes (..), applyBytesParam)
import Singular.Registry.Config (CageConfig)
import Singular.Registry.Ledger (ConwayEra, TokenId, TxIn)
import Singular.Registry.TxBuilder.Internal
    ( computeScriptHash
    , scriptHashBytes
    )
import Singular.Registry.TxBuilder.Update
    ( HolderRelease
    , RegistryContext
    )
import Singular.Registry.Types (OnChainRequest)

-- | How the registry's application policy is fixed.
data ApplicationPin
    = -- | A 28-byte policy hash given as input
      PinByHash SBS.ShortByteString
    | -- | The blueprint validator title, applied to the registry identity
      PinByScript Text
    | {- | The blueprint validator title, pinned as compiled: the
      parameterless form the tests use, never a production registry
      -}
      PinAsCompiled Text
    | -- | Read from the state datum of the registry being attached to
      PinFromState
    deriving stock (ApplicationPin -> ApplicationPin -> Bool
(ApplicationPin -> ApplicationPin -> Bool)
-> (ApplicationPin -> ApplicationPin -> Bool) -> Eq ApplicationPin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplicationPin -> ApplicationPin -> Bool
== :: ApplicationPin -> ApplicationPin -> Bool
$c/= :: ApplicationPin -> ApplicationPin -> Bool
/= :: ApplicationPin -> ApplicationPin -> Bool
Eq, Int -> ApplicationPin -> ShowS
[ApplicationPin] -> ShowS
ApplicationPin -> String
(Int -> ApplicationPin -> ShowS)
-> (ApplicationPin -> String)
-> ([ApplicationPin] -> ShowS)
-> Show ApplicationPin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplicationPin -> ShowS
showsPrec :: Int -> ApplicationPin -> ShowS
$cshow :: ApplicationPin -> String
show :: ApplicationPin -> String
$cshowList :: [ApplicationPin] -> ShowS
showList :: [ApplicationPin] -> ShowS
Show)

{- | What the registry knows of a holding: the datum it carries and what
the application protects in it. The open datum fills this from the
envelope (control + payload); a future application fills it from its own
datum. The library never names either.
-}
data DecodedHolding = DecodedHolding
    { DecodedHolding -> Data
dhDatumData :: PLC.Data
    -- ^ The full datum, as data
    , DecodedHolding -> ByteString
dhDatumCbor :: ByteString
    -- ^ Its CBOR, as the ledger hashes it
    , DecodedHolding -> ByteString
dhDatumHash :: ByteString
    -- ^ Its BLAKE2b-256, as requests and journals name it
    , DecodedHolding -> ByteString
dhKey :: ByteString
    -- ^ The key the holding belongs to
    , DecodedHolding -> Integer
dhDeposit :: Integer
    -- ^ The protected deposit, in lovelace
    , DecodedHolding -> ByteString
dhController :: ByteString
    -- ^ The controller's payment key hash
    , DecodedHolding -> Data
dhPayload :: PLC.Data
    -- ^ The payload the application leaves unread by the registry
    , DecodedHolding -> Value
dhDatumJson :: Value
    -- ^ The datum as detailed-schema JSON (for receipts)
    , DecodedHolding -> Value
dhPayloadJson :: Value
    -- ^ The payload as detailed-schema JSON (for receipts)
    }
    deriving stock (DecodedHolding -> DecodedHolding -> Bool
(DecodedHolding -> DecodedHolding -> Bool)
-> (DecodedHolding -> DecodedHolding -> Bool) -> Eq DecodedHolding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodedHolding -> DecodedHolding -> Bool
== :: DecodedHolding -> DecodedHolding -> Bool
$c/= :: DecodedHolding -> DecodedHolding -> Bool
/= :: DecodedHolding -> DecodedHolding -> Bool
Eq, Int -> DecodedHolding -> ShowS
[DecodedHolding] -> ShowS
DecodedHolding -> String
(Int -> DecodedHolding -> ShowS)
-> (DecodedHolding -> String)
-> ([DecodedHolding] -> ShowS)
-> Show DecodedHolding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodedHolding -> ShowS
showsPrec :: Int -> DecodedHolding -> ShowS
$cshow :: DecodedHolding -> String
show :: DecodedHolding -> String
$cshowList :: [DecodedHolding] -> ShowS
showList :: [DecodedHolding] -> ShowS
Show)

-- | How the application reads a datum: into a holding view, or a named reason.
newtype Decoder = Decoder
    { Decoder -> TxOut ConwayEra -> Either Text DecodedHolding
runDecoder :: TxOut ConwayEra -> Either Text DecodedHolding
    }

instance Show Decoder where
    show :: Decoder -> String
show Decoder
_ = String
"Decoder"

instance Eq Decoder where
    Decoder
_ == :: Decoder -> Decoder -> Bool
== Decoder
_ = Bool
True

{- | How the application holds keys: what the registry needs to fold without
naming the application. Absent on the neutral value; the open datum fills
every field from the envelope and release.
-}
data HoldingRules = HoldingRules
    { HoldingRules -> OnChainRequest -> Either Text Data
hrCheckCarried :: OnChainRequest -> Either Text PLC.Data
    -- ^ The datum an insertion's request must carry to be folded
    , HoldingRules
-> CageConfig
-> TokenId
-> ByteString
-> [(TxIn, TxOut ConwayEra)]
-> [((TxIn, TxOut ConwayEra), DecodedHolding)]
hrFindHoldings
        :: CageConfig
        -> TokenId
        -> ByteString
        -> [(TxIn, TxOut ConwayEra)]
        -> [((TxIn, TxOut ConwayEra), DecodedHolding)]
    {- ^ This registry's holdings of a key among the outputs at the
    application address (a foreign envelope is not one of them)
    -}
    , HoldingRules
-> CageConfig
-> TokenId
-> ByteString
-> [(TxIn, TxOut ConwayEra)]
-> Either Text ((TxIn, TxOut ConwayEra), DecodedHolding)
hrLiveOutputFor
        :: CageConfig
        -> TokenId
        -> ByteString
        -> [(TxIn, TxOut ConwayEra)]
        -> Either Text ((TxIn, TxOut ConwayEra), DecodedHolding)
    -- ^ The key's one live holding, or why there is none (foreign or duplicate)
    , HoldingRules
-> ShortByteString
-> (TxIn, TxOut ConwayEra)
-> Either Text (TxIn, HolderRelease)
hrReleaseOf
        :: SBS.ShortByteString
        -> (TxIn, TxOut ConwayEra)
        -> Either Text (TxIn, HolderRelease)
    -- ^ How the fold spends one live output: script, redeemer, recipient, amount
    , HoldingRules
-> ShortByteString
-> Maybe (TxIn, TxOut ConwayEra)
-> [(TxIn, TxOut ConwayEra)]
-> RegistryContext
-> Either Text RegistryContext
hrWithApplication
        :: SBS.ShortByteString
        -> Maybe (TxIn, TxOut ConwayEra)
        -> [(TxIn, TxOut ConwayEra)]
        -> RegistryContext
        -> Either Text RegistryContext
    -- ^ The fold context with the application's part added
    }

instance Show HoldingRules where
    show :: HoldingRules -> String
show HoldingRules
_ = String
"HoldingRules"

instance Eq HoldingRules where
    HoldingRules
_ == :: HoldingRules -> HoldingRules -> Bool
== HoldingRules
_ = Bool
True

{- | What the registry knows of an application: a name for receipts and
refusals, the executable that folds its terminations, how the policy is
fixed, and the decoder and holding rules. The neutral value carries none
of the last three; a named value carries all of them.
-}
data Application = Application
    { Application -> Maybe Text
appName :: Maybe Text
    -- ^ What receipts and refusals call the application; none is neutral
    , Application -> Maybe Text
appExecutable :: Maybe Text
    -- ^ The binary that folds this application's terminations
    , Application -> ApplicationPin
appPin :: ApplicationPin
    , Application -> Maybe Decoder
appDecoder :: Maybe Decoder
    -- ^ Reads a datum into a holding view; absent on the neutral value
    , Application -> Maybe HoldingRules
appHolding :: Maybe HoldingRules
    -- ^ Finds and releases this registry's holding; absent on neutral
    }
    deriving stock (Application -> Application -> Bool
(Application -> Application -> Bool)
-> (Application -> Application -> Bool) -> Eq Application
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Application -> Application -> Bool
== :: Application -> Application -> Bool
$c/= :: Application -> Application -> Bool
/= :: Application -> Application -> Bool
Eq, Int -> Application -> ShowS
[Application] -> ShowS
Application -> String
(Int -> Application -> ShowS)
-> (Application -> String)
-> ([Application] -> ShowS)
-> Show Application
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Application -> ShowS
showsPrec :: Int -> Application -> ShowS
$cshow :: Application -> String
show :: Application -> String
$cshowList :: [Application] -> ShowS
showList :: [Application] -> ShowS
Show)

{- | The value @singular@ folds with: no name, no executable, no decoder,
no holding rules; the pin is read from the state datum.
-}
neutralApplication :: Application
neutralApplication :: Application
neutralApplication =
    Application
        { appName :: Maybe Text
appName = Maybe Text
forall a. Maybe a
Nothing
        , appExecutable :: Maybe Text
appExecutable = Maybe Text
forall a. Maybe a
Nothing
        , appPin :: ApplicationPin
appPin = ApplicationPin
PinFromState
        , appDecoder :: Maybe Decoder
appDecoder = Maybe Decoder
forall a. Maybe a
Nothing
        , appHolding :: Maybe HoldingRules
appHolding = Maybe HoldingRules
forall a. Maybe a
Nothing
        }

-- | The neutral value with the pin fixed to the given 28-byte policy hash.
hashPinnedApplication :: SBS.ShortByteString -> Application
hashPinnedApplication :: ShortByteString -> Application
hashPinnedApplication ShortByteString
policy =
    Application
neutralApplication{appPin = PinByHash policy}

{- | The pinned policy bytes and the codes as the registry runs them, for
a pin that carries its own derivation. 'PinFromState' needs the state
datum, which this function is never given, so it is refused by name;
'resolveRegistry' reads the datum first and passes its pin as 'PinByHash'.
-}
applyPin
    :: ApplicationPin
    -> ByteString
    -- ^ The registry identity: state policy then state token name
    -> NamingCodes
    -- ^ The application and witness codes as the blueprint carries them
    -> (SBS.ShortByteString, NamingCodes)
applyPin :: ApplicationPin
-> ByteString -> NamingCodes -> (ShortByteString, NamingCodes)
applyPin ApplicationPin
pin ByteString
registryId NamingCodes
codes = case ApplicationPin
pin of
    PinByHash ShortByteString
policy -> (ShortByteString
policy, NamingCodes
codes{ncApplication = SBS.empty})
    PinByScript Text
_title ->
        let applied :: ShortByteString
applied = ByteString -> ShortByteString -> ShortByteString
applyBytesParam ByteString
registryId (NamingCodes -> ShortByteString
ncApplication NamingCodes
codes)
        in  (ShortByteString -> ShortByteString
pinOf ShortByteString
applied, NamingCodes
codes{ncApplication = applied})
    PinAsCompiled Text
_title -> (ShortByteString -> ShortByteString
pinOf (NamingCodes -> ShortByteString
ncApplication NamingCodes
codes), NamingCodes
codes)
    ApplicationPin
PinFromState ->
        String -> (ShortByteString, NamingCodes)
forall a. HasCallStack => String -> a
error
            String
"applyPin: PinFromState reads the pin from the state datum, which this derivation is never given"
  where
    pinOf :: ShortByteString -> ShortByteString
pinOf = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString)
-> (ShortByteString -> ByteString)
-> ShortByteString
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> ByteString
scriptHashBytes (ScriptHash -> ByteString)
-> (ShortByteString -> ScriptHash) -> ShortByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ScriptHash
computeScriptHash

{- | The CBOR of a datum, by the same builtin a script's `serialise_data`
runs. Generic: the library names no application to name it.
-}
datumCbor :: PLC.Data -> ByteString
datumCbor :: Data -> ByteString
datumCbor Data
d = case BuiltinData -> BuiltinByteString
Builtins.serialiseData (Data -> BuiltinData
BuiltinData Data
d) of
    BuiltinByteString ByteString
bytes -> ByteString
bytes

{- | The BLAKE2b-256 of a datum's CBOR: the datum hash a request names.
Generic: the same bytes `envelopeHash` hashes, so an application datum
hash equals its envelope hash byte for byte.
-}
datumHash :: PLC.Data -> ByteString
datumHash :: Data -> ByteString
datumHash Data
d =
    Hash HASH EraIndependentData -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes
        (SafeHash EraIndependentData -> Hash HASH EraIndependentData
forall i. SafeHash i -> Hash HASH i
extractHash (Data ConwayEra -> SafeHash EraIndependentData
forall era. Data era -> SafeHash EraIndependentData
hashData (Data -> Data ConwayEra
forall era. Era era => Data -> Data era
Data Data
d :: Data ConwayEra)))

-- | An output's inline datum, as bytes and hash, when it carries one.
txOutDatum :: TxOut ConwayEra -> Maybe (ByteString, ByteString)
txOutDatum :: TxOut ConwayEra -> Maybe (ByteString, ByteString)
txOutDatum TxOut ConwayEra
out = case TxOut ConwayEra
BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> Getting
     (Datum ConwayEra) (BabbageTxOut ConwayEra) (Datum ConwayEra)
-> Datum ConwayEra
forall s a. s -> Getting a s a -> a
^. (Datum ConwayEra -> Const (Datum ConwayEra) (Datum ConwayEra))
-> TxOut ConwayEra -> Const (Datum ConwayEra) (TxOut ConwayEra)
Getting
  (Datum ConwayEra) (BabbageTxOut ConwayEra) (Datum ConwayEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutL of
    Datum BinaryData ConwayEra
bd ->
        let Data Data
d = BinaryData ConwayEra -> Data ConwayEra
forall era. Era era => BinaryData era -> Data era
binaryDataToData BinaryData ConwayEra
bd
        in  (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (Data -> ByteString
datumCbor Data
d, Data -> ByteString
datumHash Data
d)
    Datum ConwayEra
_ -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing

{- | The detailed-schema JSON of a datum, naming no application.
Byte-identical to the open datum's `dataToJson` on the same datum.
-}
datumToJson :: PLC.Data -> Value
datumToJson :: Data -> Value
datumToJson = \case
    PLC.Constr Integer
tag [Data]
fields ->
        [Pair] -> Value
Aeson.object
            [Key
"constructor" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Integer
tag, Key
"fields" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= (Data -> Value) -> [Data] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Data -> Value
datumToJson [Data]
fields]
    PLC.Map [(Data, Data)]
entries ->
        [Pair] -> Value
Aeson.object
            [ Key
"map"
                Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [ [Pair] -> Value
Aeson.object [Key
"k" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Data -> Value
datumToJson Data
k, Key
"v" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Data -> Value
datumToJson Data
v]
                         | (Data
k, Data
v) <- [(Data, Data)]
entries
                         ]
            ]
    PLC.List [Data]
items -> [Pair] -> Value
Aeson.object [Key
"list" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= (Data -> Value) -> [Data] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Data -> Value
datumToJson [Data]
items]
    PLC.I Integer
n -> [Pair] -> Value
Aeson.object [Key
"int" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Integer
n]
    PLC.B ByteString
bytes -> [Pair] -> Value
Aeson.object [Key
"bytes" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B16.encode ByteString
bytes)]

{- | A datum from its detailed-schema JSON, or where it is wrong.
Byte-identical to the open datum's `dataFromJson` on the same JSON.
-}
datumFromJson :: Value -> Either String PLC.Data
datumFromJson :: Value -> Either String Data
datumFromJson = \case
    Aeson.Object Object
o -> case [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ((Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
o)) of
        [Text
"constructor", Text
"fields"] -> do
            tag <- Text -> Value -> Either String Integer
integer Text
"constructor" (Value -> Either String Integer)
-> Either String Value -> Either String Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"constructor" Object
o
            when (tag < 0) $ Left "a constructor index is never negative"
            fields <- array "fields" =<< field "fields" o
            PLC.Constr tag <$> mapM datumFromJson fields
        [Text
"map"] -> do
            entries <- Text -> Value -> Either String [Value]
array Text
"map" (Value -> Either String [Value])
-> Either String Value -> Either String [Value]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"map" Object
o
            PLC.Map <$> mapM entry entries
        [Text
"list"] -> do
            items <- Text -> Value -> Either String [Value]
array Text
"list" (Value -> Either String [Value])
-> Either String Value -> Either String [Value]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"list" Object
o
            PLC.List <$> mapM datumFromJson items
        [Text
"int"] -> Integer -> Data
PLC.I (Integer -> Data) -> Either String Integer -> Either String Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Value -> Either String Integer
integer Text
"int" (Value -> Either String Integer)
-> Either String Value -> Either String Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"int" Object
o)
        [Text
"bytes"] -> ByteString -> Data
PLC.B (ByteString -> Data)
-> Either String ByteString -> Either String Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either String ByteString
hexBytes (Value -> Either String ByteString)
-> Either String Value -> Either String ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"bytes" Object
o)
        [Text]
keys ->
            String -> Either String Data
forall a b. a -> Either a b
Left
                ( String
"a datum is one of constructor+fields, map, list, int, \
                  \bytes; found keys "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
keys
                )
    Value
_ -> String -> Either String Data
forall a b. a -> Either a b
Left String
"a datum is a JSON object"
  where
    field :: Text -> KeyMap b -> Either String b
field Text
name KeyMap b
o =
        Either String b
-> (b -> Either String b) -> Maybe b -> Either String b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> Either String b
forall a b. a -> Either a b
Left (String
"missing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name))
            b -> Either String b
forall a b. b -> Either a b
Right
            (Key -> KeyMap b -> Maybe b
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
name) KeyMap b
o)
    array :: Text -> Value -> Either String [Value]
array Text
name Value
x = case Value -> Result [Value]
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
x :: Aeson.Result [Value] of
        Aeson.Success [Value]
xs -> [Value] -> Either String [Value]
forall a b. b -> Either a b
Right [Value]
xs
        Aeson.Error String
_ -> String -> Either String [Value]
forall a b. a -> Either a b
Left (Text -> String
T.unpack Text
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not an array")
    integer :: Text -> Value -> Either String Integer
integer Text
name Value
x = case Value
x of
        Aeson.Number Scientific
_ | Aeson.Success Integer
n <- Value -> Result Integer
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
x -> Integer -> Either String Integer
forall a b. b -> Either a b
Right (Integer
n :: Integer)
        Value
_ -> String -> Either String Integer
forall a b. a -> Either a b
Left (Text -> String
T.unpack Text
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not an integer")
    hexBytes :: Value -> Either String ByteString
hexBytes = \case
        Aeson.String Text
t -> case ByteString -> Either String ByteString
B16.decode (Text -> ByteString
TE.encodeUtf8 Text
t) of
            Right ByteString
b -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
b
            Left String
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"bytes is not hex"
        Value
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"bytes is not a string"
    entry :: Value -> Either String (Data, Data)
entry = \case
        Aeson.Object Object
e -> do
            Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
e) [Key] -> [Key] -> Bool
forall a. Eq a => a -> a -> Bool
== [Key
"k", Key
"v"]) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
                String -> Either String ()
forall a b. a -> Either a b
Left String
"a map entry is exactly {\"k\": .., \"v\": ..}"
            k <- Value -> Either String Data
datumFromJson (Value -> Either String Data)
-> Either String Value -> Either String Data
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Either String Value
forall {b}. Text -> KeyMap b -> Either String b
field Text
"k" Object
e
            v <- datumFromJson =<< field "v" e
            pure (k, v)
        Value
_ -> String -> Either String (Data, Data)
forall a b. a -> Either a b
Left String
"a map entry is a JSON object"