{-# LANGUAGE DerivingStrategies #-}

{- | The four-field naming datum codec, transcribed exactly from the
accepted epic-15 contract's @simulator/naming-wire.mjs@ (v0.2.0, commit
@13231f58833b8feb57f4b0f9b1117bfcfba0c07d@, asset sha256
@acbabdf54a271251bd73bf9d84ab2c901107045a7dd77d28a391f22cdd53b0e5@).

The datum has exactly four fields, in this order: 'controlAddress';
'paymentDestination' as an option (@constr(0,[])@ none,
@constr(1,[bytes])@ some); the 'nextControlCommitment' 32-byte digest;
and the 'retirementQuorum'. There is no fifth field and none may be
added. Where this module and the reference disagree, the reference is
right and this module is wrong.
-}
module Naming.Datum
    ( PaymentDestination (..)
    , RetirementQuorum (..)
    , NamingDatum (..)
    , DatumAttachment (..)
    , DatumShape (..)
    , encodeNamingDatum
    , decodeNamingDatum
    , namingDatumShape
    , serialiseNamingDatum
    , deserialiseNamingDatum
    , extractNamingDatum
    ) where

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.List (nub)

import Naming.Wire
    ( Address (..)
    , PaymentCredential (..)
    , WireData (..)
    , canonicalAddress
    , decodeAddress
    , deserialiseWireData
    , guardWire
    , serialiseWireData
    )

{- | The payment destination option: none is @constr(0,[])@, some is
@constr(1,[bytes])@.
-}
data PaymentDestination
    = NoDestination
    | SomeDestination Address
    deriving stock (PaymentDestination -> PaymentDestination -> Bool
(PaymentDestination -> PaymentDestination -> Bool)
-> (PaymentDestination -> PaymentDestination -> Bool)
-> Eq PaymentDestination
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PaymentDestination -> PaymentDestination -> Bool
== :: PaymentDestination -> PaymentDestination -> Bool
$c/= :: PaymentDestination -> PaymentDestination -> Bool
/= :: PaymentDestination -> PaymentDestination -> Bool
Eq, Int -> PaymentDestination -> ShowS
[PaymentDestination] -> ShowS
PaymentDestination -> String
(Int -> PaymentDestination -> ShowS)
-> (PaymentDestination -> String)
-> ([PaymentDestination] -> ShowS)
-> Show PaymentDestination
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PaymentDestination -> ShowS
showsPrec :: Int -> PaymentDestination -> ShowS
$cshow :: PaymentDestination -> String
show :: PaymentDestination -> String
$cshowList :: [PaymentDestination] -> ShowS
showList :: [PaymentDestination] -> ShowS
Show)

{- | The retirement quorum: distinct 28-byte member key hashes and a
threshold between 1 and the member count.
-}
data RetirementQuorum = RetirementQuorum
    { RetirementQuorum -> [ByteString]
quorumMembers :: [ByteString]
    , RetirementQuorum -> Integer
quorumThreshold :: Integer
    }
    deriving stock (RetirementQuorum -> RetirementQuorum -> Bool
(RetirementQuorum -> RetirementQuorum -> Bool)
-> (RetirementQuorum -> RetirementQuorum -> Bool)
-> Eq RetirementQuorum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RetirementQuorum -> RetirementQuorum -> Bool
== :: RetirementQuorum -> RetirementQuorum -> Bool
$c/= :: RetirementQuorum -> RetirementQuorum -> Bool
/= :: RetirementQuorum -> RetirementQuorum -> Bool
Eq, Int -> RetirementQuorum -> ShowS
[RetirementQuorum] -> ShowS
RetirementQuorum -> String
(Int -> RetirementQuorum -> ShowS)
-> (RetirementQuorum -> String)
-> ([RetirementQuorum] -> ShowS)
-> Show RetirementQuorum
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetirementQuorum -> ShowS
showsPrec :: Int -> RetirementQuorum -> ShowS
$cshow :: RetirementQuorum -> String
show :: RetirementQuorum -> String
$cshowList :: [RetirementQuorum] -> ShowS
showList :: [RetirementQuorum] -> ShowS
Show)

