{- |
Module      : Singular.Registry.Wire.Request
Description : Edge vocabulary, request datum, and phase classification
License     : Apache-2.0

What a registry request names and when its age allows acting on it: the
seven-admitted-edges row-index edge vocabulary, the request datum with its codec, and the
accept\/retract\/reject phase classification. Reads only
"Singular.Registry.Wire.Primitive"; nothing here is importable by a
caller — the public surface is the "Singular.Registry.Types" facade.
-}
module Singular.Registry.Wire.Request
    ( -- * On-chain domain types
      Edge
    , edgeInsertAbsent
    , edgeInsertActive
    , edgeUpdateActive
    , edgeUpdateTerminal
    , edgeDeleteAbsent
    , edgeDeleteActive
    , edgeWitnessTerminal
    , edgeName
    , OnChainRequest (..)
    , RequestDestination

      -- * Request phase
    , RequestPhase (..)
    , requestPhase
    ) where

import Cardano.Ledger.BaseTypes (SlotNo (..))
import Data.ByteString (ByteString)
import PlutusCore.Data (Data (..))
import PlutusTx.Builtins.Internal
    ( BuiltinByteString (..)
    )
import PlutusTx.IsData.Class
    ( FromData (..)
    , ToData (..)
    , UnsafeFromData (..)
    )
import Singular.Registry.Wire.Primitive
    ( OnChainTokenId (..)
    , bbsFromD
    , bbsToD
    , bsFromD
    , bsToD
    , mkD
    , unD
    )

{- | The seven-admitted-edges row index a request names (#183, Lean @Request.edge@,
Aiken @lib\/edgeInsertAbsent@ … @edgeWitnessTerminal@).

An edge names its own leaf bytes, so no value bytes travel with a
request and an illegal value-byte shape is not expressible:

@
0  insertAbsent     insert 0x00
1  insertActive     insert 0x01
2  updateActive     update 0x00 -> 0x01
3  updateTerminal   update 0x01 -> 0x02
4  deleteAbsent     delete 0x00
5  deleteActive     delete 0x01
6  witnessTerminal  read   0x02
@

It is a plain 'Integer', exactly as it is a plain @Int@ on chain, so a
tag outside @0..6@ can still be encoded and sent — which is what the
cage's @edge-inadmissible@ refusal is there to answer, and what a row
that exercises that refusal needs to be able to build.
-}
type Edge = Integer

edgeInsertAbsent :: Edge
edgeInsertAbsent :: Integer
edgeInsertAbsent = Integer
0

edgeInsertActive :: Edge
edgeInsertActive :: Integer
edgeInsertActive = Integer
1

edgeUpdateActive :: Edge
edgeUpdateActive :: Integer
edgeUpdateActive = Integer
2

edgeUpdateTerminal :: Edge
edgeUpdateTerminal :: Integer
edgeUpdateTerminal = Integer
3

edgeDeleteAbsent :: Edge
edgeDeleteAbsent :: Integer
edgeDeleteAbsent = Integer
4

edgeDeleteActive :: Edge
edgeDeleteActive :: Integer
edgeDeleteActive = Integer
5

edgeWitnessTerminal :: Edge
edgeWitnessTerminal :: Integer
edgeWitnessTerminal = Integer
6

-- | The name of an admitted edge, for diagnostics and receipts.
edgeName :: Edge -> String
edgeName :: Integer -> String
edgeName Integer
e = case Integer
e of
    Integer
0 -> String
"insertAbsent"
    Integer
1 -> String
"insertActive"
    Integer
2 -> String
"updateActive"
    Integer
3 -> String
"updateTerminal"
    Integer
4 -> String
"deleteAbsent"
    Integer
5 -> String
"deleteActive"
    Integer
6 -> String
"witnessTerminal"
    Integer
_ -> String
"edge-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
e

