{- | Capabilities retained by a command or runner. Reads use the explicit
network and generic provider; submission accepts only signed bytes; clocks
and bounded confirmation belong to the caller's effect composition.

IO confirmation runs on the command's calling thread. Its implementation
must be interruptible, including transport waits and resource cleanup, and
must propagate asynchronous exceptions rather than convert them into a
provider verdict. Blocking uninterruptibly delays both deadlines and caller
cancellation until that block is released; there is no detached worker to
continue confirmation after the command.
-}
module Singular.Registry.Capabilities (Capabilities (..), sessionReceipt) where

import Cardano.Tx.Ledger (ConwayTx)
import Data.Aeson (Value (..), object, toJSON, (.=))
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Base16 qualified as B16
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Singular.Registry.Evidence
    ( SessionBinding (..)
    , SessionId (..)
    )
import Singular.Registry.LedgerProvider
    ( LedgerProvider
    , Network (..)
    , Session (..)
    , SubmitResult
    )
import Singular.Registry.SessionEvidence (FactRecord (..))
import Singular.Registry.Signing (SignedTx)

data Capabilities w m = Capabilities
    { forall w (m :: * -> *).
Capabilities w m -> (Network, LedgerProvider w m)
capReads :: (Network, LedgerProvider w m)
    {- ^ The provider, undecorated: each scope that reads wraps it with its own
    tracer ('Singular.Registry.ProviderTrace.tracedLedgerProvider')
    -}
    , forall w (m :: * -> *).
Capabilities w m -> SignedTx -> m SubmitResult
capSubmit :: SignedTx -> m SubmitResult
    , forall w (m :: * -> *). Capabilities w m -> ConwayTx -> m ()
capConfirm :: ConwayTx -> m ()
    {- ^ Confirm exactly this signed transaction without resubmitting it.
    For IO callers this action and its cleanup must be interruptible: a
    command runs it on its calling thread under its confirmation deadline.
    Provider failures, wait failures and caller cancellation retain their
    distinct identities. An uninterruptible replacement delays command
    return until it releases; it does not gain a background worker.
    -}
    , forall w (m :: * -> *). Capabilities w m -> m [FactRecord]
capFacts :: m [FactRecord]
    , forall w (m :: * -> *). Capabilities w m -> m [Value]
capTrace :: m [Value]
    }

{- | Only the actual scope's facts and source exchanges; later confirmation
and prior funding scopes cannot enter this body's evidence.
-}
sessionReceipt
    :: (Monad m) => Capabilities w m -> Session w n -> m Value
sessionReceipt :: forall (m :: * -> *) w (n :: * -> *).
Monad m =>
Capabilities w m -> Session w n -> m Value
sessionReceipt Capabilities w m
capabilities Session w n
session = do
    facts <- Capabilities w m -> m [FactRecord]
forall w (m :: * -> *). Capabilities w m -> m [FactRecord]
capFacts Capabilities w m
capabilities
    trace <- capTrace capabilities
    let identity@(SessionId label) = sessionId session
        Network magic = sessionNetwork session
        sameScope (Object Object
fields) = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"session" Object
fields Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
label)
        sameScope Value
_ = Bool
False
        binding = case Session w n -> SessionBinding
forall w (m :: * -> *). Session w m -> SessionBinding
sessionBinding Session w n
session of
            SessionBinding
Unbound -> [Pair] -> Value
object [Key
"kind" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Unbound" :: Text)]
            Bound Integer
slot ByteString
header ->
                [Pair] -> Value
object
                    [ Key
"kind" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Bound" :: Text)
                    , Key
"slot" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Integer
slot
                    , Key
"headerHash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (ByteString -> ByteString
B16.encode ByteString
header)
                    ]
    pure $
        object
            [ "session" .= label
            , "networkMagic" .= magic
            , "binding" .= binding
            , "facts" .= toJSON (filter ((== identity) . factSession) facts)
            , "rawSources" .= filter sameScope trace
            ]