{- | The four-field naming datum. The field names are the contract's
own; the datum has no fifth field.
-}
data NamingDatum = NamingDatum
    { NamingDatum -> Address
controlAddress :: Address
    , NamingDatum -> PaymentDestination
paymentDestination :: PaymentDestination
    , NamingDatum -> ByteString
nextControlCommitment :: ByteString
    , NamingDatum -> RetirementQuorum
retirementQuorum :: RetirementQuorum
    }
    deriving stock (NamingDatum -> NamingDatum -> Bool
(NamingDatum -> NamingDatum -> Bool)
-> (NamingDatum -> NamingDatum -> Bool) -> Eq NamingDatum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NamingDatum -> NamingDatum -> Bool
== :: NamingDatum -> NamingDatum -> Bool
$c/= :: NamingDatum -> NamingDatum -> Bool
/= :: NamingDatum -> NamingDatum -> Bool
Eq, Int -> NamingDatum -> ShowS
[NamingDatum] -> ShowS
NamingDatum -> String
(Int -> NamingDatum -> ShowS)
-> (NamingDatum -> String)
-> ([NamingDatum] -> ShowS)
-> Show NamingDatum
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamingDatum -> ShowS
showsPrec :: Int -> NamingDatum -> ShowS
$cshow :: NamingDatum -> String
show :: NamingDatum -> String
$cshowList :: [NamingDatum] -> ShowS
showList :: [NamingDatum] -> ShowS
Show)

{- | How a datum is attached to an output: inline, or as a hash. The
contract accepts only inline.
-}
data DatumAttachment
    = InlineDatum WireData
    | AttachedDatumHash ByteString
    deriving stock (DatumAttachment -> DatumAttachment -> Bool
(DatumAttachment -> DatumAttachment -> Bool)
-> (DatumAttachment -> DatumAttachment -> Bool)
-> Eq DatumAttachment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatumAttachment -> DatumAttachment -> Bool
== :: DatumAttachment -> DatumAttachment -> Bool
$c/= :: DatumAttachment -> DatumAttachment -> Bool
/= :: DatumAttachment -> DatumAttachment -> Bool
Eq, Int -> DatumAttachment -> ShowS
[DatumAttachment] -> ShowS
DatumAttachment -> String
(Int -> DatumAttachment -> ShowS)
-> (DatumAttachment -> String)
-> ([DatumAttachment] -> ShowS)
-> Show DatumAttachment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatumAttachment -> ShowS
showsPrec :: Int -> DatumAttachment -> ShowS
$cshow :: DatumAttachment -> String
show :: DatumAttachment -> String
$cshowList :: [DatumAttachment] -> ShowS
showList :: [DatumAttachment] -> ShowS
Show)

{- | The structural shape the contract records for the canonical datum:
@{arity: 4, innerIndex: 0, outerIndex: 0}@.
-}
data DatumShape = DatumShape
    { DatumShape -> Int
shapeArity :: Int
    , DatumShape -> Int
shapeInnerIndex :: Int
    , DatumShape -> Int
shapeOuterIndex :: Int
    }
    deriving stock (DatumShape -> DatumShape -> Bool
(DatumShape -> DatumShape -> Bool)
-> (DatumShape -> DatumShape -> Bool) -> Eq DatumShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatumShape -> DatumShape -> Bool
== :: DatumShape -> DatumShape -> Bool
$c/= :: DatumShape -> DatumShape -> Bool
/= :: DatumShape -> DatumShape -> Bool
Eq, Int -> DatumShape -> ShowS
[DatumShape] -> ShowS
DatumShape -> String
(Int -> DatumShape -> ShowS)
-> (DatumShape -> String)
-> ([DatumShape] -> ShowS)
-> Show DatumShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatumShape -> ShowS
showsPrec :: Int -> DatumShape -> ShowS
$cshow :: DatumShape -> String
show :: DatumShape -> String
$cshowList :: [DatumShape] -> ShowS
showList :: [DatumShape] -> ShowS
Show)

-- | Exact mirror of the contract's @encodeNamingDatum@.
encodeNamingDatum :: NamingDatum -> WireData
encodeNamingDatum :: NamingDatum -> WireData
encodeNamingDatum NamingDatum
fixture =
    Int -> [WireData] -> WireData
Constr
        Int
0
        [ Int -> [WireData] -> WireData
Constr
            Int
0
            [ ByteString -> WireData
WBytes (Address -> ByteString
addressBytes (NamingDatum -> Address
controlAddress NamingDatum
fixture))
            , PaymentDestination -> WireData
encodePaymentDestination (NamingDatum -> PaymentDestination
paymentDestination NamingDatum
fixture)
            , ByteString -> WireData
WBytes (NamingDatum -> ByteString
nextControlCommitment NamingDatum
fixture)
            , RetirementQuorum -> WireData
encodeRetirementQuorum (NamingDatum -> RetirementQuorum
retirementQuorum NamingDatum
fixture)
            ]
        ]

