dmq-node: added cddl for LocalMsgNotification protocol

We only check the decoder by generating terms with `cddl`.

Author: coot

dmq-node/cddl/Main.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
@@ -20,33 +21,38 @@
 
 module Main (main) where
 
-import Control.Monad (forM_)
+import Control.Monad (forM, forM_, unless)
 import Control.Monad.Except (ExceptT (..), runExceptT)
 
 import Codec.CBOR.Read qualified as CBOR
--- import Codec.CBOR.Term (Term (..))
+import Codec.CBOR.Term (Term (..))
 import Codec.CBOR.Term qualified as CBOR
--- import Codec.CBOR.Write qualified as CBOR
+import Codec.CBOR.Write qualified as CBOR
 -- import Codec.Serialise.Class (Serialise)
 -- import Codec.Serialise.Class qualified as Serialise
 import Codec.Serialise.Decoding qualified as CBOR
 -- import Codec.Serialise.Encoding qualified as CBOR
 
 import Data.Bool (bool)
-import Data.ByteString.Base16.Lazy as BL.Base16
+import Data.ByteString.Base16.Lazy qualified as BL.Base16
 import Data.ByteString.Lazy qualified as BL
 import Data.ByteString.Lazy.Char8 qualified as BL.Char8
+import Text.Printf
 
 import System.Directory (doesDirectoryExist)
 import System.Environment (setEnv)
-import System.Exit (ExitCode (..))
+import System.Exit (ExitCode (..), die)
 import System.FilePath
 import System.IO (hClose)
 import System.IO.Temp (withTempFile)
 import System.Process.ByteString.Lazy
 
+import Network.TypedProtocol.Codec
+
 import Cardano.KESAgent.Protocols.StandardCrypto (StandardCrypto)
 
+import DMQ.Protocol.LocalMsgNotification.Codec
+import DMQ.Protocol.LocalMsgNotification.Type as LocalMsgNotification
 import DMQ.Protocol.SigSubmission.Codec
 import DMQ.Protocol.SigSubmission.Type
 
@@ -62,29 +68,58 @@ main = do
   defaultMain (tests cddlSpecs)
 
 tests :: CDDLSpecs -> TestTree
