{-# LANGUAGE DerivingStrategies #-}

{- | The insert-request commitment codec and the refund comparison for
the initial request, transcribed exactly from the accepted epic-15
contract's @simulator/naming-wire.mjs@, @core.mjs@ and
@lifecycle-corpus.json@ vector @WR01-insert-request-refund-roundtrip@
(v0.2.0, commit @13231f58833b8feb57f4b0f9b1117bfcfba0c07d@, asset
sha256 @acbabdf54a271251bd73bf9d84ab2c901107045a7dd77d28a391f22cdd53b0e5@).

The commitment is @constr(0,[constr(0,[registry, key,
applicationPolicy, refundAddress, initial output, scope])])@ — six
proposal fields, no seventh. Every @constr@ index here is 0 and every
number a non-negative integer, exactly as the reference decoders
require. Where this module and the reference disagree, the reference
is right and this module is wrong.
-}
module Naming.Request
    ( Representative (..)
    , InitialOutput (..)
    , InsertProposal (..)
    , InsertRequestShape (..)
    , RefundReason (..)
    , RefundComparison (..)
    , withdrawRefundAddress
    , encodeInsertCommitment
    , decodeInsertCommitment
    , insertRequestShape
    , serialiseInsertCommitment
    , deserialiseInsertCommitment
    , matchingInsertCommitment
    , compareRefund
    ) where

import Data.ByteString (ByteString)

import Naming.Wire
    ( WireData (..)
    , deserialiseWireData
    , guardWire
    , serialiseWireData
    )

-- | The representative asset identity inside the initial output.
data Representative = Representative
    { Representative -> Integer
representativeRegistry :: Integer
    , Representative -> Integer
representativeKey :: Integer
    , Representative -> Integer
representativePolicy :: Integer
    , Representative -> Integer
representativeAssetScope :: Integer
    }
    deriving stock (Representative -> Representative -> Bool
(Representative -> Representative -> Bool)
-> (Representative -> Representative -> Bool) -> Eq Representative
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Representative -> Representative -> Bool
== :: Representative -> Representative -> Bool
$c/= :: Representative -> Representative -> Bool
/= :: Representative -> Representative -> Bool
Eq, Int -> Representative -> ShowS
[Representative] -> ShowS
Representative -> String
(Int -> Representative -> ShowS)
-> (Representative -> String)
-> ([Representative] -> ShowS)
-> Show Representative
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Representative -> ShowS
showsPrec :: Int -> Representative -> ShowS
$cshow :: Representative -> String
show :: Representative -> String
$cshowList :: [Representative] -> ShowS
showList :: [Representative] -> ShowS
Show)

-- | The initial output of a proposal.
data InitialOutput = InitialOutput
    { InitialOutput -> Representative
initialRepresentative :: Representative
    , InitialOutput -> Integer
initialQuantity :: Integer
    , InitialOutput -> Integer
initialDestination :: Integer
    , InitialOutput -> Integer
initialDatum :: Integer
    , InitialOutput -> Integer
initialValue :: Integer
    }
    deriving stock (InitialOutput -> InitialOutput -> Bool
(InitialOutput -> InitialOutput -> Bool)
-> (InitialOutput -> InitialOutput -> Bool) -> Eq InitialOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitialOutput -> InitialOutput -> Bool
== :: InitialOutput -> InitialOutput -> Bool
$c/= :: InitialOutput -> InitialOutput -> Bool
/= :: InitialOutput -> InitialOutput -> Bool
Eq, Int -> InitialOutput -> ShowS
[InitialOutput] -> ShowS
InitialOutput -> String
(Int -> InitialOutput -> ShowS)
-> (InitialOutput -> String)
-> ([InitialOutput] -> ShowS)
-> Show InitialOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialOutput -> ShowS
showsPrec :: Int -> InitialOutput -> ShowS
$cshow :: InitialOutput -> String
show :: InitialOutput -> String
$cshowList :: [InitialOutput] -> ShowS
showList :: [InitialOutput] -> ShowS
Show)

-- | The insert proposal carried in the request commitment.
data InsertProposal = InsertProposal
    { InsertProposal -> Integer
registry :: Integer
    , InsertProposal -> Integer
key :: Integer
    , InsertProposal -> Integer
applicationPolicy :: Integer
    , InsertProposal -> Integer
refundAddress :: Integer
    , InsertProposal -> InitialOutput
initial :: InitialOutput
    , InsertProposal -> [Integer]
scope :: [Integer]
    }
    deriving stock (InsertProposal -> InsertProposal -> Bool
(InsertProposal -> InsertProposal -> Bool)
-> (InsertProposal -> InsertProposal -> Bool) -> Eq InsertProposal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InsertProposal -> InsertProposal -> Bool
== :: InsertProposal -> InsertProposal -> Bool
$c/= :: InsertProposal -> InsertProposal -> Bool
/= :: InsertProposal -> InsertProposal -> Bool
Eq, Int -> InsertProposal -> ShowS
[InsertProposal] -> ShowS
InsertProposal -> String
(Int -> InsertProposal -> ShowS)
-> (InsertProposal -> String)
-> ([InsertProposal] -> ShowS)
-> Show InsertProposal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InsertProposal -> ShowS
showsPrec :: Int -> InsertProposal -> ShowS
$cshow :: InsertProposal -> String
show :: InsertProposal -> String
$cshowList :: [InsertProposal] -> ShowS
showList :: [InsertProposal] -> ShowS
Show)

{- | The structural shape the vector records for the request commitment:
@{commitmentIndex: 0, commitmentArity: 1, proposalIndex: 0,
proposalArity: 6}@.
-}
data InsertRequestShape = InsertRequestShape
    { InsertRequestShape -> Int
commitmentIndex :: Int
    , InsertRequestShape -> Int
commitmentArity :: Int
    , InsertRequestShape -> Int
proposalIndex :: Int
    , InsertRequestShape -> Int
proposalArity :: Int
    }
    deriving stock (InsertRequestShape -> InsertRequestShape -> Bool
(InsertRequestShape -> InsertRequestShape -> Bool)
-> (InsertRequestShape -> InsertRequestShape -> Bool)
-> Eq InsertRequestShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InsertRequestShape -> InsertRequestShape -> Bool
== :: InsertRequestShape -> InsertRequestShape -> Bool
$c/= :: InsertRequestShape -> InsertRequestShape -> Bool
/= :: InsertRequestShape -> InsertRequestShape -> Bool
Eq, Int -> InsertRequestShape -> ShowS
[InsertRequestShape] -> ShowS
InsertRequestShape -> String
(Int -> InsertRequestShape -> ShowS)
-> (InsertRequestShape -> String)
-> ([InsertRequestShape] -> ShowS)
-> Show InsertRequestShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InsertRequestShape -> ShowS
showsPrec :: Int -> InsertRequestShape -> ShowS
$cshow :: InsertRequestShape -> String
show :: InsertRequestShape -> String
$cshowList :: [InsertRequestShape] -> ShowS
showList :: [InsertRequestShape] -> ShowS
Show)

-- | Refusal reason, recorded in the vector's @comparisonResult@.
newtype RefundReason = RefundReason {RefundReason -> String
refundReasonText :: String}
    deriving stock (RefundReason -> RefundReason -> Bool
(RefundReason -> RefundReason -> Bool)
-> (RefundReason -> RefundReason -> Bool) -> Eq RefundReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefundReason -> RefundReason -> Bool
== :: RefundReason -> RefundReason -> Bool
$c/= :: RefundReason -> RefundReason -> Bool
/= :: RefundReason -> RefundReason -> Bool
Eq, Int -> RefundReason -> ShowS
[RefundReason] -> ShowS
RefundReason -> String
(Int -> RefundReason -> ShowS)
-> (RefundReason -> String)
-> ([RefundReason] -> ShowS)
-> Show RefundReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefundReason -> ShowS
showsPrec :: Int -> RefundReason -> ShowS
$cshow :: RefundReason -> String
show :: RefundReason -> String
$cshowList :: [RefundReason] -> ShowS
showList :: [RefundReason] -> ShowS
Show)

-- | Outcome of comparing a presented refund against the stored one.
data RefundComparison
    = RefundAccepted
    | RefundRefused RefundReason
    deriving stock (RefundComparison -> RefundComparison -> Bool
(RefundComparison -> RefundComparison -> Bool)
-> (RefundComparison -> RefundComparison -> Bool)
-> Eq RefundComparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefundComparison -> RefundComparison -> Bool
== :: RefundComparison -> RefundComparison -> Bool
$c/= :: RefundComparison -> RefundComparison -> Bool
/= :: RefundComparison -> RefundComparison -> Bool
Eq, Int -> RefundComparison -> ShowS
[RefundComparison] -> ShowS
RefundComparison -> String
(Int -> RefundComparison -> ShowS)
-> (RefundComparison -> String)
-> ([RefundComparison] -> ShowS)
-> Show RefundComparison
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefundComparison -> ShowS
showsPrec :: Int -> RefundComparison -> ShowS
$cshow :: RefundComparison -> String
show :: RefundComparison -> String
$cshowList :: [RefundComparison] -> ShowS
showList :: [RefundComparison] -> ShowS
Show)

{- | The reason the contract records when a withdrawal presents a refund
address other than the stored one.
-}
withdrawRefundAddress :: RefundReason
withdrawRefundAddress :: RefundReason
withdrawRefundAddress = String -> RefundReason
RefundReason String
"withdraw-refund-address"

{- | Exact mirror of the contract's @encodeProposal@ wrapped in its
single-field @constr(0)@ commitment constructor.
-}
encodeInsertCommitment :: InsertProposal -> WireData
encodeInsertCommitment :: InsertProposal -> WireData
encodeInsertCommitment InsertProposal
p =
    Int -> [WireData] -> WireData
Constr
        Int
0
        [ Int -> [WireData] -> WireData
Constr
            Int
0
            [ Integer -> WireData
WInt (InsertProposal -> Integer
registry InsertProposal
p)
            , Integer -> WireData
WInt (InsertProposal -> Integer
key InsertProposal
p)
            , Integer -> WireData
WInt (InsertProposal -> Integer
applicationPolicy InsertProposal
p)
            , Integer -> WireData
WInt (InsertProposal -> Integer
refundAddress InsertProposal
p)
            , InitialOutput -> WireData
encodeOutput (InsertProposal -> InitialOutput
initial InsertProposal
p)
            , [WireData] -> WireData
WList ((Integer -> WireData) -> [Integer] -> [WireData]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> WireData
WInt (InsertProposal -> [Integer]
scope InsertProposal
p))
            ]
        ]

encodeOutput :: InitialOutput -> WireData
encodeOutput :: InitialOutput -> WireData
encodeOutput InitialOutput
o =
    Int -> [WireData] -> WireData
Constr
        Int
0
        [ Representative -> WireData
encodeRepresentative (InitialOutput -> Representative
initialRepresentative InitialOutput
o)
        , Integer -> WireData
WInt (InitialOutput -> Integer
initialQuantity InitialOutput
o)
        , Integer -> WireData
WInt (InitialOutput -> Integer
initialDestination InitialOutput
o)
        , Integer -> WireData
WInt (InitialOutput -> Integer
initialDatum InitialOutput
o)
        , Integer -> WireData
WInt (InitialOutput -> Integer
initialValue InitialOutput
o)
        ]

encodeRepresentative :: Representative -> WireData
encodeRepresentative :: Representative -> WireData
encodeRepresentative Representative
r =
    Int -> [WireData] -> WireData
Constr
        Int
0
        [ Integer -> WireData
WInt (Representative -> Integer
representativeRegistry Representative
r)
        , Integer -> WireData
WInt (Representative -> Integer
representativeKey Representative
r)
        , Integer -> WireData
WInt (Representative -> Integer
representativePolicy Representative
r)
        , Integer -> WireData
WInt (Representative -> Integer
representativeAssetScope Representative
r)
        ]

{- | Exact mirror of the contract's @decodeInsertCommitment@ composed
with @decodeProposal@: @constr(0,[proposal])@.
-}
decodeInsertCommitment :: WireData -> Maybe InsertProposal
decodeInsertCommitment :: WireData -> Maybe InsertProposal
decodeInsertCommitment (Constr Int
0 [WireData
proposal]) = WireData -> Maybe InsertProposal
decodeProposal WireData
proposal
decodeInsertCommitment WireData
_ = Maybe InsertProposal
forall a. Maybe a
Nothing

decodeProposal :: WireData -> Maybe InsertProposal
decodeProposal :: WireData -> Maybe InsertProposal
decodeProposal
    ( Constr
            Int
0
            [ WireData
regData
                , WireData
keyData
                , WireData
policyData
                , WireData
refundData
                , WireData
outputData
                , WList [WireData]
scopeData
                ]
        ) = do
        reg <- WireData -> Maybe Integer
asNat WireData
regData
        k <- asNat keyData
        policy <- asNat policyData
        refund <- asNat refundData
        output <- decodeOutput outputData
        scope <- traverse asNat scopeData
        pure
            InsertProposal
                { registry = reg
                , key = k
                , applicationPolicy = policy
                , refundAddress = refund
                , initial = output
                , scope = scope
                }
decodeProposal WireData
_ = Maybe InsertProposal
forall a. Maybe a
Nothing

decodeOutput :: WireData -> Maybe InitialOutput
decodeOutput :: WireData -> Maybe InitialOutput
decodeOutput
    ( Constr
            Int
0
            [WireData
repData, WInt Integer
quantity, WInt Integer
destination, WInt Integer
datum, WInt Integer
value]
        ) = do
        rep <- WireData -> Maybe Representative
decodeRepresentative WireData
repData
        q <- asNat (WInt quantity)
        d <- asNat (WInt destination)
        m <- asNat (WInt datum)
        v <- asNat (WInt value)
        pure
            InitialOutput
                { initialRepresentative = rep
                , initialQuantity = q
                , initialDestination = d
                , initialDatum = m
                , initialValue = v
                }
decodeOutput WireData
_ = Maybe InitialOutput
forall a. Maybe a
Nothing

decodeRepresentative :: WireData -> Maybe Representative
decodeRepresentative :: WireData -> Maybe Representative
decodeRepresentative (Constr Int
0 [WireData
regData, WireData
keyData, WireData
policyData, WireData
scopeData]) = do
    reg <- WireData -> Maybe Integer
asNat WireData
regData
    k <- asNat keyData
    policy <- asNat policyData
    assetScope <- asNat scopeData
    pure
        Representative
            { representativeRegistry = reg
            , representativeKey = k
            , representativePolicy = policy
            , representativeAssetScope = assetScope
            }
decodeRepresentative WireData
_ = Maybe Representative
forall a. Maybe a
Nothing

{- | The contract's @decodeNat@: an integer wire value that is a
non-negative safe integer. Wire integers here never exceed 65535, so
the safe-integer bound is not reachable; the non-negativity is.
-}
asNat :: WireData -> Maybe Integer
asNat :: WireData -> Maybe Integer
asNat (WInt Integer
v)
    | Integer
v Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v
asNat WireData
_ = Maybe Integer
forall a. Maybe a
Nothing

-- | Exact mirror of the contract's @insertRequestShape@.
insertRequestShape :: WireData -> Maybe InsertRequestShape
insertRequestShape :: WireData -> Maybe InsertRequestShape
insertRequestShape (Constr Int
ci [Constr Int
pj [WireData]
fields]) =
    InsertRequestShape -> Maybe InsertRequestShape
forall a. a -> Maybe a
Just
        InsertRequestShape
            { commitmentIndex :: Int
commitmentIndex = Int
ci
            , commitmentArity :: Int
commitmentArity = Int
1
            , proposalIndex :: Int
proposalIndex = Int
pj
            , proposalArity :: Int
proposalArity = [WireData] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WireData]
fields
            }