-- | Exact mirror of the contract's @encodePaymentDestination@.
encodePaymentDestination :: PaymentDestination -> WireData
encodePaymentDestination :: PaymentDestination -> WireData
encodePaymentDestination PaymentDestination
NoDestination = Int -> [WireData] -> WireData
Constr Int
0 []
encodePaymentDestination (SomeDestination Address
a) = Int -> [WireData] -> WireData
Constr Int
1 [ByteString -> WireData
WBytes (Address -> ByteString
addressBytes Address
a)]

-- | Exact mirror of the contract's @encodeRetirementQuorum@.
encodeRetirementQuorum :: RetirementQuorum -> WireData
encodeRetirementQuorum :: RetirementQuorum -> WireData
encodeRetirementQuorum RetirementQuorum
q =
    Int -> [WireData] -> WireData
Constr
        Int
0
        [Integer -> WireData
WInt (RetirementQuorum -> Integer
quorumThreshold RetirementQuorum
q), [WireData] -> WireData
WList ((ByteString -> WireData) -> [ByteString] -> [WireData]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> WireData
WBytes (RetirementQuorum -> [ByteString]
quorumMembers RetirementQuorum
q))]

{- | Exact mirror of the contract's @decodeNamingDatum@: outer
@constr(0)@ of arity 1 wrapping an inner @constr(0)@ of arity 4, then
each field decoded and the whole checked with the contract's
@wellFormedFixture@. Anything else is refused.
-}
decodeNamingDatum :: WireData -> Maybe NamingDatum
decodeNamingDatum :: WireData -> Maybe NamingDatum
decodeNamingDatum (Constr Int
0 [WireData
inner]) = WireData -> Maybe NamingDatum
decodeInner WireData
inner
decodeNamingDatum WireData
_ = Maybe NamingDatum
forall a. Maybe a
Nothing

decodeInner :: WireData -> Maybe NamingDatum
decodeInner :: WireData -> Maybe NamingDatum
decodeInner (Constr Int
0 [WireData
controlData, WireData
destinationData, WireData
commitmentData, WireData
quorumData]) = do
    controlBytes <- WireData -> Maybe ByteString
asBytes WireData
controlData
    commitment <- asBytes commitmentData
    guardWire (BS.length commitment == 32)
    control <- decodeAddress controlBytes
    destination <- decodePaymentDestination destinationData
    quorum <- decodeRetirementQuorum quorumData
    let fixture =
            NamingDatum
                { controlAddress :: Address
controlAddress = Address
control
                , paymentDestination :: PaymentDestination
paymentDestination = PaymentDestination
destination
                , nextControlCommitment :: ByteString
nextControlCommitment = ByteString
commitment
                , retirementQuorum :: RetirementQuorum
retirementQuorum = RetirementQuorum
quorum
                }
    guardWire (wellFormedFixture fixture)
    pure fixture
decodeInner WireData
_ = Maybe NamingDatum
forall a. Maybe a
Nothing

asBytes :: WireData -> Maybe ByteString
asBytes :: WireData -> Maybe ByteString
asBytes (WBytes ByteString
b) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
b
asBytes WireData
_ = Maybe ByteString
forall a. Maybe a
Nothing

{- | Exact mirror of the contract's @decodePaymentDestination@: only
@constr(0,[])@ and @constr(1,[bytes])@ with a decodable address are
accepted.
-}
decodePaymentDestination :: WireData -> Maybe PaymentDestination
decodePaymentDestination :: WireData -> Maybe PaymentDestination
decodePaymentDestination (Constr Int
0 []) = PaymentDestination -> Maybe PaymentDestination
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PaymentDestination
NoDestination
decodePaymentDestination (Constr Int
1 [WBytes ByteString
destinationBytes]) =
    Address -> PaymentDestination
SomeDestination (Address -> PaymentDestination)
-> Maybe Address -> Maybe PaymentDestination
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe Address
decodeAddress ByteString
destinationBytes
decodePaymentDestination WireData
_ = Maybe PaymentDestination
forall a. Maybe a
Nothing

{- | Exact mirror of the contract's @decodeRetirementQuorum@:
@constr(0,[integer, list])@, non-negative threshold, every member a
28-byte key hash.
-}
decodeRetirementQuorum :: WireData -> Maybe RetirementQuorum
decodeRetirementQuorum :: WireData -> Maybe RetirementQuorum
decodeRetirementQuorum (Constr Int
0 [WInt Integer
threshold, WList [WireData]
memberData])
    | Integer
