{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DMQ.Protocol.SigSubmission.Codec
  ( codecSigSubmission
  , byteLimitsSigSubmission
  , timeLimitsSigSubmission
  , codecSigSubmissionId
  ) where

import Control.Monad (when)
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadTime.SI
import Data.ByteString.Lazy (ByteString)
import Text.Printf

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Codec.CBOR.Read qualified as CBOR

import Network.TypedProtocol.Codec.CBOR

import DMQ.Protocol.SigSubmission.Type
import Ouroboros.Network.Protocol.Limits
import Ouroboros.Network.Protocol.TxSubmission2.Codec qualified as TX


-- | 'SigSubmission' time limits.
--
-- +-----------------------------+---------------+
-- | 'SigSubmission' state       | timeout (s)   |
-- +=============================+===============+
-- | `StInit`                    | `waitForever` |
-- +-----------------------------+---------------+
-- | `StIdle`                    | `waitForever` |
-- +-----------------------------+---------------+
-- | @'StTxIds' 'StBlocking'@    | `waitForever` |
-- +-----------------------------+---------------+
-- | @'StTxIds' 'StNonBlocking'@ | `shortWait`   |
-- +-----------------------------+---------------+
-- | `StTxs`                     | `shortWait`   |
-- +-----------------------------+---------------+
--
timeLimitsSigSubmission :: ProtocolTimeLimits SigSubmission
timeLimitsSigSubmission :: ProtocolTimeLimits SigSubmission
timeLimitsSigSubmission = (forall (st :: SigSubmission).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits SigSubmission
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits StateToken st -> Maybe DiffTime
forall (st :: SigSubmission).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit
  where
    stateToLimit :: forall (st :: SigSubmission).
                    ActiveState st => StateToken st -> Maybe DiffTime
    stateToLimit :: forall (st :: SigSubmission).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit SingTxSubmission st
StateToken st
SingInit                    = Maybe DiffTime
waitForever
    stateToLimit (SingTxIds SingBlockingStyle stBlocking
SingBlocking)    = Maybe DiffTime
waitForever
    stateToLimit (SingTxIds SingBlockingStyle stBlocking
SingNonBlocking) = Maybe DiffTime
shortWait
    stateToLimit SingTxSubmission st
StateToken st
SingTxs                     = Maybe DiffTime
shortWait
    stateToLimit SingTxSubmission st
StateToken st
SingIdle                    = Maybe DiffTime
waitForever
    stateToLimit a :: StateToken st
a@SingTxSubmission st
StateToken st
SingDone                  = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a


-- TODO: these limits needs to be checked with the mithril team
byteLimitsSigSubmission :: forall bytes.
                           (bytes -> Word)
                        -> ProtocolSizeLimits SigSubmission bytes
byteLimitsSigSubmission :: forall bytes.
(bytes -> Word) -> ProtocolSizeLimits SigSubmission bytes
byteLimitsSigSubmission = (forall (st :: SigSubmission).
 ActiveState st =>
 StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits SigSubmission bytes
forall ps bytes.
(forall (st :: ps). ActiveState st => StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits StateToken st -> Word
forall (st :: SigSubmission).
ActiveState st =>
StateToken st -> Word
stateToLimit
  where
    stateToLimit :: forall (st :: SigSubmission).
                    ActiveState st => StateToken st -> Word
    stateToLimit :: forall (st :: SigSubmission).
ActiveState st =>
StateToken st -> Word
stateToLimit SingTxSubmission st
StateToken st
SingInit                    = Word
smallByteLimit
    stateToLimit (SingTxIds SingBlockingStyle stBlocking
SingBlocking)    = Word
smallByteLimit
    stateToLimit (SingTxIds SingBlockingStyle stBlocking
SingNonBlocking) = Word
smallByteLimit
    stateToLimit SingTxSubmission st
StateToken st
SingTxs                     = Word
smallByteLimit
    stateToLimit SingTxSubmission st
StateToken st
SingIdle                    = Word
smallByteLimit
    stateToLimit a :: StateToken st
a@SingTxSubmission st
StateToken st
SingDone                  = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a


-- | 'SigSubmission' protocol codec.
--
codecSigSubmission
  :: forall m.
     MonadST m
  => Codec SigSubmission CBOR.DeserialiseFailure m ByteString
codecSigSubmission :: forall (m :: * -> *).
MonadST m =>
Codec SigSubmission DeserialiseFailure m ByteString
codecSigSubmission =
    (SigId -> Encoding)
-> (forall s. Decoder s SigId)
-> (Sig -> Encoding)
-> (forall s. Decoder s Sig)
-> Codec SigSubmission DeserialiseFailure m ByteString
forall txid tx (m :: * -> *).
MonadST m =>
(txid -> Encoding)
-> (forall s. Decoder s txid)
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> Codec (TxSubmission2 txid tx) DeserialiseFailure m ByteString
TX.codecTxSubmission2 SigId -> Encoding
encodeSigId Decoder s SigId
forall s. Decoder s SigId
decodeSigId
                          Sig -> Encoding
encodeSig   Decoder s Sig
forall s. Decoder s Sig
decodeSig
  where
    encodeSigId :: SigId -> CBOR.Encoding
    encodeSigId :: SigId -> Encoding
encodeSigId SigId { SigHash
getSigId :: SigHash
getSigId :: SigId -> SigHash
getSigId } = ByteString -> Encoding
CBOR.encodeBytes (SigHash -> ByteString
getSigHash SigHash
getSigId)

    decodeSigId :: forall s. CBOR.Decoder s SigId
    decodeSigId :: forall s. Decoder s SigId
decodeSigId = SigHash -> SigId
SigId (SigHash -> SigId)
-> (ByteString -> SigHash) -> ByteString -> SigId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SigHash
SigHash (ByteString -> SigId) -> Decoder s ByteString -> Decoder s SigId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes

    encodeSig :: Sig -> CBOR.Encoding
    encodeSig :: Sig -> Encoding
encodeSig Sig { SigId
sigId :: SigId
sigId :: Sig -> SigId
sigId,
                    SigBody
sigBody :: SigBody
sigBody :: Sig -> SigBody
sigBody,
                    POSIXTime
sigExpiresAt :: POSIXTime
sigExpiresAt :: Sig -> POSIXTime
sigExpiresAt,
                    SigKesSignature
sigKesSignature :: SigKesSignature
sigKesSignature :: Sig -> SigKesSignature
sigKesSignature,
                    SigOpCertificate
sigOpCertificate :: SigOpCertificate
sigOpCertificate :: Sig -> SigOpCertificate
sigOpCertificate
                  }
       = Word -> Encoding
CBOR.encodeListLen Word
5
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SigId -> Encoding
encodeSigId SigId
sigId
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
CBOR.encodeBytes (SigBody -> ByteString
getSigBody SigBody
sigBody)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 (POSIXTime -> Word32
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
sigExpiresAt)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
CBOR.encodeBytes (SigKesSignature -> ByteString
getSigKesSignature SigKesSignature
sigKesSignature)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
CBOR.encodeBytes (SigOpCertificate -> ByteString
getSigOpCertificate SigOpCertificate
sigOpCertificate)

    decodeSig :: forall s. CBOR.Decoder s Sig
    decodeSig :: forall s. Decoder s Sig
decodeSig = do
      a <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
      when (a /= 5) $ fail (printf "codecSigSubmission: unexpected number of parameters %d" a)
      sigId <- decodeSigId
      sigBody <- SigBody <$> CBOR.decodeBytes
      sigExpiresAt <- realToFrac <$> CBOR.decodeWord32
      sigKesSignature <- SigKesSignature <$> CBOR.decodeBytes
      sigOpCertificate <- SigOpCertificate <$> CBOR.decodeBytes
      return Sig {
          sigId,
          sigBody,
          sigExpiresAt,
          sigKesSignature,
          sigOpCertificate
        }


codecSigSubmissionId
  :: Monad m
  => Codec SigSubmission CodecFailure m (AnyMessage SigSubmission)
codecSigSubmissionId :: forall (m :: * -> *).
Monad m =>
Codec SigSubmission CodecFailure m (AnyMessage SigSubmission)
codecSigSubmissionId = Codec SigSubmission CodecFailure m (AnyMessage SigSubmission)
forall txid tx (m :: * -> *).
Monad m =>
Codec
  (TxSubmission2 txid tx)
  CodecFailure
  m
  (AnyMessage (TxSubmission2 txid tx))
TX.codecTxSubmission2Id