Merge pull request #74 from input-output-hk/coot/annotated-codec

AnnotatedCodec

Author: coot

.github/workflows/haskell.yml

@@ -100,7 +100,7 @@ jobs:
     runs-on: ubuntu-22.04
 
     env:
-      STYLISH_HASKELL_VERSION: "0.14.4.0"
+      STYLISH_HASKELL_VERSION: "0.14.6.0"
 
     steps:
     - name: Set cache version
@@ -116,8 +116,8 @@ jobs:
       uses: haskell-actions/setup@v2
       id: setup-haskell
       with:
-        ghc-version: 9.2.5
-        cabal-version: 3.8.1.0
+        ghc-version: 9.8
+        cabal-version: 3.12.1.0
 
     - name: "Setup cabal bin path"
       run: |

cabal.project

@@ -1,4 +1,4 @@
-index-state:  2025-05-21T15:48:46Z
+index-state: 2025-07-08T15:23:02Z
 
 packages: ./typed-protocols
           ./typed-protocols-doc
@@ -10,6 +10,10 @@ if impl(ghc >= 9.12)
     , serdoc-core:template-haskell
     , serdoc-core:th-abstraction
 
+allow-newer:
+  , serdoc-core:QuickCheck
+  , serdoc-core:tasty-quickcheck
+
 if os(windows)
   package text
     flags: -simdutf

typed-protocols-doc/typed-protocols-doc.cabal

@@ -54,7 +54,7 @@ library
                  , th-abstraction >=0.6.0.0 && <0.8
                  , time >=1.12 && <1.14
                  , serdoc-core
-                 , typed-protocols ^>= 1.0
+                 , typed-protocols ^>= 1.0 || ^>= 1.1
     hs-source-dirs:   src
     default-language:   GHC2021
     default-extensions: DataKinds
@@ -89,7 +89,7 @@ test-suite typed-protocols-doc-test
     build-depends: base >=4.14.0.0 && <5
                  , blaze-html >=0.9.1.2 && <0.10
                  , tasty >=1.5 && <1.6
-                 , tasty-quickcheck >=0.10.3 && <0.11
+                 , tasty-quickcheck >=0.10.3 && <0.12
                  , typed-protocols
                  , typed-protocols-doc
                  , serdoc-core

typed-protocols/CHANGELOG.md

@@ -1,5 +1,22 @@
 # Revision history for typed-protocols
 
+## 1.1.0.0 -- 05.08.2025
+
+### Breaking changes
+
+* Annotated codecs which allow to retain original bytes received from the network.
+  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).  They now return the
+  `QuickCheck`'s `Property` rather than a `Bool`.
+
+### Non-breaking changes
+
+## 1.0.0.0
+
+* Hackage release.
+
 ## 0.3.0.0
 
 * `AnyMessageWithAgency` pattern synonym is exported as a constructor of `AnyMessage`.

typed-protocols/cborg/Network/TypedProtocol/Codec/CBOR.hs

@@ -25,10 +25,10 @@ import Network.TypedProtocol.Codec
 import Network.TypedProtocol.Core
 
 
--- | Construct a 'Codec' for a CBOR based serialisation format, using strict
+-- | Construct a 'CodecF' for a CBOR based serialisation format, using strict
 -- 'BS.ByteString's.
 --
--- This is an adaptor between the @cborg@ library and the 'Codec' abstraction.
+-- This is an adaptor between the @cborg@ library and the 'CodecF' abstraction.
 --
 -- It takes encode and decode functions for the protocol messages that use the
 -- CBOR library encoder and decoder.
@@ -38,7 +38,7 @@ import Network.TypedProtocol.Core
 -- natively produces chunks).
 --
 mkCodecCborStrictBS
-  :: forall ps m. MonadST m
+  :: forall ps m f. MonadST m
 
   => (forall (st :: ps) (st' :: ps).
              StateTokenI st
@@ -49,10 +49,10 @@ mkCodecCborStrictBS
   -> (forall (st :: ps) s.
              ActiveState st
           => StateToken st
-          -> CBOR.Decoder s (SomeMessage st))
+          -> CBOR.Decoder s (f st))
   -- ^ cbor decoder
 
-  -> Codec ps CBOR.DeserialiseFailure m BS.ByteString
+  -> CodecF ps CBOR.DeserialiseFailure m f BS.ByteString
 mkCodecCborStrictBS cborMsgEncode cborMsgDecode =
     Codec {
       encode = \msg  -> convertCborEncoder cborMsgEncode msg,
@@ -65,11 +65,12 @@ mkCodecCborStrictBS cborMsgEncode cborMsgDecode =
       . cborEncode
 
     convertCborDecoder
-      :: (forall s. CBOR.Decoder s a)
-      -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m a)
+      :: (forall s. CBOR.Decoder s (f a))
+      -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m (f a))
     convertCborDecoder cborDecode =
         convertCborDecoderBS cborDecode stToIO
 
+
 convertCborDecoderBS
   :: forall s m a. Functor m
   => CBOR.Decoder s a
@@ -89,16 +90,16 @@ convertCborDecoderBS cborDecode liftST =
     go (CBOR.Partial k)        = DecodePartial (fmap go . liftST . k)
 
 
--- | Construct a 'Codec' for a CBOR based serialisation format, using lazy
+-- | Construct a 'CodecF' for a CBOR based serialisation format, using lazy
 -- 'BS.ByteString's.
 --
--- This is an adaptor between the @cborg@ library and the 'Codec' abstraction.
+-- This is an adaptor between the @cborg@ library and the 'CodecF' abstraction.
 --
 -- It takes encode and decode functions for the protocol messages that use the
 -- CBOR library encoder and decoder.
 --
 mkCodecCborLazyBS
-  :: forall ps m. MonadST m
+  :: forall ps m f. MonadST m
 
   => (forall (st :: ps) (st' :: ps).
              StateTokenI st
@@ -109,10 +110,10 @@ mkCodecCborLazyBS
   -> (forall (st :: ps) s.
              ActiveState st
           => StateToken st
-          -> CBOR.Decoder s (SomeMessage st))
+          -> CBOR.Decoder s (f st))
   -- ^ cbor decoder
 
-  -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString
+  -> CodecF ps CBOR.DeserialiseFailure m f LBS.ByteString
 mkCodecCborLazyBS  cborMsgEncode cborMsgDecode =
     Codec {
       encode = \msg  -> convertCborEncoder cborMsgEncode msg,
@@ -126,11 +127,12 @@ mkCodecCborLazyBS  cborMsgEncode cborMsgDecode =
       . cborEncode
 
     convertCborDecoder
-      :: (forall s. CBOR.Decoder s a)
-      -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a)
+      :: (forall s. CBOR.Decoder s (f a))
+      -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m (f a))
     convertCborDecoder cborDecode =
         convertCborDecoderLBS cborDecode stToIO
 
+
 convertCborDecoderLBS
   :: forall s m a. Monad m
   => CBOR.Decoder s a

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)