threshold Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = do
        members <- (WireData -> Maybe ByteString) -> [WireData] -> Maybe [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse WireData -> Maybe ByteString
asQuorumMember [WireData]
memberData
        pure
            (RetirementQuorum{quorumMembers = members, quorumThreshold = threshold})
decodeRetirementQuorum WireData
_ = Maybe RetirementQuorum
forall a. Maybe a
Nothing

asQuorumMember :: WireData -> Maybe ByteString
asQuorumMember :: WireData -> Maybe ByteString
asQuorumMember (WBytes ByteString
m)
    | ByteString -> Int
BS.length ByteString
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
28 = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
m
asQuorumMember WireData
_ = Maybe ByteString
forall a. Maybe a
Nothing

{- | Exact mirror of the contract's @wellFormedFixture@ (its
@fixtureShape@ plus the destination/control difference): the control
address is a canonical payment-key address, the payment destination is
canonical and never equal to the control address, the commitment is 32
bytes, and the threshold is between 1 and the number of distinct
members.
-}
wellFormedFixture :: NamingDatum -> Bool
wellFormedFixture :: NamingDatum -> Bool
wellFormedFixture NamingDatum
f =
    Address -> Bool
canonicalAddress (NamingDatum -> Address
controlAddress NamingDatum
f)
        Bool -> Bool -> Bool
&& Address -> PaymentCredential
addressPaymentCredential (NamingDatum -> Address
controlAddress NamingDatum
f) PaymentCredential -> PaymentCredential -> Bool
forall a. Eq a => a -> a -> Bool
== PaymentCredential
PaymentKey
        Bool -> Bool -> Bool
&& Bool
destinationCanonical
        Bool -> Bool -> Bool
&& ByteString -> Int
BS.length (NamingDatum -> ByteString
nextControlCommitment NamingDatum
f) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32
        Bool -> Bool -> Bool
&& RetirementQuorum -> Integer
quorumThreshold RetirementQuorum
q Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
        Bool -> Bool -> Bool
&& RetirementQuorum -> Integer
quorumThreshold RetirementQuorum
q Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a]
nub (RetirementQuorum -> [ByteString]
quorumMembers RetirementQuorum
q)))
        Bool -> Bool -> Bool
&& NamingDatum -> PaymentDestination
paymentDestination NamingDatum
f PaymentDestination -> PaymentDestination -> Bool
forall a. Eq a => a -> a -> Bool
/= Address -> PaymentDestination
SomeDestination (NamingDatum -> Address
controlAddress NamingDatum
f)
  where
    q :: RetirementQuorum
q = NamingDatum -> RetirementQuorum
retirementQuorum NamingDatum
f
    destinationCanonical :: Bool
destinationCanonical = case NamingDatum -> PaymentDestination
paymentDestination NamingDatum
f of
        PaymentDestination
NoDestination -> Bool
True
        SomeDestination Address
a -> Address -> Bool
canonicalAddress Address
a

-- | Exact mirror of the contract's @namingDatumShape@.
namingDatumShape :: WireData -> Maybe DatumShape
namingDatumShape :: WireData -> Maybe DatumShape
namingDatumShape (Constr Int
0 [Constr Int
0 [WireData]
fields]) =
    DatumShape -> Maybe DatumShape
forall a. a -> Maybe a
Just
        DatumShape
            { shapeArity :: Int
shapeArity = [WireData] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WireData]
fields
            , shapeInnerIndex :: Int
shapeInnerIndex = Int
0
            , shapeOuterIndex :: Int
shapeOuterIndex = Int
0
            }
namingDatumShape WireData
_ = Maybe DatumShape
forall a. Maybe a
Nothing

-- | Exact mirror of the contract's @serialiseNamingDatum@.
serialiseNamingDatum :: NamingDatum -> Maybe ByteString
serialiseNamingDatum :: NamingDatum -> Maybe ByteString
serialiseNamingDatum = WireData -> Maybe ByteString
serialiseWireData (WireData -> Maybe ByteString)
-> (NamingDatum -> WireData) -> NamingDatum -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamingDatum -> WireData
encodeNamingDatum

-- | Exact mirror of the contract's @deserialiseNamingDatum@.
deserialiseNamingDatum :: ByteString -> Maybe NamingDatum
deserialiseNamingDatum :: ByteString -> Maybe NamingDatum
deserialiseNamingDatum ByteString
input = do
    datum <- ByteString -> Maybe WireData
deserialiseWireData ByteString
input
    decodeNamingDatum datum

{- | Exact mirror of the contract's @extractNamingDatum@: only an inline
datum is decoded; an attached datum hash is refused.
-}
extractNamingDatum :: DatumAttachment -> Maybe NamingDatum
extractNamingDatum :: DatumAttachment -> Maybe NamingDatum
extractNamingDatum (InlineDatum WireData
d) = WireData -> Maybe NamingDatum
decodeNamingDatum WireData
d
extractNamingDatum (AttachedDatumHash ByteString
_) = Maybe NamingDatum
forall a. Maybe a
Nothing