-tests CDDLSpecs { cddlSig
+tests CDDLSpecs { cddlSig,
+                  cddlLocalMsgNotification
                 } =
   adjustOption (const $ QuickCheckMaxSize 10) $
   testGroup "cddl"
     [ testGroup "decoding"
       -- validate decoder by generating messages from the specification
       [ testCase "Sig" (unit_decodeSig cddlSig)
+      , testCase "LocalMsgNotification" (unit_decodeLocalMsgNotification cddlLocalMsgNotification)
       ]
+      -- TODO: validate `LocalMsgNotification` encoder
     ]
 
 newtype CDDLSpec ps = CDDLSpec BL.ByteString
 
 type AnnSigRawWithSignedBytes = BL.ByteString -> SigRawWithSignedBytes StandardCrypto
 
 data CDDLSpecs = CDDLSpecs {
-    cddlSig :: CDDLSpec AnnSigRawWithSignedBytes
+    cddlSig                  :: CDDLSpec AnnSigRawWithSignedBytes,
+    cddlLocalMsgNotification :: CDDLSpec (LocalMsgNotification (Sig StandardCrypto))
   }
 
 
 unit_decodeSig :: CDDLSpec AnnSigRawWithSignedBytes
                -> Assertion
 unit_decodeSig spec = validateDecoder spec decodeSig 100
 
+unit_decodeLocalMsgNotification :: CDDLSpec (LocalMsgNotification (Sig StandardCrypto))
+                                -> Assertion
+unit_decodeLocalMsgNotification spec =
+    validateAnnotatedDecoder
+      (Just fix)
+      spec
+      codecLocalMsgNotification
+      [ SomeAgency   LocalMsgNotification.SingIdle
+      , SomeAgency $ LocalMsgNotification.SingBusy LocalMsgNotification.SingBlocking
+      , SomeAgency $ LocalMsgNotification.SingBusy LocalMsgNotification.SingNonBlocking
+      ]
+      100
+  where
+    -- | The cddl spec cannot differentiate between fix-length list encoding and
+    -- infinite-length encoding.  The cddl tool always generates fix-length
+    -- encoding but tx-submission codec is accepting only indefinite-length
+    -- encoding.
+    --
+    fix :: CBOR.Term -> CBOR.Term
+    fix = \case
+            TList (TInt tag : TList l : as)
+                 | tag == 1 || tag == 2
+                 -> TList (TInt tag : TListI l : as)
+            term -> term
+
 
 --
 -- utils
@@ -98,7 +133,9 @@ unit_decodeSig spec = validateDecoder spec decodeSig 100
 -- The `CDDL_INCLUDE_PATH` environment variable must be set.
 cddlc :: FilePath -> IO BL.ByteString
 cddlc path = do
-  (_, cddl, _) <- readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty
+  (exitCode, cddl, _) <- readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty
+  unless (exitCode == ExitSuccess) $
+    die $ printf "cddlc failed on \"%s\" with %s " path (show exitCode)
   return cddl
 
 
@@ -110,9 +147,11 @@ readCDDLSpecs = do
     setEnv "CDDL_INCLUDE_PATH" (dir <> ":")
 
     sigSpec <- cddlc (dir </> "sig.cddl")
+    localMessageNotificationSpec <- cddlc (dir </> "local-msg-notification.cddl")
 
     return CDDLSpecs {
-        cddlSig = CDDLSpec sigSpec
+        cddlSig = CDDLSpec sigSpec,
+        cddlLocalMsgNotification = CDDLSpec localMessageNotificationSpec
       }
 
 
@@ -130,7 +169,7 @@ validateDecoder (CDDLSpec spec) decoder rounds = do
             res = CBOR.deserialiseFromBytes decoder encoded_term
         case res of
           Left err -> assertFailure $ concat
-            [ "decoding failure:\n"
+            [ printf "decoding failure:\n"
             , show err
             , "\nwhile decoding:\n"
             , show decoded_term
@@ -142,6 +181,76 @@ validateDecoder (CDDLSpec spec) decoder rounds = do
           Right _ -> return ()
 
 
+data SomeAgency ps where
+    SomeAgency :: ( ActiveState st
+                  , Show (StateToken st)
+                  )
+               => StateToken (st :: ps)
+               -> SomeAgency ps
+
+deriving instance Show (SomeAgency ps)
+
+
+-- | Generate valid encoded messages from a specification using `cddl generate`
+-- (and encoded with `diag2cbor.rb`) and check that we can decode it at one of
+-- the given agencies.
+--
+validateAnnotatedDecoder
+  :: forall ps.
+     Maybe (CBOR.Term -> CBOR.Term)
+  -- ^ transform a generated term
+  -> CDDLSpec ps
+  -> AnnotatedCodec ps CBOR.DeserialiseFailure IO BL.ByteString
+  -> [SomeAgency ps]
+  -> Int
+  -> Assertion
+validateAnnotatedDecoder transform (CDDLSpec spec) codec stoks rounds = do
+    eterms <- runExceptT $ generateCBORFromSpec spec rounds
+    case eterms of
+      Left err -> assertFailure err
+      Right terms ->
+        forM_ terms $ \(generated_term, encoded_term) -> do
+          let encoded_term' = case transform of
+                 Nothing -> encoded_term
+                 Just tr -> case CBOR.deserialiseFromBytes CBOR.decodeTerm encoded_term of
+                   Right (rest, term)  | BL.null rest
+                                      -> CBOR.toLazyByteString (CBOR.encodeTerm (tr term))
+                   Right _            -> error   "validateDecoder: trailing bytes"
+                   Left err           -> error $ "validateDecoder: decoding error: "
+                                              ++ show err
+
+              Right (_, decoded_term) =
+                CBOR.deserialiseFromBytes CBOR.decodeTerm encoded_term'
+          res <- decodeMsg encoded_term'
+          case res of
+            Just errs -> assertFailure $ concat
+              [ printf "decoding failures:\n"
+              , unlines ((\(SomeAgency a, e) -> printf "%-25s: %s" (show a) (show e)) <$>errs)
+              , "while decoding:\n"
+              , show decoded_term
+              , "\ngenerated term (not rewritten):\n"
+              , BL.Char8.unpack generated_term
+              , "\nencoded term:\n"
+              , BL.Char8.unpack (BL.Base16.encode encoded_term')
+              ]
+            Nothing -> return ()
+  where
+    -- | Try decode at all given agencies.  If one succeeds return
+    -- 'Nothing' otherwise return all 'DeserialiseFailure's.
+    --
+    decodeMsg :: BL.ByteString
+              -> IO (Maybe [(SomeAgency ps, CBOR.DeserialiseFailure)])
+    decodeMsg bs =
+        -- sequence [Nothing, ...] = Nothing
+        fmap sequence $
+        forM stoks $ \(a@(SomeAgency (stok :: StateToken st))) -> do
+            decoder <- decode codec stok
+            res <- runDecoder [bs] decoder
+            return $ case res of
+              Left err -> Just (a, err)
+              Right {} -> Nothing
+
+
 generateCBORFromSpec :: BL.ByteString
                      -> Int
                      -> ExceptT String IO [(BL.ByteString, BL.ByteString)]

dmq-node/cddl/specs/local-msg-notification.cddl

@@ -0,0 +1,19 @@
+localMessageNotificationMessage
+  =
+  ; corresponds to either MsgRequestMessagesBlocking or
+  ; MsgRequestMessagesNonBlocking in the spec
+    msgRequestMessages
+  / msgReplyMessagesNonBlocking
+  / msgReplyMessagesBlocking
+  / msgClientDone
+
+isBlocking = bool
+hasMore = bool
+msgRequestMessages          = [0, isBlocking]
+; the codec only accepts indefinite lists of messages
+msgReplyMessagesNonBlocking = [1, [*sig.message], hasMore]
+; the codec only accepts indefinite lists of messages
+msgReplyMessagesBlocking    = [2, [+sig.message], hasMore]
+msgClientDone               = [3]
+
+;# import sig as sig

dmq-node/dmq-node.cabal

@@ -225,6 +225,7 @@ test-suite dmq-cddl
     tasty-hunit,
     tasty-quickcheck,
     temporary,
+    typed-protocols,
 
   ghc-options:
     -threaded

dmq-node/src/DMQ/NodeToClient/LocalMsgNotification.hs

@@ -26,6 +26,14 @@ instance Exception LocalMsgNotificationProtocolError where
 
 -- | Local Message Notification server application
 --
+-- enforced protocol invariants:
+--
+-- * non-blocking requests are only accepted when the server has no more messages,
+--   client is aware of this from previous replies
+-- * dually, blocking requests are only accepted when the server has more
+--   messages.
+-- * the first request must be blocking
+--
 localMsgNotificationServer
   :: forall m msg msgid idx a. (MonadSTM m, MonadThrow m)
   => Tracer m (TraceMessageNotificationServer msg)

ouroboros-network-protocols/cddl/Main.hs

@@ -644,6 +644,7 @@ data SomeAgency ps where
 -- (and encoded with `diag2cbor.rb`) and check that we can decode it at one of
 -- the given agencies.
 --
+-- TODO: move to a common library shared with `dmq-node:cddl-test`
 validateDecoder :: Maybe (CBOR.Term -> CBOR.Term)
                 -- ^ transform a generated term
                 -> CDDLSpec ps

ouroboros-network-protocols/cddl/specs/tx-submission2.cddl

@@ -29,7 +29,7 @@ txCount         = base.word16
 txIdList        = [ *base.txId ]
 txList          = [ *base.tx ]
 txIdAndSize     = [base.txId, txSizeInBytes]
-; The codec only accepts definite-length lists.
+; The codec only accepts indefinite-length lists.
 txIdsAndSizes   = [ *txIdAndSize ]
 txSizeInBytes   = base.word32