insertRequestShape WireData
_ = Maybe InsertRequestShape
forall a. Maybe a
Nothing

{- | Exact mirror of the contract's @serialiseInsertRequest@ at the
commitment level.
-}
serialiseInsertCommitment :: InsertProposal -> Maybe ByteString
serialiseInsertCommitment :: InsertProposal -> Maybe ByteString
serialiseInsertCommitment = WireData -> Maybe ByteString
serialiseWireData (WireData -> Maybe ByteString)
-> (InsertProposal -> WireData)
-> InsertProposal
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsertProposal -> WireData
encodeInsertCommitment

-- | Exact mirror of the contract's @deserialiseInsertCommitment@.
deserialiseInsertCommitment :: ByteString -> Maybe InsertProposal
deserialiseInsertCommitment :: ByteString -> Maybe InsertProposal
deserialiseInsertCommitment ByteString
input = do
    datum <- ByteString -> Maybe WireData
deserialiseWireData ByteString
input
    decodeInsertCommitment datum

{- | Exact mirror of the contract's @decodeInsertRequestCommitment@: the
bytes decode to a proposal only if that proposal equals the expected
one — a redirected refund decodes fine but never matches the request.
-}
matchingInsertCommitment
    :: InsertProposal -> ByteString -> Maybe InsertProposal
matchingInsertCommitment :: InsertProposal -> ByteString -> Maybe InsertProposal
matchingInsertCommitment InsertProposal
expected ByteString
input = do
    proposal <- ByteString -> Maybe InsertProposal
deserialiseInsertCommitment ByteString
input
    guardWire (proposal == expected)
    pure proposal

{- | The contract's withdraw-step refund check
(@core.mjs@: @if (d.refund.destination !==
pending.proposal.refundAddress) fail('withdraw-refund-address')@),
which vector @WR01@ records as @comparisonResult@.
-}
compareRefund :: Integer -> Integer -> RefundComparison
compareRefund :: Integer -> Integer -> RefundComparison
compareRefund Integer
stored Integer
presented
    | Integer
presented Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
stored = RefundReason -> RefundComparison
RefundRefused RefundReason
withdrawRefundAddress
    | Bool
otherwise = RefundComparison
RefundAccepted