{- | Where a request's minted token goes, and the datum the receiving output
must carry, or none (#419): what the request carries on the chain.
-}
type RequestDestination = (ByteString, Maybe Data)

{- | On-chain request to modify a token's trie.
Matches Aiken @types\/Request@.
-}
data OnChainRequest = OnChainRequest
    { OnChainRequest -> OnChainTokenId
requestToken :: !OnChainTokenId
    -- ^ Token whose trie is being modified
    , OnChainRequest -> BuiltinByteString
requestOwner :: !BuiltinByteString
    -- ^ Payment key hash of the requester (28 bytes)
    , OnChainRequest -> ByteString
requestKey :: !ByteString
    -- ^ Trie key to operate on
    , OnChainRequest -> Integer
requestEdge :: !Edge
    {- ^ The seven-admitted-edges row index this request names (#183). The edge names the
    trie move and its leaf bytes; no value bytes travel here.
    -}
    , OnChainRequest -> Integer
requestDeposit :: !Integer
    {- ^ The deposit (lovelace) the request rides with, over and above
    the tip. Must equal the request output's lovelace less
    @state.tip@ at fold time; the fold returns it to the destination.
    -}
    , OnChainRequest -> Integer
requestSubmittedAt :: !Integer
    -- ^ POSIX time (ms) when the request was submitted
    , OnChainRequest -> RequestDestination
requestDestination :: !RequestDestination
    {- ^ Where this request's minted token goes, and the inline datum the
    receiving output must carry, or none for a datum-less output (#157
    request-destination-binding, appended last; #419: the request carries
    the datum itself, so any party can build the fold from the chain).
    Encoded as a two-element list, exactly as Aiken encodes a tuple, the
    datum as Aiken's @Option@. For edge 0 the address component is the
    refund address.
    -}
    }
    deriving stock (Int -> OnChainRequest -> String -> String
[OnChainRequest] -> String -> String
OnChainRequest -> String
(Int -> OnChainRequest -> String -> String)
-> (OnChainRequest -> String)
-> ([OnChainRequest] -> String -> String)
-> Show OnChainRequest
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> OnChainRequest -> String -> String
showsPrec :: Int -> OnChainRequest -> String -> String
$cshow :: OnChainRequest -> String
show :: OnChainRequest -> String
$cshowList :: [OnChainRequest] -> String -> String
showList :: [OnChainRequest] -> String -> String
Show, OnChainRequest -> OnChainRequest -> Bool
(OnChainRequest -> OnChainRequest -> Bool)
-> (OnChainRequest -> OnChainRequest -> Bool) -> Eq OnChainRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OnChainRequest -> OnChainRequest -> Bool
== :: OnChainRequest -> OnChainRequest -> Bool
$c/= :: OnChainRequest -> OnChainRequest -> Bool
/= :: OnChainRequest -> OnChainRequest -> Bool
Eq)

-- ---------------------------------------------------------
-- Request phase (A-002): a resuming client's choice of exit
-- ---------------------------------------------------------

{- | The exit a resuming client chooses for one of its pending requests at
a chain tip.

It follows the windows of @onchain/validators/shared.ak@: an update is
folded only while the tip is before @submitted_at + process_time@ (phase
1), and the owner may retract only before @submitted_at + process_time +
retract_time@ (phase 2). After both the client rejects (phase 3). This is
the client's choice, not the validator's rule for a reject: a reject
carries no admission and is accepted in every window (#320).
-}
data RequestPhase = PhaseAccept | PhaseRetract | PhaseReject
    deriving stock (Int -> RequestPhase -> String -> String
[RequestPhase] -> String -> String
RequestPhase -> String
(Int -> RequestPhase -> String -> String)
-> (RequestPhase -> String)
-> ([RequestPhase] -> String -> String)
-> Show RequestPhase
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RequestPhase -> String -> String
showsPrec :: Int -> RequestPhase -> String -> String
$cshow :: RequestPhase -> String
show :: RequestPhase -> String
$cshowList :: [RequestPhase] -> String -> String
showList :: [RequestPhase] -> String -> String
Show, RequestPhase -> RequestPhase -> Bool
(RequestPhase -> RequestPhase -> Bool)
-> (RequestPhase -> RequestPhase -> Bool) -> Eq RequestPhase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestPhase -> RequestPhase -> Bool
== :: RequestPhase -> RequestPhase -> Bool
$c/= :: RequestPhase -> RequestPhase -> Bool
/= :: RequestPhase -> RequestPhase -> Bool
Eq)

{- | Classify a request from its two boundary slots and the live tip.

The boundaries are the slots the builders can express: the accept
fold's validity upper bound is the process deadline slot, the retract's
is the retract deadline slot. The comparison is strict, so a phase is
chosen only while the tip is inside what that phase's builder can
still build — a window already behind the tip never classifies into
the phase that would build it.
-}
requestPhase
    :: SlotNo
    -- ^ Last slot an accept fold can carry (process deadline).
    -> SlotNo
    -- ^ Last slot a retract can carry (retract deadline).
    -> SlotNo
    -- ^ The live tip.
    -> RequestPhase
requestPhase :: SlotNo -> SlotNo -> SlotNo -> RequestPhase
requestPhase SlotNo
acceptDeadline SlotNo
retractDeadline SlotNo
tip
    | SlotNo
tip SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
acceptDeadline = RequestPhase
PhaseAccept
    | SlotNo
tip SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
retractDeadline = RequestPhase
PhaseRetract
    | Bool
otherwise = RequestPhase
PhaseReject

-- ---------------------------------------------------------
-- ToData / FromData instances
-- ---------------------------------------------------------

instance ToData OnChainRequest where
    toBuiltinData :: OnChainRequest -> BuiltinData
toBuiltinData OnChainRequest{Integer
RequestDestination
ByteString
BuiltinByteString
OnChainTokenId
requestToken :: OnChainRequest -> OnChainTokenId
requestOwner :: OnChainRequest -> BuiltinByteString
requestKey :: OnChainRequest -> ByteString
requestEdge :: OnChainRequest -> Integer
requestDeposit :: OnChainRequest -> Integer
requestSubmittedAt :: OnChainRequest -> Integer
requestDestination :: OnChainRequest -> RequestDestination
requestToken :: OnChainTokenId
requestOwner :: BuiltinByteString
requestKey :: ByteString
requestEdge :: Integer
requestDeposit :: Integer
requestSubmittedAt :: Integer
requestDestination :: RequestDestination
..} =
        Data -> BuiltinData
mkD (Data -> BuiltinData) -> Data -> BuiltinData
forall a b. (a -> b) -> a -> b
$
            Integer -> [Data] -> Data
Constr
                Integer
0
                [ BuiltinData -> Data
unD (OnChainTokenId -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData OnChainTokenId
requestToken)
                , BuiltinByteString -> Data
bbsToD BuiltinByteString
requestOwner
                , ByteString -> Data
bsToD ByteString
requestKey
                , Integer -> Data
I Integer
requestEdge
                , Integer -> Data
I Integer
requestDeposit
                , Integer -> Data
I Integer
requestSubmittedAt
                , [Data] -> Data
List
                    [ ByteString -> Data
bsToD (RequestDestination -> ByteString
forall a b. (a, b) -> a
fst RequestDestination
requestDestination)
                    , Data -> (Data -> Data) -> Maybe Data -> Data
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Integer -> [Data] -> Data
Constr Integer
1 []) (Integer -> [Data] -> Data
Constr Integer
0 ([Data] -> Data) -> (Data -> [Data]) -> Data -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> [Data]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (RequestDestination -> Maybe Data
forall a b. (a, b) -> b
snd RequestDestination
requestDestination)
                    ]
                ]

instance FromData OnChainRequest where
    fromBuiltinData :: BuiltinData -> Maybe OnChainRequest
fromBuiltinData BuiltinData
bd = case BuiltinData -> Data
unD BuiltinData
bd of
        Constr
            Integer
0
            [Data
tok, Data
own, Data
k, I Integer
edge, I Integer
dep, I Integer
sub, List [Data
da, Data
dd]] -> do
                requestToken <-
                    BuiltinData -> Maybe OnChainTokenId
forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData (Data -> BuiltinData
mkD Data
tok)
                requestOwner <- bbsFromD own
                requestKey <- bsFromD k
                destAddress <- bsFromD da
                destDatum <- carriedDatum dd
                let requestEdge = Integer
edge
                    requestDeposit = Integer
dep
                    requestSubmittedAt = Integer
sub
                    requestDestination = (ByteString
destAddress, Maybe Data
destDatum)
                Just OnChainRequest{..}
        Data
_ -> Maybe OnChainRequest
forall a. Maybe a
Nothing

instance UnsafeFromData OnChainRequest where
    unsafeFromBuiltinData :: BuiltinData -> OnChainRequest
unsafeFromBuiltinData BuiltinData
bd = case BuiltinData -> Data
unD BuiltinData
bd of
        Constr
            Integer
0
            [Data
tok, B ByteString
own, B ByteString
k, I Integer
edge, I Integer
dep, I Integer
sub, List [B ByteString
da, Data
dd]]
                | Just Maybe Data
datum <- Data -> Maybe (Maybe Data)
carriedDatum Data
dd ->
                    OnChainRequest
                        { requestToken :: OnChainTokenId
requestToken =
                            BuiltinData -> OnChainTokenId
forall a. UnsafeFromData a => BuiltinData -> a
unsafeFromBuiltinData (Data -> BuiltinData
mkD Data
tok)
                        , requestOwner :: BuiltinByteString
requestOwner =
                            ByteString -> BuiltinByteString
BuiltinByteString ByteString
own
                        , requestKey :: ByteString
requestKey = ByteString
k
                        , requestEdge :: Integer
requestEdge = Integer
edge
                        , requestDeposit :: Integer
requestDeposit = Integer
dep
                        , requestSubmittedAt :: Integer
requestSubmittedAt = Integer
sub
                        , requestDestination :: RequestDestination
requestDestination = (ByteString
da, Maybe Data
datum)
                        }
        Data
_ ->
            String -> OnChainRequest
forall a. HasCallStack => String -> a
error
                String
"unsafeFromBuiltinData:\
                \ OnChainRequest"

-- | The datum a request carries, decoded from Aiken's @Option<Data>@.
carriedDatum :: Data -> Maybe (Maybe Data)
carriedDatum :: Data -> Maybe (Maybe Data)
carriedDatum Data
option = case Data
option of
    Constr Integer
0 [Data
datum] -> Maybe Data -> Maybe (Maybe Data)
forall a. a -> Maybe a
Just (Data -> Maybe Data
forall a. a -> Maybe a
Just Data
datum)
    Constr Integer
1 [] -> Maybe Data -> Maybe (Maybe Data)
forall a. a -> Maybe a
Just Maybe Data
forall a. Maybe a
Nothing
    Data
_ -> Maybe (Maybe Data)
forall a. Maybe a
Nothing