typed-protocols:test - added prop_anncodec for ReqResp mini-protocol

Author: coot

typed-protocols/CHANGELOG.md

@@ -8,7 +8,8 @@
   The `Codec` type evolved into a new `CodecF` data type, and two type aliases
   `AnnotatedCodec`, `Codec`.
 * `prop_codec` properties moved to `typed-protocols:codec-properties` library
-  (`Network.TypedProtocol.Codec.Properties` module).
+  (`Network.TypedProtocol.Codec.Properties` module).  They now return the
+  `QuickCheck`'s `Property` rather than a `Bool`.
 
 ### Non-breaking changes
 

typed-protocols/examples/Network/TypedProtocol/ReqResp/Codec.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE BlockArguments #-}
+
 module Network.TypedProtocol.ReqResp.Codec where
 
 import Network.TypedProtocol.Codec
@@ -43,6 +45,68 @@ codecReqResp =
             where failure = CodecFailure ("unexpected server message: " ++ str)
 
 
+data WithBytes a = WithBytes {
+    bytes   :: String,
+    message :: a
+  }
+  deriving (Show, Eq)
+
+mkWithBytes :: Show a => a -> WithBytes a
+mkWithBytes message = WithBytes { bytes = show message, message }
+
+
+anncodecReqResp ::
+    forall req resp m
+  .  (Monad m, Show req, Show resp, Read req, Read resp)
+  => AnnotatedCodec (ReqResp (WithBytes req) (WithBytes resp)) CodecFailure m String
+anncodecReqResp =
+      Codec{encode, decode}
+  where
+    encode :: forall req' resp'
+                     (st  :: ReqResp (WithBytes req') (WithBytes resp'))
+                     (st' :: ReqResp (WithBytes req') (WithBytes resp'))
+           .  ( Show req'
+              , Show resp'
+              )
+           => Message (ReqResp (WithBytes req') (WithBytes resp')) st st'
+           -> String
+    -- NOTE: we're not using 'Show (Message ...)' instance.  If `req ~ Int`,
+    -- then negative numbers will be surrounded with braces (e.g. @"(-1)"@) and
+    -- the `Read` type class doesn't have a way to see that brackets were consumed
+    -- from the input string.
+    encode (MsgReq WithBytes { message })
+      = "MsgReq " ++ show message ++ "\n"
+    encode (MsgResp WithBytes { message })
+      = "MsgResp " ++ show message ++ "\n"
+    encode MsgDone
+      = "MsgDone" ++ "\n"
+
+    decode :: forall req' resp' m'
+                     (st :: ReqResp (WithBytes req') (WithBytes resp'))
+           .  (Monad m', Read req', Read resp', ActiveState st)
+           => StateToken st
+           -> m' (DecodeStep String CodecFailure m' (Annotator String st))
+    decode stok =
+      decodeTerminatedFrame '\n' $ \str trailing ->
+        case (stok, break (==' ') str) of
+          (SingIdle, ("MsgReq", str'))
+             | Just req <- readMaybe @req' str'
+            -> DecodeDone (Annotator \str'' ->
+                           let used = init $ drop 7 str'' in
+                           SomeMessage (MsgReq (WithBytes used req))) trailing
+          (SingIdle, ("MsgDone", ""))
+            -> DecodeDone (Annotator \_str'' -> SomeMessage MsgDone) trailing
+          (SingBusy, ("MsgResp", str'))
+            | Just resp <- readMaybe @resp' str'
+            -> DecodeDone (Annotator \str'' ->
+                           let used = init $ drop 8 str'' in
+                           SomeMessage (MsgResp (WithBytes used resp))) trailing
+
+          (_       , _     ) -> DecodeFail failure
+            where failure = CodecFailure ("unexpected server message: " ++ str)
+
+
+
 codecReqRespId ::
     forall req resp m
   . (Monad m, Show req, Show resp)

typed-protocols/examples/Network/TypedProtocol/ReqResp/Type.hs

@@ -28,9 +28,9 @@ instance StateTokenI StDone where
 instance Protocol (ReqResp req resp) where
 
   data Message (ReqResp req resp) from to where
-    MsgReq  :: req  -> Message (ReqResp req resp) StIdle StBusy
-    MsgResp :: resp -> Message (ReqResp req resp) StBusy StIdle
-    MsgDone ::         Message (ReqResp req resp) StIdle StDone
+    MsgReq  :: forall req resp. req  -> Message (ReqResp req resp) StIdle StBusy
+    MsgResp :: forall req resp. resp -> Message (ReqResp req resp) StBusy StIdle
+    MsgDone :: forall req resp.         Message (ReqResp req resp) StIdle StDone
 
   type StateAgency StIdle = ClientAgency
   type StateAgency StBusy = ServerAgency

typed-protocols/properties/Network/TypedProtocol/Codec/Properties.hs

@@ -136,6 +136,14 @@ prop_codec = prop_codecF const
 
 -- | The 'Codec' round-trip property in a pure monad.
 --
+-- NOTE: when a message is annotated with bytes (e.g. `WithBytes` in
+-- `Network.TypedProtocol.ReqResp.Codec.anncodecReqResp`), this property will
+-- assess that the decoded bytes are equal to the supplied bytes with
+-- `msg :: AnyMessage ps`.  It is important to use the bytes in `WithBytes` when
+-- encoding the `msg`.  Verifying this property is especially important if the
+-- bytes are used to check a cryptographic signature, when the exact same bytes
+-- received from the network must be used.
+--
 prop_anncodec
   :: forall ps failure m bytes.
     ( Monad m

typed-protocols/test/Network/TypedProtocol/ReqResp/Tests.hs

@@ -73,6 +73,9 @@ tests = testGroup "Network.TypedProtocol.ReqResp"
       , testProperty "codec 3-splits"  $ withMaxSuccess 30 prop_codec_cbor_splits3_ReqResp
       ]
     ]
+  , testGroup "AnnotatedCodec"
+    [ testProperty "codec"             prop_anncodec_ReqResp
+    ]
   ]
 
 
@@ -360,3 +363,16 @@ prop_codec_cbor_splits3_ReqResp msg =
       splits3BS
       CBOR.codecReqResp
       msg
+
+
+instance (Show a, Arbitrary a) => Arbitrary (WithBytes a) where
+  arbitrary = mkWithBytes <$> arbitrary
+  shrink WithBytes { message } = mkWithBytes <$> shrink message
+
+prop_anncodec_ReqResp
+  :: AnyMessage (ReqResp (WithBytes Int) (WithBytes Int))
+  -> Property
+prop_anncodec_ReqResp =
+  prop_anncodec
+    runIdentity
+    anncodecReqResp

typed-protocols/typed-protocols.cabal

@@ -53,6 +53,7 @@ library
 
 library codec-properties
   import:             GHC
+  visibility:         public
   exposed-modules:    Network.TypedProtocol.Codec.Properties
                       Network.TypedProtocol.Stateful.Codec.Properties
   build-depends:      base >=4.12 && <4.22,