{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}

-- | The codec for the local message notification miniprotocol
--
module DMQ.Protocol.LocalMsgNotification.Codec
  ( codecLocalMsgNotification
  , codecLocalMsgNotification'
  ) where

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Codec.CBOR.Read qualified as CBOR
import Control.Monad.Class.MonadST
import Data.Bool (bool)
import Data.ByteString.Lazy (ByteString)
import Data.List.NonEmpty qualified as NonEmpty
import Text.Printf

import Cardano.KESAgent.KES.Crypto (Crypto (..))

import Ouroboros.Network.Protocol.Codec.Utils qualified as Utils

import DMQ.Protocol.LocalMsgNotification.Type
import DMQ.Protocol.SigSubmission.Codec qualified as SigSubmission
import DMQ.Protocol.SigSubmission.Type (Sig (..), SigRawWithSignedBytes (..))
import Network.TypedProtocol.Codec.CBOR


-- | The codec for the loca message notification miniprotocol instantiated for dmq-node.
--
codecLocalMsgNotification
  :: forall crypto m.
     ( MonadST m
     , Crypto crypto
     )
  => AnnotatedCodec (LocalMsgNotification (Sig crypto)) CBOR.DeserialiseFailure m ByteString
codecLocalMsgNotification :: forall crypto (m :: * -> *).
(MonadST m, Crypto crypto) =>
AnnotatedCodec
  (LocalMsgNotification (Sig crypto)) DeserialiseFailure m ByteString
codecLocalMsgNotification =
    (ByteString
 -> WithByteSpan (ByteString -> SigRawWithSignedBytes crypto)
 -> Sig crypto)
-> (Sig crypto -> Encoding)
-> (forall s.
    Decoder s (ByteString -> SigRawWithSignedBytes crypto))
-> AnnotatedCodec
     (LocalMsgNotification (Sig crypto)) DeserialiseFailure m ByteString
forall msg msgWithBytes (m :: * -> *).
MonadST m =>
(ByteString -> WithByteSpan (ByteString -> msgWithBytes) -> msg)
-> (msg -> Encoding)
-> (forall s. Decoder s (ByteString -> msgWithBytes))
-> AnnotatedCodec
     (LocalMsgNotification msg) DeserialiseFailure m ByteString
codecLocalMsgNotification' ByteString
-> WithByteSpan (ByteString -> SigRawWithSignedBytes crypto)
-> Sig crypto
mkSigWithBytes Sig crypto -> Encoding
forall crypto. Sig crypto -> Encoding
SigSubmission.encodeSig Decoder s (ByteString -> SigRawWithSignedBytes crypto)
forall s. Decoder s (ByteString -> SigRawWithSignedBytes crypto)
forall crypto s.
Crypto crypto =>
Decoder s (ByteString -> SigRawWithSignedBytes crypto)
SigSubmission.decodeSig
  where
    mkSigWithBytes
      :: ByteString
      -> Utils.WithByteSpan (ByteString -> SigRawWithSignedBytes crypto)
      -> Sig crypto
    mkSigWithBytes :: ByteString
-> WithByteSpan (ByteString -> SigRawWithSignedBytes crypto)
-> Sig crypto
mkSigWithBytes ByteString
bytes (Utils.WithByteSpan (ByteString -> SigRawWithSignedBytes crypto
f, ByteOffset
start, ByteOffset
end)) =
      SigWithBytes {
        sigRawBytes :: ByteString
sigRawBytes = ByteOffset -> ByteOffset -> ByteString -> ByteString
Utils.bytesBetweenOffsets ByteOffset
start ByteOffset
end ByteString
bytes,
        sigRawWithSignedBytes :: SigRawWithSignedBytes crypto
sigRawWithSignedBytes = ByteString -> SigRawWithSignedBytes crypto
f ByteString
bytes
      }


-- | A polymorphic annotated codec for the local message notification
-- miniprotocol.  Useful for testing.
--
codecLocalMsgNotification'
  :: forall msg msgWithBytes m.
     MonadST m
  => (ByteString -> Utils.WithByteSpan (ByteString -> msgWithBytes) -> msg)
  -> (msg -> CBOR.Encoding)
  -> (forall s. CBOR.Decoder s (ByteString -> msgWithBytes))
  -> AnnotatedCodec (LocalMsgNotification msg) CBOR.DeserialiseFailure m ByteString
codecLocalMsgNotification' :: forall msg msgWithBytes (m :: * -> *).
MonadST m =>
(ByteString -> WithByteSpan (ByteString -> msgWithBytes) -> msg)
-> (msg -> Encoding)
-> (forall s. Decoder s (ByteString -> msgWithBytes))
-> AnnotatedCodec
     (LocalMsgNotification msg) DeserialiseFailure m ByteString
codecLocalMsgNotification' ByteString -> WithByteSpan (ByteString -> msgWithBytes) -> msg
mkWithBytes msg -> Encoding
encodeMsg forall s. Decoder s (ByteString -> msgWithBytes)
decodeMsgWithBytes =
    (forall (st :: LocalMsgNotification msg)
        (st' :: LocalMsgNotification msg).
 (StateTokenI st, ActiveState st) =>
 Message (LocalMsgNotification msg) st st' -> Encoding)
-> (forall (st :: LocalMsgNotification msg) s.
    ActiveState st =>
    StateToken st -> Decoder s (Annotator ByteString st))
-> CodecF
     (LocalMsgNotification msg)
     DeserialiseFailure
     m
     (Annotator ByteString)
     ByteString
forall ps (m :: * -> *) (f :: ps -> *).
MonadST m =>
(forall (st :: ps) (st' :: ps).
 (StateTokenI st, ActiveState st) =>
 Message ps st st' -> Encoding)
-> (forall (st :: ps) s.
    ActiveState st =>
    StateToken st -> Decoder s (f st))
-> CodecF ps DeserialiseFailure m f ByteString
mkCodecCborLazyBS
      Message (LocalMsgNotification msg) st st' -> Encoding
forall (st :: LocalMsgNotification msg)
       (st' :: LocalMsgNotification msg).
Message (LocalMsgNotification msg) st st' -> Encoding
forall (st :: LocalMsgNotification msg)
       (st' :: LocalMsgNotification msg).
(StateTokenI st, ActiveState st) =>
Message (LocalMsgNotification msg) st st' -> Encoding
encode
      StateToken st -> Decoder s (Annotator ByteString st)
StateToken st -> forall s. Decoder s (Annotator ByteString st)
forall (st :: LocalMsgNotification msg).
ActiveState st =>
StateToken st -> forall s. Decoder s (Annotator ByteString st)
forall (st :: LocalMsgNotification msg) s.
ActiveState st =>
StateToken st -> Decoder s (Annotator ByteString st)
decode
  where
    encode :: forall st st'.
              Message (LocalMsgNotification msg) st st'
           -> CBOR.Encoding
    encode :: forall (st :: LocalMsgNotification msg)
       (st' :: LocalMsgNotification msg).
Message (LocalMsgNotification msg) st st' -> Encoding
encode (MsgRequest SingBlockingStyle blocking
blocking) =
        Word -> Encoding
CBOR.encodeListLen Word
2
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
CBOR.encodeBool (case SingBlockingStyle blocking
blocking of
                           SingBlockingStyle blocking
SingBlocking    -> Bool
True
                           SingBlockingStyle blocking
SingNonBlocking -> Bool
False)

    encode (MsgReply msgs :: BlockingReplyList blocking msg
msgs@NonBlockingReply{} HasMore
hasMore) =
        Word -> Encoding
CBOR.encodeListLen Word
3
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeListLenIndef
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (msg -> Encoding) -> BlockingReplyList blocking msg -> Encoding
forall m a.
Monoid m =>
(a -> m) -> BlockingReplyList blocking a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap msg -> Encoding
encodeMsg BlockingReplyList blocking msg
msgs
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeBreak
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
CBOR.encodeBool Bool
hasMore'
     where
       hasMore' :: Bool
hasMore' = case HasMore
hasMore of
                    HasMore
HasMore         -> Bool
True
                    HasMore
DoesNotHaveMore -> Bool
False

    encode (MsgReply msgs :: BlockingReplyList blocking msg
msgs@BlockingReply{} HasMore
hasMore) =
        Word -> Encoding
CBOR.encodeListLen Word
3
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeListLenIndef
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (msg -> Encoding) -> BlockingReplyList blocking msg -> Encoding
forall m a.
Monoid m =>
(a -> m) -> BlockingReplyList blocking a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap msg -> Encoding
encodeMsg BlockingReplyList blocking msg
msgs
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeBreak
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
CBOR.encodeBool Bool
hasMore'
     where
       hasMore' :: Bool
hasMore' = case HasMore
hasMore of
                    HasMore
HasMore         -> Bool
True
                    HasMore
DoesNotHaveMore -> Bool
False

    encode Message (LocalMsgNotification msg) st st'
R:MessageLocalMsgNotificationfromto msg st st'
MsgClientDone =
        Word -> Encoding
CBOR.encodeListLen Word
1
     Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
3


    decode :: forall (st :: LocalMsgNotification msg).
              ActiveState st
           => StateToken st
           -> forall s. CBOR.Decoder s (Annotator ByteString st)
    decode :: forall (st :: LocalMsgNotification msg).
ActiveState st =>
StateToken st -> forall s. Decoder s (Annotator ByteString st)
decode StateToken st
stok = do
      len <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
      key <- CBOR.decodeWord
      case (stok, len, key) of

        (SingMsgNotification st
SingIdle, Int
2, Word
0) -> do
          blocking <- Decoder s Bool
forall s. Decoder s Bool
CBOR.decodeBool
          return $! if blocking
                      then Annotator \ByteString
_ -> Message (LocalMsgNotification msg) st (StBusy 'StBlocking)
-> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (SingBlockingStyle 'StBlocking
-> Message (LocalMsgNotification msg) StIdle (StBusy 'StBlocking)
forall (blocking :: StBlockingStyle) msg.
SingI blocking =>
SingBlockingStyle blocking
-> Message (LocalMsgNotification msg) StIdle (StBusy blocking)
MsgRequest SingBlockingStyle 'StBlocking
SingBlocking)
                      else Annotator \ByteString
_ -> Message (LocalMsgNotification msg) st (StBusy 'StNonBlocking)
-> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (SingBlockingStyle 'StNonBlocking
-> Message
     (LocalMsgNotification msg) StIdle (StBusy 'StNonBlocking)
forall (blocking :: StBlockingStyle) msg.
SingI blocking =>
SingBlockingStyle blocking
-> Message (LocalMsgNotification msg) StIdle (StBusy blocking)
MsgRequest SingBlockingStyle 'StNonBlocking
SingNonBlocking)

        (SingBusy SingBlockingStyle blocking
SingNonBlocking, Int
3, Word
1) -> do
          Decoder s ()
forall s. Decoder s ()
CBOR.decodeListLenIndef
          msgs <- ([WithByteSpan (ByteString -> msgWithBytes)]
 -> WithByteSpan (ByteString -> msgWithBytes)
 -> [WithByteSpan (ByteString -> msgWithBytes)])
-> [WithByteSpan (ByteString -> msgWithBytes)]
-> ([WithByteSpan (ByteString -> msgWithBytes)]
    -> [WithByteSpan (ByteString -> msgWithBytes)])
-> Decoder s (WithByteSpan (ByteString -> msgWithBytes))
-> Decoder s [WithByteSpan (ByteString -> msgWithBytes)]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
CBOR.decodeSequenceLenIndef
                    ((WithByteSpan (ByteString -> msgWithBytes)
 -> [WithByteSpan (ByteString -> msgWithBytes)]
 -> [WithByteSpan (ByteString -> msgWithBytes)])
-> [WithByteSpan (ByteString -> msgWithBytes)]
-> WithByteSpan (ByteString -> msgWithBytes)
-> [WithByteSpan (ByteString -> msgWithBytes)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [WithByteSpan (ByteString -> msgWithBytes)]
-> [WithByteSpan (ByteString -> msgWithBytes)]
forall a. [a] -> [a]
reverse
                    (Decoder s (ByteString -> msgWithBytes)
-> Decoder s (WithByteSpan (ByteString -> msgWithBytes))
forall s a. Decoder s a -> Decoder s (WithByteSpan a)
Utils.decodeWithByteSpan Decoder s (ByteString -> msgWithBytes)
forall s. Decoder s (ByteString -> msgWithBytes)
decodeMsgWithBytes)
          more <- bool DoesNotHaveMore HasMore <$> CBOR.decodeBool
          return (Annotator \ByteString
bytes -> Message (LocalMsgNotification msg) st StIdle -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (LocalMsgNotification msg) st StIdle -> SomeMessage st)
-> Message (LocalMsgNotification msg) st StIdle -> SomeMessage st
forall a b. (a -> b) -> a -> b
$ BlockingReplyList 'StNonBlocking msg
-> HasMore
-> Message
     (LocalMsgNotification msg) (StBusy 'StNonBlocking) StIdle
forall (blocking :: StBlockingStyle) msg.
BlockingReplyList blocking msg
-> HasMore
-> Message (LocalMsgNotification msg) (StBusy blocking) StIdle
MsgReply ([msg] -> BlockingReplyList 'StNonBlocking msg
forall a. [a] -> BlockingReplyList 'StNonBlocking a
NonBlockingReply ([msg] -> BlockingReplyList 'StNonBlocking msg)
-> [msg] -> BlockingReplyList 'StNonBlocking msg
forall a b. (a -> b) -> a -> b
$ ByteString -> WithByteSpan (ByteString -> msgWithBytes) -> msg
mkWithBytes ByteString
bytes (WithByteSpan (ByteString -> msgWithBytes) -> msg)
-> [WithByteSpan (ByteString -> msgWithBytes)] -> [msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WithByteSpan (ByteString -> msgWithBytes)]
msgs) HasMore
more)

        (SingBusy SingBlockingStyle blocking
SingBlocking, Int
3, Word
2) -> do
          Decoder s ()
forall s. Decoder s ()
CBOR.decodeListLenIndef
          msgs <- ([WithByteSpan (ByteString -> msgWithBytes)]
 -> WithByteSpan (ByteString -> msgWithBytes)
 -> [WithByteSpan (ByteString -> msgWithBytes)])
-> [WithByteSpan (ByteString -> msgWithBytes)]
-> ([WithByteSpan (ByteString -> msgWithBytes)]
    -> [WithByteSpan (ByteString -> msgWithBytes)])
-> Decoder s (WithByteSpan (ByteString -> msgWithBytes))
-> Decoder s [WithByteSpan (ByteString -> msgWithBytes)]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
CBOR.decodeSequenceLenIndef
                    ((WithByteSpan (ByteString -> msgWithBytes)
 -> [WithByteSpan (ByteString -> msgWithBytes)]
 -> [WithByteSpan (ByteString -> msgWithBytes)])
-> [WithByteSpan (ByteString -> msgWithBytes)]
-> WithByteSpan (ByteString -> msgWithBytes)
-> [WithByteSpan (ByteString -> msgWithBytes)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [WithByteSpan (ByteString -> msgWithBytes)]
-> [WithByteSpan (ByteString -> msgWithBytes)]
forall a. [a] -> [a]
reverse
                    (Decoder s (ByteString -> msgWithBytes)
-> Decoder s (WithByteSpan (ByteString -> msgWithBytes))
forall s a. Decoder s a -> Decoder s (WithByteSpan a)
Utils.decodeWithByteSpan Decoder s (ByteString -> msgWithBytes)
forall s. Decoder s (ByteString -> msgWithBytes)
decodeMsgWithBytes)
          more <- bool DoesNotHaveMore HasMore <$> CBOR.decodeBool
          return (Annotator \ByteString
bytes ->
                   Message (LocalMsgNotification msg) st StIdle -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (LocalMsgNotification msg) st StIdle -> SomeMessage st)
-> Message (LocalMsgNotification msg) st StIdle -> SomeMessage st
forall a b. (a -> b) -> a -> b
$ BlockingReplyList 'StBlocking msg
-> HasMore
-> Message (LocalMsgNotification msg) (StBusy 'StBlocking) StIdle
forall (blocking :: StBlockingStyle) msg.
BlockingReplyList blocking msg
-> HasMore
-> Message (LocalMsgNotification msg) (StBusy blocking) StIdle
MsgReply (NonEmpty msg -> BlockingReplyList 'StBlocking msg
forall a. NonEmpty a -> BlockingReplyList 'StBlocking a
BlockingReply (ByteString -> WithByteSpan (ByteString -> msgWithBytes) -> msg
mkWithBytes ByteString
bytes (WithByteSpan (ByteString -> msgWithBytes) -> msg)
-> NonEmpty (WithByteSpan (ByteString -> msgWithBytes))
-> NonEmpty msg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WithByteSpan (ByteString -> msgWithBytes)]
-> NonEmpty (WithByteSpan (ByteString -> msgWithBytes))
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList [WithByteSpan (ByteString -> msgWithBytes)]
msgs)) HasMore
more)

        (SingMsgNotification st
SingIdle, Int
1, Word
3) -> Annotator ByteString st -> Decoder s (Annotator ByteString st)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> SomeMessage st) -> Annotator ByteString st
forall {ps} bytes (st :: ps).
(bytes -> SomeMessage st) -> Annotator bytes st
Annotator \ByteString
_ -> Message (LocalMsgNotification msg) st StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LocalMsgNotification msg) st StDone
Message (LocalMsgNotification msg) StIdle StDone
forall msg. Message (LocalMsgNotification msg) StIdle StDone
MsgClientDone)

        (SingMsgNotification st
SingDone, Int
_, Word
_) -> StateToken StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken StDone
stok

        --
        -- failure
        --
        (SingMsgNotification st
_, Int
_, Word
_) ->
          String -> Decoder s (Annotator ByteString st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> Word -> Int -> String
forall r. PrintfType r => String -> r
printf String
"codecLocalMsgNotification (%s, %s) unexpected key (%d, %d)"
                       (ActiveAgency' st (StateAgency st) -> String
forall a. Show a => a -> String
show (ActiveAgency' st (StateAgency st)
forall {ps} (st :: ps) (agency :: Agency).
IsActiveState st agency =>
ActiveAgency' st agency
activeAgency :: ActiveAgency st)) (SingMsgNotification st -> String
forall a. Show a => a -> String
show StateToken st
SingMsgNotification st
stok) Word
key Int
len)