From 08ee7c44be5662f847046ae8c59a388d331c417a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 25 Jul 2024 15:40:36 +0200 Subject: [PATCH 01/39] typed-protocols: new API The new API provides proofs for all protocols, and thus proof obligations are not part of `Protocol` type class but instead an internal detail of the library. --- .../src/Network/TypedProtocol/Codec/CBOR.hs | 33 +- .../typed-protocols-cborg.cabal | 1 + typed-protocols/src/Network/TypedProtocol.hs | 6 +- .../src/Network/TypedProtocol/Codec.hs | 159 +++-- .../src/Network/TypedProtocol/Core.hs | 553 +++++++++--------- .../src/Network/TypedProtocol/Driver.hs | 85 +-- .../src/Network/TypedProtocol/Peer.hs | 293 ++++++++++ .../src/Network/TypedProtocol/Pipelined.hs | 197 ------- .../src/Network/TypedProtocol/Proofs.hs | 368 +++++------- typed-protocols/typed-protocols.cabal | 5 +- 10 files changed, 865 insertions(+), 835 deletions(-) create mode 100644 typed-protocols/src/Network/TypedProtocol/Peer.hs delete mode 100644 typed-protocols/src/Network/TypedProtocol/Pipelined.hs diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index bb2183a5..aabb1fc7 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -22,6 +22,7 @@ import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Internal as LBS (smallChunkSize) +import Data.Singletons import Network.TypedProtocol.Codec import Network.TypedProtocol.Core @@ -44,19 +45,19 @@ type DeserialiseFailure = CBOR.DeserialiseFailure mkCodecCborStrictBS :: forall ps m. MonadST m - => (forall (pr :: PeerRole) (st :: ps) (st' :: ps). - PeerHasAgency pr st - -> Message ps st st' -> CBOR.Encoding) + => (forall (st :: ps) (st' :: ps). + SingI st + => Message ps st st' -> CBOR.Encoding) - -> (forall (pr :: PeerRole) (st :: ps) s. - PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st)) + -> (forall (st :: ps) s. + SingI st + => CBOR.Decoder s (SomeMessage st)) -> Codec ps DeserialiseFailure m BS.ByteString mkCodecCborStrictBS cborMsgEncode cborMsgDecode = Codec { - encode = \stok msg -> convertCborEncoder (cborMsgEncode stok) msg, - decode = \stok -> convertCborDecoder (cborMsgDecode stok) + encode = \msg -> convertCborEncoder cborMsgEncode msg, + decode = convertCborDecoder cborMsgDecode } where convertCborEncoder :: (a -> CBOR.Encoding) -> a -> BS.ByteString @@ -98,19 +99,19 @@ convertCborDecoderBS cborDecode liftST = mkCodecCborLazyBS :: forall ps m. MonadST m - => (forall (pr :: PeerRole) (st :: ps) (st' :: ps). - PeerHasAgency pr st - -> Message ps st st' -> CBOR.Encoding) + => (forall (st :: ps) (st' :: ps). + SingI st + => Message ps st st' -> CBOR.Encoding) - -> (forall (pr :: PeerRole) (st :: ps) s. - PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st)) + -> (forall (st :: ps) s. + SingI st + => CBOR.Decoder s (SomeMessage st)) -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString mkCodecCborLazyBS cborMsgEncode cborMsgDecode = Codec { - encode = \stok msg -> convertCborEncoder (cborMsgEncode stok) msg, - decode = \stok -> convertCborDecoder (cborMsgDecode stok) + encode = \msg -> convertCborEncoder cborMsgEncode msg, + decode = convertCborDecoder cborMsgDecode } where convertCborEncoder :: (a -> CBOR.Encoding) -> a -> LBS.ByteString diff --git a/typed-protocols-cborg/typed-protocols-cborg.cabal b/typed-protocols-cborg/typed-protocols-cborg.cabal index e770a0e0..b7a80a80 100644 --- a/typed-protocols-cborg/typed-protocols-cborg.cabal +++ b/typed-protocols-cborg/typed-protocols-cborg.cabal @@ -21,6 +21,7 @@ library build-depends: base >=4.12 && <4.21, bytestring >=0.10 && <0.13, cborg >=0.2.1 && <0.3, + singletons, io-classes ^>=1.5, typed-protocols diff --git a/typed-protocols/src/Network/TypedProtocol.hs b/typed-protocols/src/Network/TypedProtocol.hs index f88fe39f..779c622c 100644 --- a/typed-protocols/src/Network/TypedProtocol.hs +++ b/typed-protocols/src/Network/TypedProtocol.hs @@ -8,20 +8,18 @@ module Network.TypedProtocol -- * Defining and implementing protocols -- $defining module Network.TypedProtocol.Core + , module Network.TypedProtocol.Peer -- ** Protocol proofs and tests -- $tests , module Network.TypedProtocol.Proofs -- * Running protocols -- $running , module Network.TypedProtocol.Driver - -- * Pipelining protocols - -- $pipelining - , module Network.TypedProtocol.Pipelined ) where import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer import Network.TypedProtocol.Driver -import Network.TypedProtocol.Pipelined import Network.TypedProtocol.Proofs diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 2d548395..a337c32e 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -6,9 +6,10 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- @UndecidableInstances@ extension is required for defining @Show@ instance of --- @'AnyMessage'@ and @'AnyMessageAndAgency'@. +-- @'AnyMessage'@ and @'AnyMessage'@. {-# LANGUAGE UndecidableInstances #-} module Network.TypedProtocol.Codec @@ -19,9 +20,6 @@ module Network.TypedProtocol.Codec , mapFailureCodec -- ** Related types , PeerRole (..) - , PeerHasAgency (..) - , WeHaveAgency - , TheyHaveAgency , SomeMessage (..) , CodecFailure (..) -- ** Incremental decoding @@ -30,7 +28,6 @@ module Network.TypedProtocol.Codec , runDecoderPure -- ** Codec properties , AnyMessage (..) - , AnyMessageAndAgency (..) , prop_codecM , prop_codec , prop_codec_splitsM @@ -46,8 +43,9 @@ import Control.Exception (Exception) import Data.Kind (Type) import Data.Monoid (All (..)) -import Network.TypedProtocol.Core (PeerHasAgency (..), PeerRole (..), - Protocol (..), TheyHaveAgency, WeHaveAgency) +import Data.Singletons + +import Network.TypedProtocol.Core (PeerRole (..), Protocol (..)) import Network.TypedProtocol.Driver (SomeMessage (..)) -- | A codec for a 'Protocol' handles the encoding and decoding of typed @@ -79,12 +77,12 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- -- For example a simple text encoder for the ping\/pong protocol could be: -- --- > encode :: WeHaveAgency pr st --- > -> Message PingPong st st' +-- > encode :: SingI st +-- > => Message PingPong st st' -- > -> String --- > encode (ClientAgency TokIdle) MsgPing = "ping\n" --- > encode (ClientAgency TokIdle) MsgDone = "done\n" --- > encode (ServerAgency TokBusy) MsgPong = "pong\n" +-- > encode MsgPing = "ping\n" +-- > encode MsgDone = "done\n" +-- > encode MsgPong = "pong\n" -- -- The decoder is also given the current protocol state and it is expected to -- be able to decode /any/ message that is valid in that state, but /only/ @@ -101,16 +99,16 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- decoder allows but does not require a format with message framing where the -- decoder input matches exactly with the message boundaries. -- --- > decode :: TheyHaveAgency pr st --- > -> m (DecodeStep String String m (SomeMessage st)) --- > decode stok = +-- > decode :: forall st m. SingI st +-- > => m (DecodeStep String String m (SomeMessage st)) +-- > decode = -- > decodeTerminatedFrame '\n' $ \str trailing -> --- > case (stok, str) of --- > (ServerAgency TokBusy, "pong") -> +-- > case (sing :: Sing st, str) of +-- > (TokBusy, "pong") -> -- > DecodeDone (SomeMessage MsgPong) trailing --- > (ClientAgency TokIdle, "ping") -> +-- > (TokIdle, "ping") -> -- > DecodeDone (SomeMessage MsgPing) trailing --- > (ClientAgency TokIdle, "done") -> +-- > (TokIdle, "done") -> -- > DecodeDone (SomeMessage MsgDone) trailing -- > _ -> DecodeFail ("unexpected message: " ++ str) -- @@ -123,14 +121,14 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- 'DecodeStep' for suggestions on how to use it for more realistic formats. -- data Codec ps failure m bytes = Codec { - encode :: forall (pr :: PeerRole) (st :: ps) (st' :: ps). - PeerHasAgency pr st - -> Message ps st st' + encode :: forall (st :: ps) (st' :: ps). + SingI st + => Message ps st st' -> bytes, - decode :: forall (pr :: PeerRole) (st :: ps). - PeerHasAgency pr st - -> m (DecodeStep bytes failure m (SomeMessage st)) + decode :: forall (st :: ps). + SingI st + => m (DecodeStep bytes failure m (SomeMessage st)) } hoistCodec @@ -139,7 +137,7 @@ hoistCodec -> Codec ps failure m bytes -> Codec ps failure n bytes hoistCodec nat codec = codec - { decode = fmap (hoistDecodeStep nat) . nat . decode codec + { decode = fmap (hoistDecodeStep nat) . nat $ decode codec } isoCodec :: Functor m @@ -148,8 +146,8 @@ isoCodec :: Functor m -> Codec ps failure m bytes -> Codec ps failure m bytes' isoCodec f finv Codec {encode, decode} = Codec { - encode = \tok msg -> f $ encode tok msg, - decode = \tok -> isoDecodeStep f finv <$> decode tok + encode = \msg -> f $ encode msg, + decode = isoDecodeStep f finv <$> decode } mapFailureCodec @@ -159,7 +157,7 @@ mapFailureCodec -> Codec ps failure' m bytes mapFailureCodec f Codec {encode, decode} = Codec { encode = encode, - decode = \tok -> mapFailureDecodeStep f <$> decode tok + decode = mapFailureDecodeStep f <$> decode } -- The types here are pretty fancy. The decode is polymorphic in the protocol @@ -278,35 +276,23 @@ runDecoderPure runM decoder bs = runM (runDecoder bs =<< decoder) -- Codec properties -- --- | Any message for a protocol, without knowing the protocol state. --- --- Used at least for 'Eq' instances for messages, but also as a target for an --- identity codec `Codec ps failure m (AnyMessage ps)` . --- -data AnyMessage ps where - AnyMessage :: Message ps st st' -> AnyMessage ps - --- requires @UndecidableInstances@ and @QuantifiedConstraints@. -instance (forall st st'. Show (Message ps st st')) => Show (AnyMessage ps) where - show (AnyMessage msg) = show msg - --- | Used to hold the 'PeerHasAgency' state token and a corresponding 'Message'. +-- | Any message for a protocol, with a 'SingI' constraint which gives access to +-- protocol state. -- -- Used where we don't know statically what the state type is, but need the -- agency and message to match each other. -- -data AnyMessageAndAgency ps where - AnyMessageAndAgency :: PeerHasAgency pr (st :: ps) - -> Message ps (st :: ps) (st' :: ps) - -> AnyMessageAndAgency ps +data AnyMessage ps where + AnyMessage :: forall ps (st :: ps) (st' :: ps). + SingI st + => Message ps (st :: ps) (st' :: ps) + -> AnyMessage ps -- requires @UndecidableInstances@ and @QuantifiedConstraints@. -instance - ( forall (st :: ps). Show (ClientHasAgency st) - , forall (st :: ps). Show (ServerHasAgency st) - , forall (st :: ps) (st' :: ps). Show (Message ps st st') - ) => Show (AnyMessageAndAgency ps) where - show (AnyMessageAndAgency agency msg) = show (agency, msg) +instance (forall (st :: ps) (st' :: ps). Show (Message ps st st')) + => Show (AnyMessage ps) where + show (AnyMessage (msg :: Message ps st st')) = + "AnyMessage " ++ show msg -- | The 'Codec' round-trip property: decode after encode gives the same -- message. Every codec must satisfy this property. @@ -317,11 +303,11 @@ prop_codecM , Eq (AnyMessage ps) ) => Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> m Bool -prop_codecM Codec {encode, decode} (AnyMessageAndAgency stok msg) = do - r <- decode stok >>= runDecoder [encode stok msg] - case r of +prop_codecM Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do + r <- decode >>= runDecoder [encode msg] + case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $ AnyMessage msg' == AnyMessage msg Left _ -> return False @@ -332,7 +318,7 @@ prop_codec (Monad m, Eq (AnyMessage ps)) => (forall a. m a -> a) -> Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> Bool prop_codec runM codec msg = runM (prop_codecM codec msg) @@ -354,17 +340,17 @@ prop_codec_splitsM (Monad m, Eq (AnyMessage ps)) => (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> m Bool prop_codec_splitsM splits - Codec {encode, decode} (AnyMessageAndAgency stok msg) = do + Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do and <$> sequence - [ do r <- decode stok >>= runDecoder bytes' - case r of + [ do r <- decode >>= runDecoder bytes' + case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! AnyMessage msg' == AnyMessage msg Left _ -> return False - | let bytes = encode stok msg + | let bytes = encode msg , bytes' <- splits bytes ] @@ -376,7 +362,7 @@ prop_codec_splits => (bytes -> [[bytes]]) -> (forall a. m a -> a) -> Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> Bool prop_codec_splits splits runM codec msg = runM $ prop_codec_splitsM splits codec msg @@ -389,8 +375,9 @@ prop_codec_splits splits runM codec msg = -- 'PeerHasAgency' for protocol B of some @st :: ps@. data SamePeerHasAgency (pr :: PeerRole) (ps :: Type) where SamePeerHasAgency - :: forall (pr :: PeerRole) ps (st :: ps). - PeerHasAgency pr st + :: forall (pr :: PeerRole) ps (st :: ps) proxy. + SingI st + => !(proxy st) -> SamePeerHasAgency pr ps -- | Binary compatibility of two protocols @@ -413,27 +400,29 @@ prop_codec_binary_compatM ) => Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall pr (stA :: psA). PeerHasAgency pr stA -> SamePeerHasAgency pr psB) + -> (forall pr (stA :: psA). Sing stA -> SamePeerHasAgency pr psB) -- ^ The states of A map directly of states of B. - -> AnyMessageAndAgency psA + -> AnyMessage psA -> m Bool prop_codec_binary_compatM codecA codecB stokEq - (AnyMessageAndAgency (stokA :: PeerHasAgency pr stA) msgA) = - case stokEq stokA of - SamePeerHasAgency stokB -> do + (AnyMessage (msgA :: Message psA stA stA')) = + let stokA :: Sing stA + stokA = sing + in case stokEq stokA of + SamePeerHasAgency (_ :: proxy stB) -> do -- 1. - let bytesA = encode codecA stokA msgA + let bytesA = encode codecA msgA -- 2. - r1 <- decode codecB stokB >>= runDecoder [bytesA] - case r1 of + r1 <- decode codecB >>= runDecoder [bytesA] + case r1 :: Either failure (SomeMessage stB) of Left _ -> return False Right (SomeMessage msgB) -> do -- 3. - let bytesB = encode codecB stokB msgB + let bytesB = encode codecB msgB -- 4. - r2 <- decode codecA stokA >>= runDecoder [bytesB] - case r2 of + r2 <- decode codecA >>= runDecoder [bytesB] + case r2 :: Either failure (SomeMessage stA) of Left _ -> return False Right (SomeMessage msgA') -> return $ AnyMessage msgA' == AnyMessage msgA @@ -446,8 +435,8 @@ prop_codec_binary_compat => (forall a. m a -> a) -> Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall pr (stA :: psA). PeerHasAgency pr stA -> SamePeerHasAgency pr psB) - -> AnyMessageAndAgency psA + -> (forall pr (stA :: psA). Sing stA -> SamePeerHasAgency pr psB) + -> AnyMessage psA -> Bool prop_codec_binary_compat runM codecA codecB stokEq msgA = runM $ prop_codec_binary_compatM codecA codecB stokEq msgA @@ -465,16 +454,16 @@ prop_codecs_compatM ) => Codec ps failure m bytes -> Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> m Bool prop_codecs_compatM codecA codecB - (AnyMessageAndAgency stok msg) = - getAll <$> do r <- decode codecB stok >>= runDecoder [encode codecA stok msg] - case r of + (AnyMessage (msg :: Message ps st st')) = + getAll <$> do r <- decode codecB >>= runDecoder [encode codecA msg] + case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False - <> do r <- decode codecA stok >>= runDecoder [encode codecB stok msg] - case r of + <> do r <- decode codecA >>= runDecoder [encode codecB msg] + case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False @@ -489,7 +478,7 @@ prop_codecs_compat => (forall a. m a -> a) -> Codec ps failure m bytes -> Codec ps failure m bytes - -> AnyMessageAndAgency ps + -> AnyMessage ps -> Bool prop_codecs_compat run codecA codecB msg = run $ prop_codecs_compatM codecA codecB msg diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index b968ddca..70b1e028 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} -- | This module defines the core of the typed protocol framework. @@ -21,17 +23,26 @@ module Network.TypedProtocol.Core Protocol (..) -- $lemmas -- * Engaging in protocols - -- $using , PeerRole (..) - , TokPeerRole (..) + , SingPeerRole (..) + , Agency (..) + , RelativeAgency (..) + , Relative + , ReflRelativeAgency (..) , FlipAgency - , PeerHasAgency (..) - , WeHaveAgency - , TheyHaveAgency - , Peer (..) + , Pipelined (..) + -- * Protocol proofs and tests + -- $tests + -- $lemmas + , exclusionLemma_ClientAndServerHaveAgency + , terminationLemma_1 + , terminationLemma_2 + , ReflNobodyHasAgency (..) ) where -import Data.Void (Void) +import Data.Kind (Type) + +import Data.Singletons -- $intro -- A typed protocol between two peers is defined via a state machine: a @@ -133,9 +144,7 @@ import Data.Void (Void) -- -- As described above, this style of protocol gives agency to only one peer at -- once. That is, in each protocol state, one peer has agency (the ability to --- send) and the other does not (it must only receive). The three associated --- data families ('ClientHasAgency', 'ServerHasAgency' and 'NobodyHasAgency') --- define which peer has agency for each state. +-- send) and the other does not (it must only receive). -- -- In the \"ping\/pong\" protocol example, the idle state is the one in which -- the client can send a message, and the busy state is the one in which the @@ -143,19 +152,29 @@ import Data.Void (Void) -- further messages. This arrangement is defined as so: -- -- > -- still within the instance Protocol PingPong --- > data ClientHasAgency st where --- > TokIdle :: ClientHasAgency StIdle --- > --- > data ServerHasAgency st where --- > TokBusy :: ServerHasAgency StBusy --- > --- > data NobodyHasAgency st where --- > TokDone :: NobodyHasAgency StDone +-- > type StateAgency StIdle = ClientAgency +-- > type StateAgency StBusy = ServerAgency +-- > type StateAgency StDone = NobodyAgency -- -- In this simple protocol there is exactly one state in each category, but in -- general for non-trivial protocols there may be several protocol states in -- each category. -- +-- Furthermore we use singletons to provide term level reflection of type level +-- states. One is required to provide singletons for all types of kind +-- 'PingPong'. This is as simple as providing a GADT: +-- +-- > data SingPingPong (st :: PingPong) where +-- > SingIdle :: SingPingPong StIdle +-- > SingBusy :: SingPingPong StBusy +-- > SingDone :: SingPingPong StDone +-- +-- together with 'Sing' and 'SingI' instances: +-- +-- > type instance Sing = SingPingPong +-- > instance SingI StIdle where sing = SingIdle +-- > instance SingI StBusy where sing = SingBusy +-- > instance SingI StDone where sing = SingDone -- $tests -- The mechanism for labelling each protocol state with the agency does not @@ -169,30 +188,87 @@ import Data.Void (Void) -- each protocol that this property is not violated. It also provides utilities -- helpful for testing protocols. --- $lemmas + +-- | Types for client and server peer roles. As protocol can be viewed from +-- either client or server side. -- --- The 'connect' and 'connectPipelined' proofs rely on lemmas about the --- protocol. Specifically they rely on the property that each protocol state --- is labelled with the agency of one peer or the other, or neither, but never --- both. Or to put it another way, the protocol states should be partitioned --- into those with agency for one peer, or the other or neither. +-- Note that technically \"client\" and \"server\" are arbitrary labels. The +-- framework is completely symmetric between the two peers. -- --- The way the labelling is encoded does not automatically enforce this --- property. It is technically possible to set up the labelling for a protocol --- so that one state is labelled as having both peers with agency, or declaring --- simultaneously that one peer has agency and that neither peer has agency --- in a particular state. +-- This definition is only used as promoted types and kinds, never as values. -- --- So the overall proofs rely on lemmas that say that the labelling has been --- done correctly. This type bundles up those three lemmas. +data PeerRole = AsClient | AsServer + +-- | Singletons for 'PeerRole'. We provide 'Sing' and 'SingI' instances from +-- the "singletons" package. -- --- Specifically proofs that it is impossible for a protocol state to have: +type SingPeerRole :: PeerRole -> Type +data SingPeerRole pr where + SingAsClient :: SingPeerRole AsClient + SingAsServer :: SingPeerRole AsServer + +type instance Sing = SingPeerRole +instance SingI AsClient where + sing = SingAsClient +instance SingI AsServer where + sing = SingAsServer + +-- | A promoted data type which denotes three possible agencies a protocol +-- state might be assigned. -- --- * client having agency and server having agency --- * client having agency and nobody having agency --- * server having agency and nobody having agency +data Agency where + -- | The client has agency. + ClientAgency :: Agency + + -- | The server has agency. + ServerAgency :: Agency + + -- | Nobody has agency, terminal state. + NobodyAgency :: Agency + + +-- | A promoted data type which indicates the effective agency (which is +-- relative to current role). -- --- These lemmas are structured as proofs by contradiction, e.g. stating +data RelativeAgency where + WeHaveAgency :: RelativeAgency + TheyHaveAgency :: RelativeAgency + NobodyHasAgency :: RelativeAgency + + +-- | Compute effective agency with respect to the peer role, for client role, +-- agency is preserved, while for the server role it is flipped. +-- +type Relative :: PeerRole -> Agency -> RelativeAgency +type family Relative pr a where + Relative AsClient ClientAgency = WeHaveAgency + Relative AsClient ServerAgency = TheyHaveAgency + Relative AsClient NobodyAgency = NobodyHasAgency + Relative AsServer ClientAgency = TheyHaveAgency + Relative AsServer ServerAgency = WeHaveAgency + Relative AsServer NobodyAgency = NobodyHasAgency + + +-- | Type equality for 'RelativeAgency' which also carries information about +-- agency. It is isomorphic to a product of 'Agency' singleton and +-- @r :~: r'@, where both @r@ and @r'@ have kind 'RelativeAgency'. +-- +type ReflRelativeAgency :: Agency -> RelativeAgency -> RelativeAgency -> Type +data ReflRelativeAgency a r r' where + ReflClientAgency :: ReflRelativeAgency ClientAgency r r + ReflServerAgency :: ReflRelativeAgency ServerAgency r r + ReflNobodyAgency :: ReflRelativeAgency NobodyAgency r r + +-- $lemmas +-- +-- The 'connect' proof rely on lemmas about the protocol. Specifically they +-- rely on the property that each protocol state is labelled with the agency of +-- one peer or the other, or neither, but never both. This property is true by +-- construction, since we use a type family 'StateAgency' which maps states to +-- agencies, however we still need an evince that cases where both peer have +-- the agency or neither of them has it can be eliminated. +-- +-- The provided lemmas are structured as proofs by contradiction, e.g. stating -- \"if the client and the server have agency for this state then it leads to -- contradiction\". Contradiction is represented as the 'Void' type that has -- no values except ⊥. @@ -206,54 +282,48 @@ import Data.Void (Void) -- > StDone :: PingPong -- > -- > instance Protocol PingPong where +-- > data Message PingPong st st' where +-- > MsgPing :: Message PingPong StIdle StBusy +-- > MsgPong :: Message PingPong StBusy StIdle +-- > MsgDone :: Message PingPong StIdle StDone -- > --- > data ClientHasAgency st where --- > TokIdle :: ClientHasAgency StIdle --- > --- > data ServerHasAgency st where --- > TokBusy :: ServerHasAgency StBusy +-- > data TokState PingPong st where +-- > TokIdle :: TokState PingPong StIdle +-- > TokBusy :: TokState PingPong StBusy +-- > TokDone :: TokState PingPong StDone -- > --- > data NobodyHasAgency st where --- > TokDone :: NobodyHasAgency StDone +-- > type StateAgency StIdle = ClientAgency +-- > type StateAgency StBusy = ServerAgency +-- > type StateAgency StDone = NobodyAgency -- --- So now we can prove that if the client has agency for a state then there --- are no cases in which the server has agency. +-- The framework provides proofs which excludes that the client and server have +-- agency at the same time. -- --- > exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} +-- * 'exclusionLemma_ClientAndServerHaveAgency', +-- * 'terminationLemma_1', +-- * 'terminationLemma_2'. -- --- For this protocol there is only one state in which the client has agency, --- the idle state. By pattern matching on the state token for the server --- agency we can list all the cases in which the server also has agency for --- the idle state. There are of course none of these so we give the empty --- set of patterns. GHC can check that we are indeed correct about this. --- This also requires the @EmptyCase@ language extension. --- --- To get this completeness checking it is important to compile modules --- containing these lemmas with @-Wincomplete-patterns@, which is implied by --- @-Wall@. --- --- All three lemmas follow the same pattern. +-- These lemmas are proven for all protocols. -- -- | The protocol type class bundles up all the requirements for a typed -- protocol. -- --- Each protocol consists of three things: +-- Each protocol consists of four components: -- -- * The protocol itself, which is also expected to be the kind of the types --- of the protocol states. The class is indexed on the protocol itself. --- * The protocol messages. --- * The partition of the protocol states into those in which the client has --- agency, or the server has agency, or neither have agency. --- --- The labelling of each protocol state with the peer that has agency in that --- state is done by giving a definition to the data families --- 'ClientHasAgency', 'ServerHasAgency' and 'NobodyHasAgency'. These --- definitions are expected to be singleton-style GADTs with one constructor --- per protocol state. --- --- Each protocol state must be assigned to only one label. See --- "Network.TypedProtocol.Proofs" for more details on this point. +-- of the protocol states. The class is indexed on the protocol itself; +-- * the protocol messages; +-- * a type level map from the protocol states to agency: in each state either +-- client or server or nobody has the agency. +-- * a singleton type for the protocol states (e.g. `Sing` type family +-- instance), together with 'SingI' instances. +-- +-- It is required provide 'Sing' type family instance as well as 'SingI' +-- instances for all protocol states. These singletons allow one to pattern +-- match on the state, which is useful when defining codecs, or providing +-- informative error messages, however they are not necessary for proving +-- correctness of the protocol. -- class Protocol ps where @@ -264,204 +334,139 @@ class Protocol ps where -- data Message ps (st :: ps) (st' :: ps) - -- | Tokens for those protocol states in which the client has agency. - -- - data ClientHasAgency (st :: ps) - - -- | Tokens for those protocol states in which the server has agency. + -- | Associate an 'Agency' for each state. -- - data ServerHasAgency (st :: ps) - - -- | Tokens for terminal protocol states in which neither the client nor - -- server has agency. - -- - data NobodyHasAgency (st :: ps) - - -- | Lemma that if the client has agency for a state, there are no - -- cases in which the server has agency for the same state. - -- - exclusionLemma_ClientAndServerHaveAgency - :: forall (st :: ps). - ClientHasAgency st - -> ServerHasAgency st - -> Void - - -- | Lemma that if the nobody has agency for a state, there are no - -- cases in which the client has agency for the same state. - -- - exclusionLemma_NobodyAndClientHaveAgency - :: forall (st :: ps). - NobodyHasAgency st - -> ClientHasAgency st - -> Void - - -- | Lemma that if the nobody has agency for a state, there are no - -- cases in which the server has agency for the same state. - -- - exclusionLemma_NobodyAndServerHaveAgency - :: forall (st :: ps). - NobodyHasAgency st - -> ServerHasAgency st - -> Void - --- | Types for client and server peer roles. As protocol can be viewed from --- either client or server side. --- --- Note that technically \"client\" and \"server\" are arbitrary labels. The --- framework is completely symmetric between the two peers. --- --- This definition is only used as promoted types and kinds, never as values. --- -data PeerRole = AsClient | AsServer - --- | Singletons for the promoted 'PeerRole' types. Not directly used by the --- framework, however some times useful when writing code that is shared between --- client and server. --- -data TokPeerRole (peerRole :: PeerRole) where - TokAsClient :: TokPeerRole AsClient - TokAsServer :: TokPeerRole AsServer - --- | This data type is used to hold state tokens for states with either client --- or server agency. This GADT shows up when writing protocol peers, when --- 'Yield'ing or 'Await'ing, and when writing message encoders\/decoders. --- -data PeerHasAgency (pr :: PeerRole) (st :: ps) where - ClientAgency :: !(ClientHasAgency st) -> PeerHasAgency AsClient st - ServerAgency :: !(ServerHasAgency st) -> PeerHasAgency AsServer st + type StateAgency (st :: ps) :: Agency -instance ( forall (st' :: ps). Show (ClientHasAgency st') - , forall (st' :: ps). Show (ServerHasAgency st') - ) => Show (PeerHasAgency pr (st :: ps)) where - show (ClientAgency stok) = "ClientAgency " ++ show stok - show (ServerAgency stok) = "ServerAgency " ++ show stok - --- | A synonym for an state token in which \"our\" peer has agency. This is --- parametrised over the client or server roles. In either case the peer in --- question has agency. --- --- This shows up when we are sending messages, or dealing with encoding --- outgoing messages. --- -type WeHaveAgency (pr :: PeerRole) st = PeerHasAgency pr st - --- | A synonym for an state token in which the other peer has agency. This is --- parametrised over the client or server roles. In either case the other peer --- has agency. --- --- This shows up when we are receiving messages, or dealing with decoding --- incoming messages. --- -type TheyHaveAgency (pr :: PeerRole) st = PeerHasAgency (FlipAgency pr) st -- | A type function to flip the client and server roles. -- -type family FlipAgency (pr :: PeerRole) where +type FlipAgency :: PeerRole -> PeerRole +type family FlipAgency pr where FlipAgency AsClient = AsServer FlipAgency AsServer = AsClient --- | A description of a peer that engages in a protocol. --- --- The protocol describes what messages peers /may/ send or /must/ accept. --- A particular peer implementation decides what to actually do within the --- constraints of the protocol. --- --- Peers engage in a protocol in either the client or server role. Of course --- the client role can only interact with the serve role for the same protocol --- and vice versa. --- --- 'Peer' has several type arguments: --- --- * the protocol itself; --- * the client\/server role; --- *.the current protocol state; --- * the monad in which the peer operates; and --- * the type of any final result once the peer terminates. --- --- For example: --- --- > pingPongClientExample :: Int -> Peer PingPong AsClient StIdle m () --- > pingPongServerExample :: Peer PingPong AsServer StIdle m Int --- --- The actions that a peer can take are: --- --- * to perform local monadic effects --- * to terminate with a result (but only in a terminal protocol state) --- * to send a message (but only in a protocol state in which we have agency) --- * to wait to receive a message (but only in a protocol state in which the --- other peer has agency) --- --- In the 'Done', 'Yield' and 'Await' cases we must provide evidence of both --- the protocol state we are in and that the appropriate peer has agency. --- This takes the form of 'ClientAgency' or 'ServerAgency' applied to a --- protocol-specific state token: either a 'ClientHasAgency' or a --- 'ServerHasAgency' token for the protocol. The 'Done' state does not need --- the extra agency information. --- --- While this evidence must be provided, the types guarantee that it is not --- possible to supply incorrect evidence. --- -data Peer ps (pr :: PeerRole) (st :: ps) m a where - - -- | Perform a local monadic effect and then continue. - -- - -- Example: - -- - -- > Effect $ do - -- > ... -- actions in the monad - -- > return $ ... -- another Peer value - -- - Effect :: m (Peer ps pr st m a) - -> Peer ps pr st m a - - -- | Terminate with a result. A state token must be provided from the - -- 'NobodyHasAgency' states, so show that this is a state in which we can - -- terminate. - -- - -- Example: - -- - -- > Yield (ClientAgency TokIdle) - -- > MsgDone - -- > (Done TokDone result) - -- - Done :: !(NobodyHasAgency st) - -> a - -> Peer ps pr st m a - - -- | Send a message to the other peer and then continue. This takes the - -- message and the continuation. It also requires evidence that we have - -- agency for this protocol state and thus are allowed to send messages. - -- - -- Example: - -- - -- > Yield (ClientAgency TokIdle) MsgPing $ ... - -- - Yield :: !(WeHaveAgency pr st) - -> Message ps st st' - -> Peer ps pr st' m a - -> Peer ps pr st m a - - -- | Waits to receive a message from the other peer and then continues. - -- This takes the the continuation that is supplied with the received - -- message. It also requires evidence that the other peer has agency for - -- this protocol state and thus we are expected to wait to receive messages. - -- - -- Note that the continuation that gets supplied with the message must be - -- prepared to deal with /any/ message that is allowed in /this/ protocol - -- state. This is why the continuation /must/ be polymorphic in the target - -- state of the message (the third type argument of 'Message'). - -- - -- Example: - -- - -- > Await (ClientAgency TokIdle) $ \msg -> - -- > case msg of - -- > MsgDone -> ... - -- > MsgPing -> ... - -- - Await :: !(TheyHaveAgency pr st) - -> (forall st'. Message ps st st' -> Peer ps pr st' m a) - -> Peer ps pr st m a - - -deriving instance Functor m => Functor (Peer ps (pr :: PeerRole) (st :: ps) m) +-- | An evidence that both relative agencies are equal to 'NobodyHasAgency'. +-- +type ReflNobodyHasAgency :: RelativeAgency -> RelativeAgency -> Type +data ReflNobodyHasAgency ra ra' where + ReflNobodyHasAgency :: ReflNobodyHasAgency + NobodyHasAgency + NobodyHasAgency + + +-- | A proof that if both @Relative pr a@ and @Relative (FlipAgency pr) a@ are +-- equal then nobody has agency. In particual this lemma excludes the +-- possibility that client and server has agency at the same state. +-- +exclusionLemma_ClientAndServerHaveAgency + :: forall (pr :: PeerRole) (a :: Agency) + (ra :: RelativeAgency). + SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflNobodyHasAgency (Relative pr a) + (Relative (FlipAgency pr) a) +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency + +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflClientAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflClientAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflServerAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflServerAgency x = case x of {} + + +-- | A proof that if one side has terminated, then the other side terminated as +-- well. +-- +terminationLemma_1 + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a NobodyHasAgency (Relative (FlipAgency pr) a) + -> ReflNobodyHasAgency (Relative pr a) + (Relative (FlipAgency pr) a) +terminationLemma_1 + SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +terminationLemma_1 + SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +terminationLemma_1 SingAsClient ReflClientAgency x = case x of {} +terminationLemma_1 SingAsClient ReflServerAgency x = case x of {} +terminationLemma_1 SingAsServer ReflClientAgency x = case x of {} +terminationLemma_1 SingAsServer ReflServerAgency x = case x of {} + + +-- | Internal; only need to formulate auxiliary lemmas in the proof of +-- 'terminationLemma_2'. +-- +type FlipRelAgency :: RelativeAgency -> RelativeAgency +type family FlipRelAgency ra where + FlipRelAgency WeHaveAgency = TheyHaveAgency + FlipRelAgency TheyHaveAgency = WeHaveAgency + FlipRelAgency NobodyHasAgency = NobodyHasAgency + + +-- | Similar to 'terminationLemma_1'. +-- +-- Note: this could be proven the same way 'terminationLemma_1' is proved, but +-- instead we use two lemmas to reduce the assumptions (arguments) and we apply +-- 'terminationLemma_1'. +-- +terminationLemma_2 + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflRelativeAgency a NobodyHasAgency (Relative pr a) + -> ReflNobodyHasAgency (Relative (FlipAgency pr) a) + (Relative pr a) + +terminationLemma_2 singPeerRole refl refl' = + case terminationLemma_1 singPeerRole + (lemma_flip singPeerRole refl) + (lemma_flip' singPeerRole refl') + of x@ReflNobodyHasAgency -> x + -- note: if we'd swap arguments of the returned @ReflNobodyHasAgency@ type, + -- we wouldn't need to pattern match on the result. But in this form the + -- lemma is a symmetric version of 'terminationLemma_1'. + where + lemma_flip + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflRelativeAgency a (FlipRelAgency ra) (Relative pr a) + + lemma_flip' + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a (FlipRelAgency ra) (Relative (FlipAgency pr) a) + + -- both lemmas are identity functions: + lemma_flip SingAsClient ReflClientAgency = ReflClientAgency + lemma_flip SingAsClient ReflServerAgency = ReflServerAgency + lemma_flip SingAsClient ReflNobodyAgency = ReflNobodyAgency + lemma_flip SingAsServer ReflClientAgency = ReflClientAgency + lemma_flip SingAsServer ReflServerAgency = ReflServerAgency + lemma_flip SingAsServer ReflNobodyAgency = ReflNobodyAgency + + lemma_flip' SingAsClient ReflClientAgency = ReflClientAgency + lemma_flip' SingAsClient ReflServerAgency = ReflServerAgency + lemma_flip' SingAsClient ReflNobodyAgency = ReflNobodyAgency + lemma_flip' SingAsServer ReflClientAgency = ReflClientAgency + lemma_flip' SingAsServer ReflServerAgency = ReflServerAgency + lemma_flip' SingAsServer ReflNobodyAgency = ReflNobodyAgency + + +-- | Promoted data type which indicates if 'Peer' is used in +-- pipelined mode or not. +-- +data Pipelined where + -- | Pipelined peer which is using `c :: Type` for collecting responses + -- from a pipelined messages. + Pipelined :: Type -> Pipelined + + -- | Non-pipelined peer. + NonPipelined :: Pipelined diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index 75cff4b5..096e41e1 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -22,10 +22,11 @@ module Network.TypedProtocol.Driver , runPipelinedPeerWithDriver ) where +import Data.Singletons import Data.Void (Void) import Network.TypedProtocol.Core -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer import Control.Concurrent.Class.MonadSTM.TQueue import Control.Monad.Class.MonadAsync @@ -63,19 +64,25 @@ import Control.Monad.Class.MonadSTM -- Driver interface -- -data Driver ps dstate m = +data Driver ps (pr :: PeerRole) dstate m = Driver { - sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps). - PeerHasAgency pr st + sendMessage :: forall (st :: ps) (st' :: ps). + SingI st + => ReflRelativeAgency (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) -> Message ps st st' -> m () - , recvMessage :: forall (pr :: PeerRole) (st :: ps). - PeerHasAgency pr st + , recvMessage :: forall (st :: ps). + SingI st + => ReflRelativeAgency (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) -> dstate -> m (SomeMessage st, dstate) - , startDState :: dstate + , initialDState :: dstate } -- | When decoding a 'Message' we only know the expected \"from\" state. We @@ -98,8 +105,8 @@ data SomeMessage (st :: ps) where runPeerWithDriver :: forall ps (st :: ps) pr dstate m a. Monad m - => Driver ps dstate m - -> Peer ps pr st m a + => Driver ps pr dstate m + -> Peer ps pr NonPipelined Z st m a -> dstate -> m (a, dstate) runPeerWithDriver Driver{sendMessage, recvMessage} = @@ -107,17 +114,17 @@ runPeerWithDriver Driver{sendMessage, recvMessage} = where go :: forall st'. dstate - -> Peer ps pr st' m a + -> Peer ps pr 'NonPipelined Z st' m a -> m (a, dstate) go dstate (Effect k) = k >>= go dstate go dstate (Done _ x) = return (x, dstate) - go dstate (Yield stok msg k) = do - sendMessage stok msg + go dstate (Yield refl msg k) = do + sendMessage refl msg go dstate k - go dstate (Await stok k) = do - (SomeMessage msg, dstate') <- recvMessage stok dstate + go dstate (Await refl k) = do + (SomeMessage msg, dstate') <- recvMessage refl dstate go dstate' (k msg) -- Note that we do not complain about trailing data in any case, neither @@ -146,13 +153,13 @@ runPeerWithDriver Driver{sendMessage, recvMessage} = -- 'MonadAsync' constraint. -- runPipelinedPeerWithDriver - :: forall ps (st :: ps) pr dstate m a. + :: forall ps (st :: ps) pr dstate c m a. MonadAsync m - => Driver ps dstate m - -> PeerPipelined ps pr st m a + => Driver ps pr dstate m + -> Peer ps pr ('Pipelined c) Z st m a -> dstate -> m (a, dstate) -runPipelinedPeerWithDriver driver (PeerPipelined peer) dstate0 = do +runPipelinedPeerWithDriver driver peer dstate0 = do receiveQueue <- atomically newTQueue collectQueue <- atomically newTQueue a <- runPipelinedPeerReceiverQueue receiveQueue collectQueue driver @@ -172,7 +179,7 @@ runPipelinedPeerWithDriver driver (PeerPipelined peer) dstate0 = do data ReceiveHandler dstate ps pr m c where ReceiveHandler :: MaybeDState dstate n - -> PeerReceiver ps pr (st :: ps) (st' :: ps) m c + -> Receiver ps pr (st :: ps) (st' :: ps) m c -> ReceiveHandler dstate ps pr m c -- | The handling of trailing data here is quite subtle. Trailing data is data @@ -228,8 +235,8 @@ runPipelinedPeerSender ) => TQueue m (ReceiveHandler dstate ps pr m c) -> TQueue m (c, dstate) - -> Driver ps dstate m - -> PeerSender ps pr st Z c m a + -> Driver ps pr dstate m + -> Peer ps pr ('Pipelined c) Z st m a -> dstate -> m (a, dstate) runPipelinedPeerSender receiveQueue collectQueue @@ -242,31 +249,31 @@ runPipelinedPeerSender receiveQueue collectQueue go :: forall st' n. Nat n -> MaybeDState dstate n - -> PeerSender ps pr st' n c m a + -> Peer ps pr ('Pipelined c) n st' m a -> m (a, dstate) - go n dstate (SenderEffect k) = k >>= go n dstate - go Zero (HasDState dstate) (SenderDone _ x) = return (x, dstate) + go n dstate (Effect k) = k >>= go n dstate + go Zero (HasDState dstate) (Done _ x) = return (x, dstate) - go Zero dstate (SenderYield stok msg k) = do - sendMessage stok msg + go Zero dstate (Yield refl msg k) = do + sendMessage refl msg go Zero dstate k - go Zero (HasDState dstate) (SenderAwait stok k) = do + go Zero (HasDState dstate) (Await stok k) = do (SomeMessage msg, dstate') <- recvMessage stok dstate go Zero (HasDState dstate') (k msg) - go n dstate (SenderPipeline stok msg receiver k) = do + go n dstate (YieldPipelined refl msg receiver k) = do atomically (writeTQueue receiveQueue (ReceiveHandler dstate receiver)) - sendMessage stok msg + sendMessage refl msg go (Succ n) NoDState k - go (Succ n) NoDState (SenderCollect Nothing k) = do + go (Succ n) NoDState (Collect Nothing k) = do (c, dstate) <- atomically (readTQueue collectQueue) case n of Zero -> go Zero (HasDState dstate) (k c) Succ n' -> go (Succ n') NoDState (k c) - go (Succ n) NoDState (SenderCollect (Just k') k) = do + go (Succ n) NoDState (Collect (Just k') k) = do mc <- atomically (tryReadTQueue collectQueue) case mc of Nothing -> go (Succ n) NoDState k' @@ -283,13 +290,13 @@ runPipelinedPeerReceiverQueue ) => TQueue m (ReceiveHandler dstate ps pr m c) -> TQueue m (c, dstate) - -> Driver ps dstate m + -> Driver ps pr dstate m -> m Void runPipelinedPeerReceiverQueue receiveQueue collectQueue - driver@Driver{startDState} = do + driver@Driver{initialDState} = do threadId <- myThreadId labelThread threadId "pipelined-recevier-queue" - go startDState + go initialDState where go :: dstate -> m Void go receiverDState = do @@ -306,20 +313,20 @@ runPipelinedPeerReceiverQueue receiveQueue collectQueue runPipelinedPeerReceiver :: forall ps (st :: ps) (stdone :: ps) pr dstate m c. Monad m - => Driver ps dstate m + => Driver ps pr dstate m -> dstate - -> PeerReceiver ps pr (st :: ps) (stdone :: ps) m c + -> Receiver ps pr (st :: ps) (stdone :: ps) m c -> m (c, dstate) runPipelinedPeerReceiver Driver{recvMessage} = go where go :: forall st' st''. dstate - -> PeerReceiver ps pr st' st'' m c + -> Receiver ps pr st' st'' m c -> m (c, dstate) go dstate (ReceiverEffect k) = k >>= go dstate go dstate (ReceiverDone x) = return (x, dstate) - go dstate (ReceiverAwait stok k) = do - (SomeMessage msg, dstate') <- recvMessage stok dstate + go dstate (ReceiverAwait refl k) = do + (SomeMessage msg, dstate') <- recvMessage refl dstate go dstate' (k msg) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs new file mode 100644 index 00000000..02c88a56 --- /dev/null +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Protocol EDSL. +-- +-- __Note__: 'Network.TypedProtocol.Peer.Client.Client' and +-- 'Network.TypedProtocol.Peer.Server.Server' patterns are easier to use, +-- however this module provides in-depth documentation. +-- +module Network.TypedProtocol.Peer + ( Peer (..) + , Receiver (..) + , Outstanding + , N (..) + , Nat (Zero, Succ) + , natToInt + , unsafeIntToNat + ) where + +import Data.Kind (Type) +import Data.Singletons +import Unsafe.Coerce (unsafeCoerce) + +import Network.TypedProtocol.Core as Core + + +-- | A description of a peer that engages in a protocol. +-- +-- The protocol describes what messages peers /may/ send or /must/ accept. +-- A particular peer implementation decides what to actually do within the +-- constraints of the protocol. +-- +-- Peers engage in a protocol in either the client or server role. Of course +-- the client role can only interact with the serve role for the same protocol +-- and vice versa. +-- +-- 'Peer' has several type arguments: +-- +-- * the protocol itself; +-- * the client\/server role; +-- * whether the peer is using pipelining or not; +-- * the type level queue of future transitions not yet performed due to +-- pipelining; +-- * the current protocol state; +-- * the monad in which the peer operates (e.g. 'IO'); +-- * the stm monad, (e.g. 'STM' or it can be left abstract if 'CollectSTM' is +-- not used); +-- * the type of the final result once the peer terminates. +-- +-- For example: +-- +-- > pingPongClientExample :: Int -> Peer PingPong AsClient Pipelined Empty StIdle IO STM () +-- > pingPongServerExample :: Peer PingPong AsServer NonPipeliend Empty StIdle IO stm Int +-- +-- The actions that a non pipelining peer can take are: +-- +-- * to perform local monadic effects +-- * to terminate with a result (but only in a terminal protocol state) +-- * to send a message (but only in a protocol state in which we have agency) +-- * to wait to receive a message (but only in a protocol state in which the +-- other peer has agency) +-- +-- In addition a pipelining peer can: +-- +-- * pipeline a message, which requires upfront declaration at which state we +-- are continue. This pushes the skipped transition to the back of the +-- pipelining queue. +-- * collect a response, which removes a transition from the front of the +-- queue. It's worth to notice that this modifies the first element in the +-- queue, in particular it does not changes the queue length. +-- If there's no reply yet, collect allows to either block or continue, +-- possibly pipelining more messages. +-- * collect an identity transition (which removes the first element from the +-- queue). +-- * race between receiving a response and an stm transaction returning +-- a continuation. +-- +-- The 'Yield', 'Await', 'Done', 'YieldPipelined', 'Collect', +-- constructors require to provide an evidence that the +-- peer has agency in the current state. The types guarantee that it is not +-- possible to supply incorrect evidence, however you should use +-- 'Network.TypedProtocol.Peer.Client.Client' and +-- 'Network.TypedProtocol.Peer.Client.Server' pattern synonyms which provide +-- this evidence for you. +-- +type Peer :: forall ps + -> PeerRole + -> Pipelined + -> Outstanding + -> ps + -> (Type -> Type) + -- ^ monad's kind + -> Type + -> Type +data Peer ps pr pl n st m a where + + -- | Perform a local monadic effect and then continue. + -- + -- Example: + -- + -- > Effect $ do + -- > ... -- actions in the monad + -- > return $ ... -- another Peer value + -- + Effect + :: m (Peer ps pr pl n st m a) + -- ^ monadic continuation + -> Peer ps pr pl n st m a + + -- | Send a message to the other peer and then continue. This takes the + -- message and the continuation. It also requires evidence that we have + -- agency for this protocol state and thus are allowed to send messages. + -- + -- Example: + -- + -- > Yield ReflClientAgency MsgPing $ ... + -- + Yield + :: SingI st + => ReflRelativeAgency (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) + -- ^ agency proof + -> Message ps st st' + -- ^ protocol message + -> Peer ps pr pl Z st' m a + -- ^ continuation + -> Peer ps pr pl Z st m a + + -- | Waits to receive a message from the other peer and then continues. + -- This takes the continuation that is supplied with the received message. It + -- also requires evidence that the other peer has agency for this protocol + -- state and thus we are expected to wait to receive messages. + -- + -- Note that the continuation that gets supplied with the message must be + -- prepared to deal with /any/ message that is allowed in /this/ protocol + -- state. This is why the continuation /must/ be polymorphic in the target + -- state of the message (the third type argument of 'Message'). + -- + -- Example: + -- + -- > Await ReflClientAgency $ \msg -> + -- > case msg of + -- > MsgDone -> ... + -- > MsgPing -> ... + -- + Await + :: SingI st + => ReflRelativeAgency (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) + -- ^ agency proof + -> (forall st'. Message ps st st' + -> Peer ps pr pl Z st' m a) + -- ^ continuation + -> Peer ps pr pl Z st m a + + -- | Terminate with a result. A state token must be provided from the + -- 'NobodyHasAgency' states, to show that this is a state in which we can + -- terminate. + -- + -- Example: + -- + -- > Yield ReflClientAgency + -- > MsgDone + -- > (Done ReflNobodyAgency TokDone result) + -- + Done + :: SingI st + => ReflRelativeAgency (StateAgency st) + NobodyHasAgency + (Relative pr (StateAgency st)) + -- ^ (no) agency proof + -> a + -- ^ returned value + -> Peer ps pr pl Z st m a + + -- + -- Pipelining primitives + -- + + -- | Pipelined send which. Note that the continuation decides from which + -- state we pipeline next message, and the gap is pushed at the back of + -- the queue. + -- + YieldPipelined + :: (SingI st, SingI st') + => ReflRelativeAgency (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) + -- ^ agency proof + -> Message ps st st' + -- ^ protocol message + -> Receiver ps pr st' st'' m c + -> Peer ps pr ('Pipelined c) (S n) st'' m a + -- ^ continuation + -> Peer ps pr ('Pipelined c) n st m a + + -- | Partially collect promised transition. + -- + Collect + :: SingI st + => Maybe (Peer ps pr ('Pipelined c) (S n) st m a) + -- ^ continuation, executed if no message has arrived so far + -> (c -> Peer ps pr ('Pipelined c) n st m a) + -- ^ continuation + -> Peer ps pr ('Pipelined c) (S n) st m a + +deriving instance Functor m => Functor (Peer ps pr pl n st m) + + +-- | Receiver +type Receiver :: forall ps + -> PeerRole + -> ps + -- ^ initial state + -> ps + -- ^ final state + -> (Type -> Type) + -- ^ monad + -> Type + -- ^ returned type by the receiver + -> Type +data Receiver ps pr st stdone m c where + + ReceiverEffect :: m (Receiver ps pr st stdone m c) + -> Receiver ps pr st stdone m c + + ReceiverDone :: c -> Receiver ps pr stdone stdone m c + + ReceiverAwait :: SingI st + => ReflRelativeAgency (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) + -> (forall st'. Message ps st st' + -> Receiver ps pr st' stdone m c) + -> Receiver ps pr st stdone m c + +deriving instance Functor m => Functor (Receiver ps pr st stdone m) + +-- | Type level count of the number of outstanding pipelined yields for which +-- we have not yet collected a receiver result. Used in 'PeerSender' to ensure +-- 'SenderCollect' is only used when there are outstanding results to collect, +-- and to ensure 'SenderYield', 'SenderAwait' and 'SenderDone' are only used +-- when there are none. +-- +type Outstanding = N + +-- | A type level inductive natural number. +data N = Z | S N + +-- | A value level inductive natural number, indexed by the corresponding type +-- level natural number 'N'. +-- +-- This is often needed when writing pipelined peers to be able to count the +-- number of outstanding pipelined yields, and show to the type checker that +-- 'SenderCollect' and 'SenderDone' are being used correctly. +-- +newtype Nat (n :: N) = UnsafeInt Int + deriving Show via Int + +data IsNat (n :: N) where + IsZero :: IsNat Z + IsSucc :: Nat n -> IsNat (S n) + +toIsNat :: Nat n -> IsNat n +toIsNat (UnsafeInt 0) = unsafeCoerce IsZero +toIsNat (UnsafeInt n) = unsafeCoerce (IsSucc (UnsafeInt (pred n))) + +pattern Zero :: () => Z ~ n => Nat n +pattern Zero <- (toIsNat -> IsZero) where + Zero = UnsafeInt 0 + +pattern Succ :: () => (m ~ S n) => Nat n -> Nat m +pattern Succ n <- (toIsNat -> IsSucc n) where + Succ (UnsafeInt n) = UnsafeInt (succ n) + +{-# COMPLETE Zero, Succ #-} + +natToInt :: Nat n -> Int +natToInt (UnsafeInt n) = n + +unsafeIntToNat :: Int -> Nat n +unsafeIntToNat = UnsafeInt diff --git a/typed-protocols/src/Network/TypedProtocol/Pipelined.hs b/typed-protocols/src/Network/TypedProtocol/Pipelined.hs deleted file mode 100644 index aa0a002b..00000000 --- a/typed-protocols/src/Network/TypedProtocol/Pipelined.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -module Network.TypedProtocol.Pipelined - ( PeerPipelined (..) - , PeerSender (..) - , PeerReceiver (..) - , Outstanding - , N (..) - , Nat (Zero, Succ) - , natToInt - , unsafeIntToNat - , fmapPeerPipelined - ) where - -import Unsafe.Coerce (unsafeCoerce) - -import Network.TypedProtocol.Core - - --- | A description of a peer that engages in a protocol in a pipelined fashion. --- --- This is very much like 'Peer', and can work with the same protocol state --- machine descriptions, but allows the peer to pipeline the execution of --- the protocol. --- --- This wraps a 'PeerSender', but works for any internal collect type @c@, and --- with the starting condition of zero outstanding pipelined responses. --- -data PeerPipelined ps (pr :: PeerRole) (st :: ps) m a where - PeerPipelined :: PeerSender ps pr st Z c m a - -> PeerPipelined ps pr st m a - -deriving instance Functor m => Functor (PeerPipelined ps (pr :: PeerRole) (st :: ps) m) - --- | More general than 'fmap', as it allows to change the protocol. --- -fmapPeerPipelined :: (forall c. PeerSender ps pr st Z c m a -> PeerSender ps' pr st' Z c m b) - -> PeerPipelined ps pr st m a - -> PeerPipelined ps' pr st' m b -fmapPeerPipelined f (PeerPipelined peer) = PeerPipelined (f peer) - - --- | This is the pipelined variant of 'Peer'. --- --- In particular it has two extra type arguments: --- --- * @(n :: 'Outstanding')@ records the number of outstanding pipelined --- responses. Note that when this is 'Z' then we have no such outstanding --- responses, and we are in an equivalent situation to a normal --- non-pipelined 'Peer' --- --- * @c@ records the internal type of the pipelined responses. --- -data PeerSender ps (pr :: PeerRole) (st :: ps) (n :: Outstanding) c m a where - - -- | Same idea as normal 'Peer' 'Effect'. - SenderEffect :: m (PeerSender ps pr st n c m a) - -> PeerSender ps pr st n c m a - - -- | Same idea as normal 'Peer' 'Done'. - SenderDone :: !(NobodyHasAgency st) - -> a - -> PeerSender ps pr st Z c m a - - -- | A normal non-pipelined 'Yield'. - -- - -- Note that we cannot mix pipelined and normal synchronous syle, so this - -- can only be used when there are no outstanding pipelined responses. - -- - -- The @n ~ 'Z'@ constraint provides the type level guarantees that there - -- are no outstanding pipelined responses. - -- - SenderYield :: !(WeHaveAgency pr st) - -> Message ps st st' - -> PeerSender ps pr st' Z c m a - -> PeerSender ps pr st Z c m a - - -- | A normal non-pipelined 'Await'. Note that this can only be used . - -- - -- Note that we cannot mix pipelined and normal synchronous syle, so this - -- can only be used when there are no outstanding pipelined responses. - -- - -- The @n ~ 'Z'@ constraint provides the type level guarantees that there - -- are no outstanding pipelined responses. - -- - SenderAwait :: !(TheyHaveAgency pr st) - -> (forall st'. Message ps st st' - -> PeerSender ps pr st' Z c m a) - -> PeerSender ps pr st Z c m a - - -- | A pipelined equivalent of 'Yield'. The key difference is that instead - -- of moving into the immediate next state @st'@, the sender jumps directly - -- to state @st''@ and a seperate 'PeerReceiver' has to be supplied which - -- will get from @st'@ to @st''@. This sets up an outstanding pipelined - -- receive. The queue of outstanding pipelined receive actions 'PeerReceiver' - -- are executed in order, as messages arrive from the remote peer. - -- - -- The type records the fact that the number of outstanding pipelined - -- responses increases by one. - -- - SenderPipeline :: !(WeHaveAgency pr st) - -> Message ps st st' - -> PeerReceiver ps pr (st' :: ps) (st'' :: ps) m c - -> PeerSender ps pr (st'' :: ps) (S n) c m a - -> PeerSender ps pr (st :: ps) n c m a - - -- | Collect the result of a previous pipelined receive action. - -- - -- This (optionally) provides two choices: - -- - -- * Continue without a pipelined result - -- * Continue with a pipelined result - -- - -- Since presenting the first choice is optional, this allows expressing - -- both a blocking collect and a non-blocking collect. This allows - -- implementations to express policies such as sending a short sequence - -- of messages and then waiting for all replies, but also a maximum - -- pipelining policy that keeps a large number of messages in flight but - -- collects results eagerly. - -- - -- The type records the fact that when collecting a response, the number of - -- outstanding pipelined responses decreases by one. The type also guarantees - -- that it can only be used when there is at least one outstanding response. - -- - SenderCollect :: Maybe (PeerSender ps pr (st :: ps) (S n) c m a) - -> (c -> PeerSender ps pr (st :: ps) n c m a) - -> PeerSender ps pr (st :: ps) (S n) c m a - -deriving instance Functor m => Functor (PeerSender ps (pr :: PeerRole) (st :: ps) (n :: Outstanding) c m) - -data PeerReceiver ps (pr :: PeerRole) (st :: ps) (stdone :: ps) m c where - - ReceiverEffect :: m (PeerReceiver ps pr st stdone m c) - -> PeerReceiver ps pr st stdone m c - - ReceiverDone :: c -> PeerReceiver ps pr stdone stdone m c - - ReceiverAwait :: !(TheyHaveAgency pr st) - -> (forall st'. Message ps st st' - -> PeerReceiver ps pr st' stdone m c) - -> PeerReceiver ps pr st stdone m c - - --- | Type level count of the number of outstanding pipelined yields for which --- we have not yet collected a receiver result. Used in 'PeerSender' to ensure --- 'SenderCollect' is only used when there are outstanding results to collect, --- and to ensure 'SenderYield', 'SenderAwait' and 'SenderDone' are only used --- when there are none. --- -type Outstanding = N - --- | A type level inductive natural number. -data N = Z | S N - --- | A value level inductive natural number, indexed by the corresponding type --- level natural number 'N'. --- --- This is often needed when writing pipelined peers to be able to count the --- number of outstanding pipelined yields, and show to the type checker that --- 'SenderCollect' and 'SenderDone' are being used correctly. --- -newtype Nat (n :: N) = UnsafeInt Int - deriving Show via Int - -data IsNat (n :: N) where - IsZero :: IsNat Z - IsSucc :: Nat n -> IsNat (S n) - -toIsNat :: Nat n -> IsNat n -toIsNat (UnsafeInt 0) = unsafeCoerce IsZero -toIsNat (UnsafeInt n) = unsafeCoerce (IsSucc (UnsafeInt (pred n))) - -pattern Zero :: () => Z ~ n => Nat n -pattern Zero <- (toIsNat -> IsZero) where - Zero = UnsafeInt 0 - -pattern Succ :: () => (m ~ S n) => Nat n -> Nat m -pattern Succ n <- (toIsNat -> IsSucc n) where - Succ (UnsafeInt n) = UnsafeInt (succ n) - -{-# COMPLETE Zero, Succ #-} - -natToInt :: Nat n -> Int -natToInt (UnsafeInt n) = n - -unsafeIntToNat :: Int -> Nat n -unsafeIntToNat = UnsafeInt diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index 289c0973..e6ff9558 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- This is already implied by the -Wall in the .cabal file, but lets just be @@ -21,21 +22,22 @@ module Network.TypedProtocol.Proofs -- $about -- * Connect proof connect + , connectPipelined , TerminalStates (..) -- * Pipelining proofs -- | Additional proofs specific to the pipelining features - , connectPipelined , forgetPipelined + , promoteToPipelined -- ** Pipeline proof helpers , Queue (..) , enqueue - -- ** Auxilary functions + -- ** Auxiliary functions , pipelineInterleaving ) where -import Data.Void (absurd) +import Data.Singletons import Network.TypedProtocol.Core -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer -- $about -- @@ -73,18 +75,28 @@ import Network.TypedProtocol.Pipelined -- * It is useful for testing peer implementations against each other in a -- minimalistic setting. -- -connect :: forall ps (pr :: PeerRole) (st :: ps) m a b. - (Monad m, Protocol ps) - => Peer ps pr st m a - -> Peer ps (FlipAgency pr) st m b - -> m (a, b, TerminalStates ps) +connect + :: forall ps (pr :: PeerRole) (initSt :: ps) m a b. + (Monad m, SingI pr) + => Peer ps pr NonPipelined Z initSt m a + -> Peer ps (FlipAgency pr) NonPipelined Z initSt m b + -> m (a, b, TerminalStates ps pr) connect = go where - go :: forall (st' :: ps). - Peer ps pr st' m a - -> Peer ps (FlipAgency pr) st' m b - -> m (a, b, TerminalStates ps) - go (Done stA a) (Done stB b) = return (a, b, TerminalStates stA stB) + singPeerRole :: Sing pr + singPeerRole = sing + + go :: forall (st :: ps). + Peer ps pr NonPipelined Z st m a + -> Peer ps (FlipAgency pr) NonPipelined Z st m b + -> m (a, b, TerminalStates ps pr) + go (Done reflA a) (Done reflB b) = return (a, b, terminals) + where + terminals :: TerminalStates ps pr + terminals = TerminalStates (sing :: Sing st) + reflA + (sing :: Sing st) + reflB go (Effect a ) b = a >>= \a' -> go a' b go a (Effect b) = b >>= \b' -> go a b' go (Yield _ msg a) (Await _ b) = go a (b msg) @@ -92,215 +104,50 @@ connect = go -- By appealing to the proofs about agency for this protocol we can -- show that these other cases are impossible - go (Yield (ClientAgency stA) _ _) (Yield (ServerAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) - - go (Yield (ServerAgency stA) _ _) (Yield (ClientAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - go (Await (ServerAgency stA) _) (Await (ClientAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - go (Await (ClientAgency stA) _) (Await (ServerAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) + go (Yield reflA _ _) (Yield reflB _ _) = + case exclusionLemma_ClientAndServerHaveAgency singPeerRole reflA reflB of + ReflNobodyHasAgency -> case reflA of {} - go (Done stA _) (Yield (ServerAgency stB) _ _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB) + go (Await reflA _) (Await reflB _) = + case exclusionLemma_ClientAndServerHaveAgency singPeerRole reflA reflB of + ReflNobodyHasAgency -> case reflA of {} - go (Done stA _) (Yield (ClientAgency stB) _ _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB) + go (Done reflA _) (Yield reflB _ _) = + case terminationLemma_2 singPeerRole reflB reflA of + ReflNobodyHasAgency -> case reflB of {} - go (Done stA _) (Await (ClientAgency stB) _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB) + go (Done reflA _) (Await reflB _) = + case terminationLemma_2 singPeerRole reflB reflA of + ReflNobodyHasAgency -> case reflB of {} - go (Done stA _) (Await (ServerAgency stB) _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB) + go (Yield reflA _ _) (Done reflB _) = + case terminationLemma_1 singPeerRole reflA reflB of + ReflNobodyHasAgency -> case reflA of {} - go (Yield (ClientAgency stA) _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) - - go (Yield (ServerAgency stA) _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - go (Await (ServerAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - go (Await (ClientAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) + go (Await reflA _) (Done reflB _) = + case terminationLemma_1 singPeerRole reflA reflB of + ReflNobodyHasAgency -> case reflA of {} -- | The terminal states for the protocol. Used in 'connect' and -- 'connectPipelined' to return the states in which the peers terminated. -- -data TerminalStates ps where - TerminalStates :: forall ps (st :: ps). - NobodyHasAgency st - -> NobodyHasAgency st - -> TerminalStates ps +data TerminalStates ps (pr :: PeerRole) where + TerminalStates + :: forall ps pr (st :: ps) (st' :: ps). + Sing st + -> ReflRelativeAgency (StateAgency st) + NobodyHasAgency + (Relative pr (StateAgency st)) + -> Sing st' + -> ReflRelativeAgency (StateAgency st') + NobodyHasAgency + (Relative (FlipAgency pr) (StateAgency st')) + -> TerminalStates ps pr - --- | Analogous to 'connect' but for pipelined peers. --- --- Since pipelining allows multiple possible interleavings, we provide a --- @[Bool]@ parameter to control the choices. Each @True@ will trigger picking --- the first choice in the @SenderCollect@ construct (if possible), leading --- to more results outstanding. This can also be interpreted as a greater --- pipeline depth, or more messages in-flight. -- --- This can be exercised using a QuickCheck style generator. --- -connectPipelined :: forall ps (pr :: PeerRole) (st :: ps) m a b. - (Monad m, Protocol ps) - => [Bool] -- ^ Interleaving choices. [] gives no pipelining. - -> PeerPipelined ps pr st m a - -> Peer ps (FlipAgency pr) st m b - -> m (a, b, TerminalStates ps) - -connectPipelined cs0 (PeerPipelined peerA) peerB = - goSender cs0 EmptyQ peerA peerB - where - goSender :: forall (st' :: ps) n c. - [Bool] - -> Queue n c - -> PeerSender ps pr st' n c m a - -> Peer ps (FlipAgency pr) st' m b - -> m (a, b, TerminalStates ps) - - goSender _ EmptyQ (SenderDone stA a) (Done stB b) = return (a, b, terminals) - where terminals = TerminalStates stA stB - - goSender cs q (SenderEffect a) b = a >>= \a' -> goSender cs q a' b - goSender cs q a (Effect b) = b >>= \b' -> goSender cs q a b' - - goSender cs q (SenderYield _ msg a) (Await _ b) = goSender cs q a (b msg) - goSender cs q (SenderAwait _ a) (Yield _ msg b) = goSender cs q (a msg) b - - -- This does the receiver effects immediately, as if there were no - -- pipelining. - goSender cs q (SenderPipeline _ msg r a) (Await _ b) = - goReceiver r (b msg) >>= \(b', x) -> goSender cs (enqueue x q) a b' - - -- However we make it possible to exercise the choice the environment has - -- in the non-determinism of the pipeline interleaving of collecting - -- results. Always picking the second continuation gives the fully serial - -- order. Always picking the first leads to a maximal (and possibly - -- unbounded) number of pending replies. By using a list of bools to - -- control the choices here, we can test any other order: - goSender (True:cs) q (SenderCollect (Just a) _) b = goSender cs q a b - goSender (_:cs) (ConsQ x q) (SenderCollect _ a) b = goSender cs q (a x) b - goSender [] (ConsQ x q) (SenderCollect _ a) b = goSender [] q (a x) b - - -- Proofs that the remaining cases are impossible - goSender _ _ (SenderDone stA _) (Yield (ServerAgency stB) _ _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB) - - goSender _ _ (SenderDone stA _) (Yield (ClientAgency stB) _ _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB) - - goSender _ _ (SenderDone stA _) (Await (ClientAgency stB) _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB) - - goSender _ _ (SenderDone stA _) (Await (ServerAgency stB) _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB) - - goSender _ _ (SenderYield (ClientAgency stA) _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) - - goSender _ _ (SenderYield (ServerAgency stA) _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - goSender _ _ (SenderYield (ClientAgency stA) _ _) (Yield (ServerAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) - - goSender _ _ (SenderYield (ServerAgency stA) _ _) (Yield (ClientAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - goSender _ _ (SenderAwait (ClientAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) - - goSender _ _ (SenderAwait (ServerAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - goSender _ _ (SenderAwait (ClientAgency stA) _) (Await (ServerAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) - - goSender _ _ (SenderAwait (ServerAgency stA) _) (Await (ClientAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - goSender _ _ (SenderPipeline (ClientAgency stA) _ _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) - - goSender _ _ (SenderPipeline (ServerAgency stA) _ _ _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - goSender _ _ (SenderPipeline (ClientAgency stA) _ _ _) (Yield (ServerAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) - - goSender _ _ (SenderPipeline (ServerAgency stA) _ _ _) (Yield (ClientAgency stB) _ _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - - goReceiver :: forall (st' :: ps) (stdone :: ps) c. - PeerReceiver ps pr st' stdone m c - -> Peer ps (FlipAgency pr) st' m b - -> m (Peer ps (FlipAgency pr) stdone m b, c) - - goReceiver (ReceiverDone x) b = return (b, x) - goReceiver (ReceiverEffect a) b = a >>= \a' -> goReceiver a' b - goReceiver a (Effect b) = b >>= \b' -> goReceiver a b' - - goReceiver (ReceiverAwait _ a) (Yield _ msg b) = goReceiver (a msg) b - - - -- Proofs that the remaining cases are impossible - goReceiver (ReceiverAwait (ServerAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA) - - goReceiver (ReceiverAwait (ClientAgency stA) _) (Done stB _) = - absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA) - - goReceiver (ReceiverAwait (ServerAgency stA) _) (Await (ClientAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stB stA) - - goReceiver (ReceiverAwait (ClientAgency stA) _) (Await (ServerAgency stB) _) = - absurd (exclusionLemma_ClientAndServerHaveAgency stA stB) - - --- | Prove that we have a total conversion from pipelined peers to regular --- peers. This is a sanity property that shows that pipelining did not give --- us extra expressiveness or to break the protocol state machine. +-- Remove Pipelining -- -forgetPipelined - :: forall ps (pr :: PeerRole) (st :: ps) m a. - Functor m - => PeerPipelined ps pr st m a - -> Peer ps pr st m a -forgetPipelined (PeerPipelined peer) = goSender EmptyQ peer - where - goSender :: forall st' n c. - Queue n c - -> PeerSender ps pr st' n c m a - -> Peer ps pr st' m a - - goSender EmptyQ (SenderDone st k) = Done st k - goSender q (SenderEffect k) = Effect (goSender q <$> k) - goSender q (SenderYield st m k) = Yield st m (goSender q k) - goSender q (SenderAwait st k) = Await st (goSender q <$> k) - goSender q (SenderPipeline st m r k) = Yield st m (goReceiver q k r) - goSender (ConsQ x q) (SenderCollect _ k) = goSender q (k x) - -- Here by picking the second continuation in Collect we resolve the - -- non-determinism by always picking the fully in-order non-pipelined - -- data flow path. - - goReceiver :: forall stCurrent stNext n c. - Queue n c - -> PeerSender ps pr stNext (S n) c m a - -> PeerReceiver ps pr stCurrent stNext m c - -> Peer ps pr stCurrent m a - - goReceiver q s (ReceiverDone x) = goSender (enqueue x q) s - goReceiver q s (ReceiverEffect k) = Effect (goReceiver q s <$> k) - goReceiver q s (ReceiverAwait st k) = Await st (goReceiver q s . k) -- | A size indexed queue. This is useful for proofs, including @@ -319,12 +166,97 @@ enqueue a EmptyQ = ConsQ a EmptyQ enqueue a (ConsQ b q) = ConsQ b (enqueue a q) +-- | Prove that we have a total conversion from pipelined peers to regular +-- peers. This is a sanity property that shows that pipelining did not give +-- us extra expressiveness or to break the protocol state machine. +-- +forgetPipelined + :: forall ps (pr :: PeerRole) (st :: ps) c m a. + Functor m + => [Bool] + -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps pr 'NonPipelined Z st m a +forgetPipelined = goSender EmptyQ + where + goSender :: forall st' n. + Queue n c + -> [Bool] + -> Peer ps pr ('Pipelined c) n st' m a + -> Peer ps pr 'NonPipelined Z st' m a + + goSender EmptyQ _cs (Done refl k) = Done refl k + goSender q cs (Effect k) = Effect (goSender q cs <$> k) + goSender q cs (Yield refl m k) = Yield refl m (goSender q cs k) + goSender q cs (Await refl k) = Await refl (goSender q cs <$> k) + goSender q cs (YieldPipelined refl m r k) = Yield refl m (goReceiver q cs k r) + goSender q (True:cs') (Collect (Just k) _) = goSender q cs' k + goSender (ConsQ x q) (_:cs) (Collect _ k) = goSender q cs (k x) + goSender (ConsQ x q) cs@[] (Collect _ k) = goSender q cs (k x) + + goReceiver :: forall stCurrent stNext n. + Queue n c + -> [Bool] + -> Peer ps pr ('Pipelined c) (S n) stNext m a + -> Receiver ps pr stCurrent stNext m c + -> Peer ps pr 'NonPipelined Z stCurrent m a + + goReceiver q cs s (ReceiverDone x) = goSender (enqueue x q) cs s + goReceiver q cs s (ReceiverEffect k) = Effect (goReceiver q cs s <$> k) + goReceiver q cs s (ReceiverAwait refl k) = Await refl (goReceiver q cs s . k) + + +-- | Promote a peer to a pipelined one. +-- +-- This is a right inverse of `forgetPipelined`, e.g. +-- +-- >>> forgetPipelined . promoteToPipelined = id +-- +-- This function is useful to test a pipelined peer against a non-pipelined one +-- using `connectPipelined` function. +-- +promoteToPipelined + :: forall ps (pr :: PeerRole) st c m a. + Functor m + => Peer ps pr 'NonPipelined Z st m a + -> Peer ps pr ('Pipelined c) Z st m a +promoteToPipelined (Effect k) = Effect + $ promoteToPipelined <$> k +promoteToPipelined (Yield refl msg k) = Yield refl msg + $ promoteToPipelined k +promoteToPipelined (Await refl k) = Await refl + $ promoteToPipelined . k +promoteToPipelined (Done refl k) = Done refl k + + +-- | Analogous to 'connect' but also for pipelined peers. +-- +-- Since pipelining allows multiple possible interleavings, we provide a +-- @[Bool]@ parameter to control the choices. Each @True@ will trigger picking +-- the first choice in the @SenderCollect@ construct (if possible), leading +-- to more results outstanding. This can also be interpreted as a greater +-- pipeline depth, or more messages in-flight. +-- +-- This can be exercised using a QuickCheck style generator. +-- +connectPipelined + :: forall ps (pr :: PeerRole) + (st :: ps) c c' m a b. + (Monad m, SingI pr) + => [Bool] + -> [Bool] + -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps (FlipAgency pr) ('Pipelined c') Z st m b + -> m (a, b, TerminalStates ps pr) +connectPipelined csA csB a b = + connect (forgetPipelined csA a) + (forgetPipelined csB b) + -- | A reference specification for interleaving of requests and responses -- with pipelining, where the environment can choose whether a response is -- available yet. -- -- This also supports bounded choice where the maximum number of outstanding --- in-flight responses is limted. +-- in-flight responses is limited. -- pipelineInterleaving :: Int -- ^ Bound on outstanding responses -> [Bool] -- ^ Pipelining choices diff --git a/typed-protocols/typed-protocols.cabal b/typed-protocols/typed-protocols.cabal index 3c0d573c..73661385 100644 --- a/typed-protocols/typed-protocols.cabal +++ b/typed-protocols/typed-protocols.cabal @@ -19,8 +19,8 @@ library exposed-modules: Network.TypedProtocol , Network.TypedProtocol.Core , Network.TypedProtocol.Codec - , Network.TypedProtocol.Pipelined , Network.TypedProtocol.Driver + , Network.TypedProtocol.Peer , Network.TypedProtocol.Proofs other-extensions: GADTs @@ -32,7 +32,8 @@ library , TypeOperators , BangPatterns build-depends: base, - io-classes >= 1.0 && < 1.6 + io-classes >= 1.0 && < 1.6, + singletons >= 3.0 hs-source-dirs: src default-language: Haskell2010 From 81f2fbe018acf525343f312cb009a28b5fd20714 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 25 Jul 2024 15:42:18 +0200 Subject: [PATCH 02/39] typed-protocols: Peer pattern synonyms The client / server 'Peer's pattern synonyms make it easier to write a 'Peer'. They automatically provide the 'RelativeAgencyEq' singleton. See "Network.TypedProtocol.PingPong.Client". --- .../src/Network/TypedProtocol/Peer/Client.hs | 159 +++++++++++++++++ .../src/Network/TypedProtocol/Peer/Server.hs | 160 ++++++++++++++++++ typed-protocols/typed-protocols.cabal | 4 +- 3 files changed, 322 insertions(+), 1 deletion(-) create mode 100644 typed-protocols/src/Network/TypedProtocol/Peer/Client.hs create mode 100644 typed-protocols/src/Network/TypedProtocol/Peer/Server.hs diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs new file mode 100644 index 00000000..b6d81002 --- /dev/null +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | Bidirectional patterns for @'Peer' ps 'AsClient'@. The advantage of +-- these patterns is that they automatically provide the 'RelativeAgencyEq' +-- singleton. +-- +module Network.TypedProtocol.Peer.Client + ( Client + , pattern Effect + , pattern Yield + , pattern Await + , pattern Done + , pattern YieldPipelined + , pattern Collect + , Receiver + , pattern ReceiverEffect + , pattern ReceiverAwait + , pattern ReceiverDone + -- * re-exports + , Pipelined (..) + , Outstanding + , N (..) + , Nat (..) + ) where + +import Data.Kind (Type) +import Data.Singletons + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer (Peer, N (..), + Nat (..), Outstanding) +import qualified Network.TypedProtocol.Peer as TP + + +type Client :: forall ps + -> Pipelined + -> Outstanding + -> ps + -> (Type -> Type) + -> Type + -> Type +type Client ps pl q st m a = Peer ps AsClient pl q st m a + + +-- | Client role pattern for 'TP.Effect'. +-- +pattern Effect :: forall ps pl n st m a. + m (Client ps pl n st m a) + -- ^ monadic continuation + -> Client ps pl n st m a +pattern Effect mclient = TP.Effect mclient + + +-- | Client role pattern for 'TP.Yield' +-- +pattern Yield :: forall ps pl st m a. + () + => forall st'. + ( SingI st + , StateAgency st ~ ClientAgency + ) + => Message ps st st' + -- ^ protocol message + -> Client ps pl Z st' m a + -- ^ continuation + -> Client ps pl Z st m a +pattern Yield msg k = TP.Yield ReflClientAgency msg k + + +-- | Client role pattern for 'TP.Await' +-- +pattern Await :: forall ps pl st m a. + () + => ( SingI st + , StateAgency st ~ ServerAgency + ) + => (forall st'. Message ps st st' + -> Client ps pl Z st' m a) + -- ^ continuation + -> Client ps pl Z st m a +pattern Await k = TP.Await ReflServerAgency k + + +-- | Client role pattern for 'TP.Done' +-- +pattern Done :: forall ps pl st m a. + () + => ( SingI st + , StateAgency st ~ NobodyAgency + ) + => a + -- ^ protocol return value + -> Client ps pl Z st m a +pattern Done a = TP.Done ReflNobodyAgency a + + +-- | Client role pattern for 'TP.YieldPipelined' +-- +pattern YieldPipelined :: forall ps st n c m a. + () + => forall st' st''. + ( SingI st + , SingI st' + , StateAgency st ~ ClientAgency + ) + => Message ps st st' + -- ^ pipelined message + -> Receiver ps st' st'' m c + -> Client ps ('Pipelined c) (S n) st'' m a + -- ^ continuation + -> Client ps ('Pipelined c) n st m a +pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg receiver k + + +-- | Client role pattern for 'TP.Collect' +-- +pattern Collect :: forall ps st n c m a. + () + => SingI st + => Maybe (Client ps ('Pipelined c) (S n) st m a) + -- ^ continuation, executed if no message has arrived so far + -> (c -> Client ps ('Pipelined c) n st m a) + -- ^ continuation + -> Client ps ('Pipelined c) (S n) st m a +pattern Collect k' k = TP.Collect k' k + +{-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} + + +type Receiver ps st stdone m c = TP.Receiver ps AsClient st stdone m c + +pattern ReceiverEffect :: forall ps st stdone m c. + m (Receiver ps st stdone m c) + -> Receiver ps st stdone m c +pattern ReceiverEffect k = TP.ReceiverEffect k + +pattern ReceiverAwait :: forall ps st stdone m c. + () + => ( SingI st + , StateAgency st ~ ServerAgency + ) + => (forall st'. Message ps st st' + -> Receiver ps st' stdone m c + ) + -> Receiver ps st stdone m c +pattern ReceiverAwait k = TP.ReceiverAwait ReflServerAgency k + +pattern ReceiverDone :: forall ps stdone m c. + c + -> Receiver ps stdone stdone m c +pattern ReceiverDone c = TP.ReceiverDone c + +{-# COMPLETE ReceiverEffect, ReceiverAwait, ReceiverDone #-} diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs new file mode 100644 index 00000000..9aac1089 --- /dev/null +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | Bidirectional patterns for @'Peer' ps 'AsServer'@. The advantage of +-- these patterns is that they automatically provide the 'RelativeAgencyEq' +-- singleton. +-- +module Network.TypedProtocol.Peer.Server + ( Server + , pattern Effect + , pattern Yield + , pattern Await + , pattern Done + , pattern YieldPipelined + , pattern Collect + , Receiver + , pattern ReceiverEffect + , pattern ReceiverAwait + , pattern ReceiverDone + -- * re-exports + , Pipelined (..) + , Outstanding + , N (..) + , Nat (..) + ) where + +import Data.Kind (Type) +import Data.Singletons + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer (Peer, N (..), + Nat (..), Outstanding) +import qualified Network.TypedProtocol.Peer as TP + + +type Server :: forall ps + -> Pipelined + -> Outstanding + -> ps + -> (Type -> Type) + -> Type + -> Type +type Server ps pl q st m a = Peer ps AsServer pl q st m a + + +-- | Server role pattern for 'TP.Effect'. +-- +pattern Effect :: forall ps pl n st m a. + m (Server ps pl n st m a) + -- ^ monadic continuation + -> Server ps pl n st m a +pattern Effect mclient = TP.Effect mclient + + +-- | Server role pattern for 'TP.Yield' +-- +pattern Yield :: forall ps pl st m a. + () + => forall st'. + ( SingI st + , StateAgency st ~ ServerAgency + ) + => Message ps st st' + -- ^ protocol message + -> Server ps pl Z st' m a + -- ^ continuation + -> Server ps pl Z st m a +pattern Yield msg k = TP.Yield ReflServerAgency msg k + + +-- | Server role pattern for 'TP.Await' +-- +pattern Await :: forall ps pl st m a. + () + => ( SingI st + , StateAgency st ~ ClientAgency + ) + => (forall st'. Message ps st st' + -> Server ps pl Z st' m a) + -- ^ continuation + -> Server ps pl Z st m a +pattern Await k = TP.Await ReflClientAgency k + + +-- | Server role pattern for 'TP.Done' +-- +pattern Done :: forall ps pl st m a. + () + => ( SingI st + , StateAgency st ~ NobodyAgency + ) + => a + -- ^ protocol return value + -> Server ps pl Z st m a +pattern Done a = TP.Done ReflNobodyAgency a + + +-- | Server role pattern for 'TP.YieldPipelined' +-- +pattern YieldPipelined :: forall ps st n c m a. + () + => forall st' st''. + ( SingI st + , SingI st' + , StateAgency st ~ ServerAgency + ) + => Message ps st st' + -- ^ pipelined message + -> Receiver ps st' st'' m c + -> Server ps ('Pipelined c) (S n) st'' m a + -- ^ continuation + -> Server ps ('Pipelined c) n st m a +pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg receiver k + + +-- | Server role pattern for 'TP.Collect' +-- +pattern Collect :: forall ps st n c m a. + () + => SingI st + => Maybe (Server ps ('Pipelined c) (S n) st m a) + -- ^ continuation, executed if no message has arrived so far + -> (c -> Server ps ('Pipelined c) n st m a) + -- ^ continuation + -> Server ps ('Pipelined c) (S n) st m a +pattern Collect k' k = TP.Collect k' k + + +{-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} + + +type Receiver ps st stdone m c = TP.Receiver ps AsServer st stdone m c + +pattern ReceiverEffect :: forall ps st stdone m c. + m (Receiver ps st stdone m c) + -> Receiver ps st stdone m c +pattern ReceiverEffect k = TP.ReceiverEffect k + +pattern ReceiverAwait :: forall ps st stdone m c. + () + => ( SingI st + , StateAgency st ~ ClientAgency + ) + => (forall st'. Message ps st st' + -> Receiver ps st' stdone m c + ) + -> Receiver ps st stdone m c +pattern ReceiverAwait k = TP.ReceiverAwait ReflClientAgency k + +pattern ReceiverDone :: forall ps stdone m c. + c + -> Receiver ps stdone stdone m c +pattern ReceiverDone c = TP.ReceiverDone c + +{-# COMPLETE ReceiverEffect, ReceiverAwait, ReceiverDone #-} diff --git a/typed-protocols/typed-protocols.cabal b/typed-protocols/typed-protocols.cabal index 73661385..36c04101 100644 --- a/typed-protocols/typed-protocols.cabal +++ b/typed-protocols/typed-protocols.cabal @@ -18,9 +18,11 @@ extra-source-files: CHANGELOG.md library exposed-modules: Network.TypedProtocol , Network.TypedProtocol.Core + , Network.TypedProtocol.Peer + , Network.TypedProtocol.Peer.Client + , Network.TypedProtocol.Peer.Server , Network.TypedProtocol.Codec , Network.TypedProtocol.Driver - , Network.TypedProtocol.Peer , Network.TypedProtocol.Proofs other-extensions: GADTs From fe36759d02364dc33ff9012475d61a9ff410263f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 25 Jul 2024 15:41:22 +0200 Subject: [PATCH 03/39] typed-protocols-examples: updated --- .../src/Network/TypedProtocol/Channel.hs | 4 +- .../Network/TypedProtocol/Driver/Simple.hs | 65 +++++---- .../Network/TypedProtocol/PingPong/Client.hs | 123 +++++++++--------- .../Network/TypedProtocol/PingPong/Codec.hs | 62 ++++----- .../TypedProtocol/PingPong/Codec/CBOR.hs | 35 ++--- .../TypedProtocol/PingPong/Examples.hs | 20 +-- .../Network/TypedProtocol/PingPong/Server.hs | 9 +- .../Network/TypedProtocol/PingPong/Type.hs | 48 +++---- .../Network/TypedProtocol/ReqResp/Client.hs | 122 ++++++++--------- .../Network/TypedProtocol/ReqResp/Codec.hs | 67 +++++----- .../TypedProtocol/ReqResp/Codec/CBOR.hs | 33 ++--- .../Network/TypedProtocol/ReqResp/Examples.hs | 11 +- .../Network/TypedProtocol/ReqResp/Server.hs | 9 +- .../src/Network/TypedProtocol/ReqResp/Type.hs | 39 +++--- .../Network/TypedProtocol/PingPong/Tests.hs | 65 ++++----- .../Network/TypedProtocol/ReqResp/Tests.hs | 81 +++++++----- .../typed-protocols-examples.cabal | 1 + 17 files changed, 413 insertions(+), 381 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs index 6330fbdf..d7887f5b 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs @@ -159,8 +159,8 @@ createConnectedBufferedChannels sz = do -- | Create a pair of channels that are connected via N-place buffers. -- -- This variant /fails/ when 'send' would exceed the maximum buffer size. --- Use this variant when you want the 'PeerPipelined' to limit the pipelining --- itself, and you want to check that it does not exceed the expected level of +-- Use this variant when you want the 'Peer' to limit the pipelining itself, +-- and you want to check that it does not exceed the expected level of -- pipelining. -- -- This is primarily useful for testing protocols. diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 5f517bfe..7ccf8765 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -30,11 +31,13 @@ module Network.TypedProtocol.Driver.Simple , runDecoderWithChannel ) where +import Data.Singletons + import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec import Network.TypedProtocol.Core import Network.TypedProtocol.Driver -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow @@ -77,29 +80,35 @@ instance Show (AnyMessage ps) => Show (TraceSendRecv ps) where show (TraceRecvMsg msg) = "Recv " ++ show msg -driverSimple :: forall ps failure bytes m. +driverSimple :: forall ps pr failure bytes m. (MonadThrow m, Exception failure) => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> Driver ps (Maybe bytes) m + -> Driver ps pr (Maybe bytes) m driverSimple tracer Codec{encode, decode} channel@Channel{send} = - Driver { sendMessage, recvMessage, startDState = Nothing } + Driver { sendMessage, recvMessage, initialDState = Nothing } where - sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps). - PeerHasAgency pr st + sendMessage :: forall (st :: ps) (st' :: ps). + SingI st + => ReflRelativeAgency (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) -> Message ps st st' -> m () - sendMessage stok msg = do - send (encode stok msg) + sendMessage !_refl msg = do + send (encode msg) traceWith tracer (TraceSendMsg (AnyMessage msg)) - recvMessage :: forall (pr :: PeerRole) (st :: ps). - PeerHasAgency pr st + recvMessage :: forall (st :: ps). + SingI st + => ReflRelativeAgency (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) -> Maybe bytes -> m (SomeMessage st, Maybe bytes) - recvMessage stok trailing = do - decoder <- decode stok + recvMessage !_refl trailing = do + decoder <- decode result <- runDecoderWithChannel channel trailing decoder case result of Right x@(SomeMessage msg, _trailing') -> do @@ -114,15 +123,15 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = -- This runs the peer to completion (if the protocol allows for termination). -- runPeer - :: forall ps (st :: ps) pr failure bytes m a . + :: forall ps (st :: ps) pr failure bytes m a. (MonadThrow m, Exception failure) => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> Peer ps pr st m a - -> m a + -> Peer ps pr 'NonPipelined Z st m a + -> m (a, Maybe bytes) runPeer tracer codec channel peer = - fst <$> runPeerWithDriver driver peer (startDState driver) + runPeerWithDriver driver peer Nothing where driver = driverSimple tracer codec channel @@ -135,15 +144,15 @@ runPeer tracer codec channel peer = -- 'MonadSTM' constraint. -- runPipelinedPeer - :: forall ps (st :: ps) pr failure bytes m a. + :: forall ps (st :: ps) pr failure bytes c m a. (MonadAsync m, MonadThrow m, Exception failure) => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> PeerPipelined ps pr st m a - -> m a + -> Peer ps pr ('Pipelined c) Z st m a + -> m (a, Maybe bytes) runPipelinedPeer tracer codec channel peer = - fst <$> runPipelinedPeerWithDriver driver peer (startDState driver) + runPipelinedPeerWithDriver driver peer Nothing where driver = driverSimple tracer codec channel @@ -184,15 +193,15 @@ runConnectedPeers :: (MonadAsync m, MonadCatch m, => m (Channel m bytes, Channel m bytes) -> Tracer m (Role, TraceSendRecv ps) -> Codec ps failure m bytes - -> Peer ps pr st m a - -> Peer ps (FlipAgency pr) st m b + -> Peer ps pr 'NonPipelined Z st m a + -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b -> m (a, b) runConnectedPeers createChannels tracer codec client server = createChannels >>= \(clientChannel, serverChannel) -> - runPeer tracerClient codec clientChannel client + (fst <$> runPeer tracerClient codec clientChannel client) `concurrently` - runPeer tracerServer codec serverChannel server + (fst <$> runPeer tracerServer codec serverChannel server) where tracerClient = contramap ((,) Client) tracer tracerServer = contramap ((,) Server) tracer @@ -202,15 +211,15 @@ runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m, => m (Channel m bytes, Channel m bytes) -> Tracer m (PeerRole, TraceSendRecv ps) -> Codec ps failure m bytes - -> PeerPipelined ps pr st m a - -> Peer ps (FlipAgency pr) st m b + -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b -> m (a, b) runConnectedPeersPipelined createChannels tracer codec client server = createChannels >>= \(clientChannel, serverChannel) -> - runPipelinedPeer tracerClient codec clientChannel client + (fst <$> runPipelinedPeer tracerClient codec clientChannel client) `concurrently` - runPeer tracerServer codec serverChannel server + (fst <$> runPeer tracerServer codec serverChannel server) where tracerClient = contramap ((,) AsClient) tracer tracerServer = contramap ((,) AsServer) tracer diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs index f60be974..5c031f6d 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Network.TypedProtocol.PingPong.Client ( -- * Normal client @@ -7,13 +10,13 @@ module Network.TypedProtocol.PingPong.Client , pingPongClientPeer -- * Pipelined client , PingPongClientPipelined (..) - , PingPongSender (..) + , PingPongClientIdle (..) , pingPongClientPeerPipelined ) where import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Client import Network.TypedProtocol.PingPong.Type -import Network.TypedProtocol.Pipelined -- | A ping-pong client, on top of some effect 'm'. -- @@ -51,23 +54,23 @@ data PingPongClient m a where pingPongClientPeer :: Monad m => PingPongClient m a - -> Peer PingPong AsClient StIdle m a + -> Client PingPong NonPipelined Z StIdle m a pingPongClientPeer (SendMsgDone result) = -- We do an actual transition using 'yield', to go from the 'StIdle' to -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. - Yield (ClientAgency TokIdle) MsgDone (Done TokDone result) + Yield MsgDone (Done result) pingPongClientPeer (SendMsgPing next) = -- Send our message. - Yield (ClientAgency TokIdle) MsgPing $ + Yield MsgPing $ -- The type of our protocol means that we're now into the 'StBusy' state -- and the only thing we can do next is local effects or wait for a reply. -- We'll wait for a reply. - Await (ServerAgency TokBusy) $ \MsgPong -> + Await $ \MsgPong -> -- Now in this case there is only one possible response, and we have -- one corresponding continuation 'kPong' to handle that response. @@ -85,30 +88,31 @@ pingPongClientPeer (SendMsgPing next) = -- | A ping-pong client designed for running the 'PingPong' protocol in -- a pipelined way. -- -data PingPongClientPipelined m a where +data PingPongClientPipelined c m a where -- | A 'PingPongSender', but starting with zero outstanding pipelined -- responses, and for any internal collect type @c@. PingPongClientPipelined :: - PingPongSender Z c m a - -> PingPongClientPipelined m a + PingPongClientIdle Z c m a + -> PingPongClientPipelined c m a -data PingPongSender n c m a where - -- | - -- Send a `Ping` message but alike in `PingPongClient` do not await for the - -- resopnse, instead supply a monadic action which will run on a received +data PingPongClientIdle (n :: Outstanding) c m a where + -- | Send a `Ping` message but alike in `PingPongClient` do not await for the + -- response, instead supply a monadic action which will run on a received -- `Pong` message. + -- SendMsgPingPipelined - :: m c -- pong receive action - -> PingPongSender (S n) c m a -- continuation - -> PingPongSender n c m a + :: m c + -> PingPongClientIdle (S n) c m a -- continuation + -> PingPongClientIdle n c m a -- | Collect the result of a previous pipelined receive action. -- -- This (optionally) provides two choices: -- -- * Continue without a pipelined result - -- * Continue with a pipelined result + -- * Continue with a pipelined result, which allows to run a monadic action + -- when 'MsgPong' is received. -- -- Since presenting the first choice is optional, this allows expressing -- both a blocking collect and a non-blocking collect. This allows @@ -118,58 +122,55 @@ data PingPongSender n c m a where -- eagerly. -- CollectPipelined - :: Maybe (PingPongSender (S n) c m a) - -> (c -> PingPongSender n c m a) - -> PingPongSender (S n) c m a + :: Maybe (PingPongClientIdle (S n) c m a) + -> (c -> (PingPongClientIdle n c m a)) + -> PingPongClientIdle (S n) c m a -- | Termination of the ping-pong protocol. -- -- Note that all pipelined results must be collected before terminating. -- SendMsgDonePipelined - :: a -> PingPongSender Z c m a + :: a -> PingPongClientIdle Z c m a --- | Interpret a pipelined client as a 'PeerPipelined' on the client side of +-- | Interpret a pipelined client as a pipelined 'Peer' on the client side of -- the 'PingPong' protocol. -- pingPongClientPeerPipelined - :: Monad m - => PingPongClientPipelined m a - -> PeerPipelined PingPong AsClient StIdle m a + :: Functor m + => PingPongClientPipelined c m a + -> Client PingPong ('Pipelined c) Z StIdle m a pingPongClientPeerPipelined (PingPongClientPipelined peer) = - PeerPipelined (pingPongClientPeerSender peer) - - -pingPongClientPeerSender - :: Monad m - => PingPongSender n c m a - -> PeerSender PingPong AsClient StIdle n c m a - -pingPongClientPeerSender (SendMsgDonePipelined result) = - -- Send `MsgDone` and complete the protocol - SenderYield - (ClientAgency TokIdle) - MsgDone - (SenderDone TokDone result) - -pingPongClientPeerSender (SendMsgPingPipelined receive next) = - -- Pipelined yield: send `MsgPing`, immediately follow with the next step. - -- Await for a response in a continuation. - SenderPipeline - (ClientAgency TokIdle) - MsgPing - -- response handler - (ReceiverAwait (ServerAgency TokBusy) $ \MsgPong -> - ReceiverEffect $ do - x <- receive - return (ReceiverDone x)) - -- run the next step of the ping-pong protocol. - (pingPongClientPeerSender next) - -pingPongClientPeerSender (CollectPipelined mNone collect) = - SenderCollect - (fmap pingPongClientPeerSender mNone) - (pingPongClientPeerSender . collect) - + pingPongClientPeerIdle peer + + +pingPongClientPeerIdle + :: forall (n :: Outstanding) c m a. Functor m + => PingPongClientIdle n c m a + -> Client PingPong ('Pipelined c) n StIdle m a +pingPongClientPeerIdle = go + where + go :: forall (n' :: Outstanding). + PingPongClientIdle n' c m a + -> Client PingPong ('Pipelined c) n' StIdle m a + + go (SendMsgPingPipelined receive next) = + -- Pipelined yield: send `MsgPing`, immediately follow with the next step. + YieldPipelined + MsgPing + (ReceiverAwait $ \MsgPong -> + ReceiverEffect $ ReceiverDone <$> receive) + (go next) + + go (CollectPipelined mNone collect) = + Collect + (go <$> mNone) + (go . collect) + + go (SendMsgDonePipelined result) = + -- Send `MsgDone` and complete the protocol + Yield + MsgDone + (Done result) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs index 33ad83ca..b2d0d270 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs @@ -6,6 +6,8 @@ module Network.TypedProtocol.PingPong.Codec where +import Data.Singletons + import Network.TypedProtocol.Codec import Network.TypedProtocol.PingPong.Type @@ -16,28 +18,25 @@ codecPingPong codecPingPong = Codec{encode, decode} where - encode :: forall pr (st :: PingPong) (st' :: PingPong) - . PeerHasAgency pr st - -> Message PingPong st st' + encode :: forall (st :: PingPong) (st' :: PingPong). + Message PingPong st st' -> String - encode (ClientAgency TokIdle) MsgPing = "ping\n" - encode (ClientAgency TokIdle) MsgDone = "done\n" - encode (ServerAgency TokBusy) MsgPong = "pong\n" + encode MsgPing = "ping\n" + encode MsgDone = "done\n" + encode MsgPong = "pong\n" - decode :: forall pr (st :: PingPong) - . PeerHasAgency pr st - -> m (DecodeStep String CodecFailure m (SomeMessage st)) - decode stok = + decode :: forall (st :: PingPong). + SingI st + => m (DecodeStep String CodecFailure m (SomeMessage st)) + decode = decodeTerminatedFrame '\n' $ \str trailing -> - case (stok, str) of - (ServerAgency TokBusy, "pong") -> DecodeDone (SomeMessage MsgPong) trailing - (ClientAgency TokIdle, "ping") -> DecodeDone (SomeMessage MsgPing) trailing - (ClientAgency TokIdle, "done") -> DecodeDone (SomeMessage MsgDone) trailing + case (sing :: Sing st, str) of + (SingBusy, "pong") -> DecodeDone (SomeMessage MsgPong) trailing + (SingIdle, "ping") -> DecodeDone (SomeMessage MsgPing) trailing + (SingIdle, "done") -> DecodeDone (SomeMessage MsgDone) trailing - (ServerAgency _ , _ ) -> DecodeFail failure + (_ , _ ) -> DecodeFail failure where failure = CodecFailure ("unexpected server message: " ++ str) - (ClientAgency _ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected client message: " ++ str) decodeTerminatedFrame :: forall m a. @@ -66,28 +65,29 @@ codecPingPongId codecPingPongId = Codec{encode,decode} where - encode :: forall pr (st :: PingPong) (st' :: PingPong) - . PeerHasAgency pr st - -> Message PingPong st st' + encode :: forall (st :: PingPong) (st' :: PingPong) + . SingI st + => Message PingPong st st' -> AnyMessage PingPong - encode _ msg = AnyMessage msg + encode msg = AnyMessage msg - decode :: forall pr (st :: PingPong) - . PeerHasAgency pr st - -> m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) - decode stok = + decode :: forall (st :: PingPong) + . SingI st + => m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) + decode = + let stok :: Sing st + stok = sing in pure $ DecodePartial $ \mb -> case mb of Nothing -> return $ DecodeFail (CodecFailure "expected more data") Just (AnyMessage msg) -> return $ case (stok, msg) of - (ServerAgency TokBusy, MsgPong) -> + (SingBusy, MsgPong) -> DecodeDone (SomeMessage msg) Nothing - (ClientAgency TokIdle, MsgPing) -> + (SingIdle, MsgPing) -> DecodeDone (SomeMessage msg) Nothing - (ClientAgency TokIdle, MsgDone) -> + (SingIdle, MsgDone) -> DecodeDone (SomeMessage msg) Nothing - (ServerAgency _ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected server message: " ++ show msg) - (ClientAgency _ , _ ) -> DecodeFail failure + + (_ , _ ) -> DecodeFail failure where failure = CodecFailure ("unexpected client message: " ++ show msg ) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs index 596bdaae..cd41c36d 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs @@ -9,6 +9,7 @@ module Network.TypedProtocol.PingPong.Codec.CBOR where import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) +import Data.Singletons import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeWord) import qualified Codec.CBOR.Encoding as CBOR (Encoding, encodeWord) @@ -25,26 +26,26 @@ codecPingPong => Codec PingPong CBOR.DeserialiseFailure m ByteString codecPingPong = mkCodecCborLazyBS encodeMsg decodeMsg where - encodeMsg :: forall (pr :: PeerRole) st st'. - PeerHasAgency pr st - -> Message PingPong st st' + encodeMsg :: forall st st'. + Message PingPong st st' -> CBOR.Encoding - encodeMsg (ClientAgency TokIdle) MsgPing = CBOR.encodeWord 0 - encodeMsg (ServerAgency TokBusy) MsgPong = CBOR.encodeWord 1 - encodeMsg (ClientAgency TokIdle) MsgDone = CBOR.encodeWord 2 - - decodeMsg :: forall (pr :: PeerRole) s (st :: PingPong). - PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st) - decodeMsg stok = do + encodeMsg MsgPing = CBOR.encodeWord 0 + encodeMsg MsgPong = CBOR.encodeWord 1 + encodeMsg MsgDone = CBOR.encodeWord 2 + + decodeMsg :: forall s (st :: PingPong). + SingI st + => CBOR.Decoder s (SomeMessage st) + decodeMsg = do key <- CBOR.decodeWord - case (stok, key) of - (ClientAgency TokIdle, 0) -> return $ SomeMessage MsgPing - (ServerAgency TokBusy, 1) -> return $ SomeMessage MsgPong - (ClientAgency TokIdle, 2) -> return $ SomeMessage MsgDone + case (sing :: Sing st, key) of + (SingIdle, 0) -> return $ SomeMessage MsgPing + (SingBusy, 1) -> return $ SomeMessage MsgPong + (SingIdle, 2) -> return $ SomeMessage MsgDone -- TODO proper exceptions - (ClientAgency TokIdle, _) -> fail "codecPingPong.StIdle: unexpected key" - (ServerAgency TokBusy, _) -> fail "codecPingPong.StBusy: unexpected key" + (SingIdle, _) -> fail "codecPingPong.StIdle: unexpected key" + (SingBusy, _) -> fail "codecPingPong.StBusy: unexpected key" + (SingDone, _) -> fail "codecPingPong.StDone: unexpected key" diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Examples.hs index 126f5c72..efcc6ea8 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Examples.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Examples.hs @@ -1,14 +1,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Network.TypedProtocol.PingPong.Examples where import Network.TypedProtocol.PingPong.Client import Network.TypedProtocol.PingPong.Server -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer.Client -- | The standard stateless ping-pong server instance. @@ -66,12 +68,12 @@ pingPongClientCount n = SendMsgPing (pure (pingPongClientCount (n-1))) pingPongClientPipelinedMax :: forall m. Monad m => Int - -> PingPongClientPipelined m [Either Int Int] + -> PingPongClientPipelined Int m [Either Int Int] pingPongClientPipelinedMax c = PingPongClientPipelined (go [] Zero 0) where go :: [Either Int Int] -> Nat o -> Int - -> PingPongSender o Int m [Either Int Int] + -> PingPongClientIdle o Int m [Either Int Int] go acc o n | n < c = SendMsgPingPipelined (return n) @@ -92,12 +94,12 @@ pingPongClientPipelinedMax c = pingPongClientPipelinedMin :: forall m. Monad m => Int - -> PingPongClientPipelined m [Either Int Int] + -> PingPongClientPipelined Int m [Either Int Int] pingPongClientPipelinedMin c = PingPongClientPipelined (go [] Zero 0) where go :: [Either Int Int] -> Nat o -> Int - -> PingPongSender o Int m [Either Int Int] + -> PingPongClientIdle o Int m [Either Int Int] go acc (Succ o) n = CollectPipelined (if n < c then Just (ping acc (Succ o) n) else Nothing) @@ -107,7 +109,7 @@ pingPongClientPipelinedMin c = go acc Zero _ = SendMsgDonePipelined (reverse acc) ping :: [Either Int Int] -> Nat o -> Int - -> PingPongSender o Int m [Either Int Int] + -> PingPongClientIdle o Int m [Either Int Int] ping acc o n = SendMsgPingPipelined (return n) (go (Left n : acc) (Succ o) (succ n)) @@ -123,12 +125,12 @@ pingPongClientPipelinedMin c = pingPongClientPipelinedLimited :: forall m. Monad m => Int -> Int - -> PingPongClientPipelined m [Either Int Int] + -> PingPongClientPipelined Int m [Either Int Int] pingPongClientPipelinedLimited omax c = PingPongClientPipelined (go [] Zero 0) where go :: [Either Int Int] -> Nat o -> Int - -> PingPongSender o Int m [Either Int Int] + -> PingPongClientIdle o Int m [Either Int Int] go acc (Succ o) n = CollectPipelined (if n < c && int (Succ o) < omax then Just (ping acc (Succ o) n) @@ -139,7 +141,7 @@ pingPongClientPipelinedLimited omax c = go acc Zero _ = SendMsgDonePipelined (reverse acc) ping :: [Either Int Int] -> Nat o -> Int - -> PingPongSender o Int m [Either Int Int] + -> PingPongClientIdle o Int m [Either Int Int] ping acc o n = SendMsgPingPipelined (return n) (go (Left n : acc) (Succ o) (succ n)) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs index 67ede8eb..53f27954 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs @@ -5,6 +5,7 @@ module Network.TypedProtocol.PingPong.Server where import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Server import Network.TypedProtocol.PingPong.Type @@ -25,11 +26,11 @@ data PingPongServer m a = PingPongServer { pingPongServerPeer :: Monad m => PingPongServer m a - -> Peer PingPong AsServer StIdle m a + -> Server PingPong NonPipelined Z StIdle m a pingPongServerPeer PingPongServer{..} = -- In the 'StIdle' the server is awaiting a request message - Await (ClientAgency TokIdle) $ \req -> + Await $ \req -> -- The client got to choose between two messages and we have to handle -- either of them @@ -37,10 +38,10 @@ pingPongServerPeer PingPongServer{..} = -- The client sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Done TokDone recvMsgDone + MsgDone -> Done recvMsgDone -- The client sent us a ping request, so now we're in the 'StBusy' state -- which means it's the server's turn to send. MsgPing -> Effect $ do next <- recvMsgPing - pure $ Yield (ServerAgency TokBusy) MsgPong (pingPongServerPeer next) + pure $ Yield MsgPong (pingPongServerPeer next) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs index 128e0f1a..794e4fc2 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs @@ -8,6 +8,8 @@ module Network.TypedProtocol.PingPong.Type where +import Data.Singletons + import Network.TypedProtocol.Core @@ -35,6 +37,22 @@ data PingPong where StBusy :: PingPong StDone :: PingPong +data SPingPong (st :: PingPong) where + SingIdle :: SPingPong StIdle + SingBusy :: SPingPong StBusy + SingDone :: SPingPong StDone + +deriving instance Show (SPingPong st) + +type instance Sing = SPingPong +instance SingI StIdle where + sing = SingIdle +instance SingI StBusy where + sing = SingBusy +instance SingI StDone where + sing = SingDone + + instance Protocol PingPong where -- | The actual messages in our protocol. @@ -54,33 +72,9 @@ instance Protocol PingPong where MsgPong :: Message PingPong StBusy StIdle MsgDone :: Message PingPong StIdle StDone - -- | We have to explain to the framework what our states mean, in terms of - -- who is expected to send and receive in the different states. - -- - -- Idle states are where it is for the client to send a message. - -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency StIdle - - -- | Busy states are where the server is expected to send a reply (a pong). - -- - data ServerHasAgency st where - TokBusy :: ServerHasAgency StBusy - - -- | In the done state neither client nor server can send messages. - -- - data NobodyHasAgency st where - TokDone :: NobodyHasAgency StDone - - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} + type StateAgency StIdle = ClientAgency + type StateAgency StBusy = ServerAgency + type StateAgency StDone = NobodyAgency deriving instance Show (Message PingPong from to) - -instance Show (ClientHasAgency (st :: PingPong)) where - show TokIdle = "TokIdle" - -instance Show (ServerHasAgency (st :: PingPong)) where - show TokBusy = "TokBusy" diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs index 2d9f7693..dd8928ad 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.TypedProtocol.ReqResp.Client ( -- * Normal client @@ -7,12 +9,13 @@ module Network.TypedProtocol.ReqResp.Client , reqRespClientPeer -- * Pipelined client , ReqRespClientPipelined (..) - , ReqRespSender (..) , reqRespClientPeerPipelined + , ReqRespIdle (..) + , reqRespClientPeerIdle ) where import Network.TypedProtocol.Core -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer.Client import Network.TypedProtocol.ReqResp.Type data ReqRespClient req resp m a where @@ -29,25 +32,24 @@ data ReqRespClient req resp m a where reqRespClientPeer :: Monad m => ReqRespClient req resp m a - -> Peer (ReqResp req resp) AsClient StIdle m a + -> Client (ReqResp req resp) NonPipelined Z StIdle m a reqRespClientPeer (SendMsgDone result) = -- We do an actual transition using 'yield', to go from the 'StIdle' to -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. - Effect $ do - r <- result - return $ Yield (ClientAgency TokIdle) MsgDone (Done TokDone r) + Effect $ + Yield MsgDone . Done <$> result reqRespClientPeer (SendMsgReq req next) = -- Send our message. - Yield (ClientAgency TokIdle) (MsgReq req) $ + Yield (MsgReq req) $ -- The type of our protocol means that we're now into the 'StBusy' state -- and the only thing we can do next is local effects or wait for a reply. -- We'll wait for a reply. - Await (ServerAgency TokBusy) $ \(MsgResp resp) -> + Await $ \(MsgResp resp) -> -- Now in this case there is only one possible response, and we have -- one corresponding continuation 'kPong' to handle that response. @@ -65,73 +67,75 @@ reqRespClientPeer (SendMsgReq req next) = -- | A request-response client designed for running the 'ReqResp' protocol in -- a pipelined way. -- -data ReqRespClientPipelined req resp m a where +data ReqRespClientPipelined req resp c m a where -- | A 'PingPongSender', but starting with zero outstanding pipelined -- responses, and for any internal collect type @c@. ReqRespClientPipelined :: - ReqRespSender req resp Z c m a - -> ReqRespClientPipelined req resp m a + ReqRespIdle req resp c Z m a + -> ReqRespClientPipelined req resp c m a -data ReqRespSender req resp n c m a where +data ReqRespIdle req resp c n m a where -- | Send a `Req` message but alike in `ReqRespClient` do not await for the -- resopnse, instead supply a monadic action which will run on a received -- `Pong` message. SendMsgReqPipelined :: req - -> (resp -> m c) -- receive action - -> ReqRespSender req resp (S n) c m a -- continuation - -> ReqRespSender req resp n c m a + -> (resp -> m c) -- receive action + -> ReqRespIdle req resp c (S n) m a -- continuation + -> ReqRespIdle req resp c n m a CollectPipelined - :: Maybe (ReqRespSender req resp (S n) c m a) - -> (c -> ReqRespSender req resp n c m a) - -> ReqRespSender req resp (S n) c m a + :: Maybe (ReqRespIdle req resp c (S n) m a) + -> (c -> m (ReqRespIdle req resp c n m a)) + -> ReqRespIdle req resp c (S n) m a -- | Termination of the req-resp protocol. SendMsgDonePipelined - :: a -> ReqRespSender req resp Z c m a + :: a -> ReqRespIdle req resp c Z m a --- | Interpret a pipelined client as a 'PeerPipelined' on the client side of +-- | Interpret a pipelined client as a 'Peer' on the client side of -- the 'ReqResp' protocol. -- reqRespClientPeerPipelined - :: Monad m - => ReqRespClientPipelined req resp m a - -> PeerPipelined (ReqResp req resp) AsClient StIdle m a + :: Functor m + => ReqRespClientPipelined req resp c m a + -> Client (ReqResp req resp) ('Pipelined c) Z StIdle m a reqRespClientPeerPipelined (ReqRespClientPipelined peer) = - PeerPipelined (reqRespClientPeerSender peer) - - -reqRespClientPeerSender - :: Monad m - => ReqRespSender req resp n c m a - -> PeerSender (ReqResp req resp) AsClient StIdle n c m a - -reqRespClientPeerSender (SendMsgDonePipelined result) = - -- Send `MsgDone` and complete the protocol - SenderYield - (ClientAgency TokIdle) - MsgDone - (SenderDone TokDone result) - -reqRespClientPeerSender (SendMsgReqPipelined req receive next) = - -- Pipelined yield: send `MsgReq`, immediately follow with the next step. - -- Await for a response in a continuation. - SenderPipeline - (ClientAgency TokIdle) - (MsgReq req) - -- response handler - (ReceiverAwait (ServerAgency TokBusy) $ \(MsgResp resp) -> - ReceiverEffect $ do - x <- receive resp - return (ReceiverDone x)) - -- run the next step of the req-resp protocol. - (reqRespClientPeerSender next) - -reqRespClientPeerSender (CollectPipelined mNone collect) = - SenderCollect - (fmap reqRespClientPeerSender mNone) - (reqRespClientPeerSender . collect) - + reqRespClientPeerIdle peer + + +reqRespClientPeerIdle + :: forall req resp n c m a. + Functor m + => ReqRespIdle req resp c n m a + -> Client (ReqResp req resp) ('Pipelined c) n StIdle m a + +reqRespClientPeerIdle = go + where + go :: forall n'. + ReqRespIdle req resp c n' m a + -> Client (ReqResp req resp) ('Pipelined c) n' StIdle m a + + go (SendMsgReqPipelined req receive next) = + -- Pipelined yield: send `MsgReq`, immediately follow with the next step. + -- Await for a response in a continuation. + YieldPipelined + (MsgReq req) + (ReceiverAwait $ \(MsgResp resp) -> + ReceiverEffect $ + ReceiverDone <$> receive resp + ) + (go next) + + go (CollectPipelined mNone collect) = + Collect + (go <$> mNone) + (\c -> Effect $ go <$> collect c) + + go (SendMsgDonePipelined result) = + -- Send `MsgDone` and complete the protocol + Yield + MsgDone + (Done result) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs index 1b363463..9f7e6732 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs @@ -8,6 +8,8 @@ module Network.TypedProtocol.ReqResp.Codec where +import Data.Singletons + import Network.TypedProtocol.Codec import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) import Network.TypedProtocol.ReqResp.Type @@ -21,35 +23,32 @@ codecReqResp :: codecReqResp = Codec{encode, decode} where - encode :: forall (pr :: PeerRole) - (st :: ReqResp req resp) - (st' :: ReqResp req resp) - . PeerHasAgency pr st - -> Message (ReqResp req resp) st st' + encode :: forall req' resp' + (st :: ReqResp req' resp') + (st' :: ReqResp req' resp') + . ( Show (Message (ReqResp req' resp') st st') ) + => Message (ReqResp req' resp') st st' -> String - encode (ClientAgency TokIdle) msg = show msg ++ "\n" - encode (ServerAgency TokBusy) msg = show msg ++ "\n" + encode msg = show msg ++ "\n" - decode :: forall (pr :: PeerRole) - (st :: ReqResp req resp) - . PeerHasAgency pr st - -> m (DecodeStep String CodecFailure m (SomeMessage st)) - decode stok = + decode :: forall req' resp' m' + (st :: ReqResp req' resp') + . (Monad m', SingI st, Read req', Read resp') + => m' (DecodeStep String CodecFailure m' (SomeMessage st)) + decode = decodeTerminatedFrame '\n' $ \str trailing -> - case (stok, break (==' ') str) of - (ClientAgency TokIdle, ("MsgReq", str')) + case (sing :: Sing st, break (==' ') str) of + (SingIdle, ("MsgReq", str')) | Just resp <- readMaybe str' -> DecodeDone (SomeMessage (MsgReq resp)) trailing - (ClientAgency TokIdle, ("MsgDone", "")) + (SingIdle, ("MsgDone", "")) -> DecodeDone (SomeMessage MsgDone) trailing - (ServerAgency TokBusy, ("MsgResp", str')) + (SingBusy, ("MsgResp", str')) | Just resp <- readMaybe str' -> DecodeDone (SomeMessage (MsgResp resp)) trailing - (ServerAgency _ , _ ) -> DecodeFail failure + (_ , _ ) -> DecodeFail failure where failure = CodecFailure ("unexpected server message: " ++ str) - (ClientAgency _ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected client message: " ++ str) codecReqRespId :: @@ -59,33 +58,31 @@ codecReqRespId :: codecReqRespId = Codec{encode, decode} where - encode :: forall (pr :: PeerRole) - (st :: ReqResp req resp) + encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp) - . PeerHasAgency pr st - -> Message (ReqResp req resp) st st' + . SingI st + => Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp) - encode _ msg = AnyMessage msg + encode msg = AnyMessage msg - decode :: forall (pr :: PeerRole) - (st :: ReqResp req resp) - . PeerHasAgency pr st - -> m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) - decode stok = + decode :: forall (st :: ReqResp req resp) + . SingI st + => m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) + decode = + let stok :: Sing st + stok = sing in pure $ DecodePartial $ \mb -> case mb of Nothing -> return $ DecodeFail (CodecFailure "expected more data") Just (AnyMessage msg) -> return $ case (stok, msg) of - (ClientAgency TokIdle, MsgReq{}) + (SingIdle, MsgReq{}) -> DecodeDone (SomeMessage msg) Nothing - (ClientAgency TokIdle, MsgDone) + (SingIdle, MsgDone) -> DecodeDone (SomeMessage msg) Nothing - (ServerAgency TokBusy, MsgResp{}) + (SingBusy, MsgResp{}) -> DecodeDone (SomeMessage msg) Nothing - (ServerAgency _ , _ ) -> DecodeFail failure + (_ , _ ) -> DecodeFail failure where failure = CodecFailure ("unexpected server message: " ++ show msg) - (ClientAgency _ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected client message: " ++ show msg) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs index 23fd7a95..2df5f9ba 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs @@ -9,6 +9,7 @@ module Network.TypedProtocol.ReqResp.Codec.CBOR where import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) +import Data.Singletons import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeListLen, decodeWord) @@ -32,29 +33,29 @@ codecReqResp => Codec (ReqResp req resp) CBOR.DeserialiseFailure m ByteString codecReqResp = mkCodecCborLazyBS encodeMsg decodeMsg where - encodeMsg :: forall (pr :: PeerRole) st st'. - PeerHasAgency pr st - -> Message (ReqResp req resp) st st' + encodeMsg :: forall st st'. + Message (ReqResp req resp) st st' -> CBOR.Encoding - encodeMsg (ClientAgency TokIdle) (MsgReq req) = + encodeMsg (MsgReq req) = CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encode req - encodeMsg (ServerAgency TokBusy) (MsgResp resp) = + encodeMsg (MsgResp resp) = CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> CBOR.encode resp - encodeMsg (ClientAgency TokIdle) MsgDone = + encodeMsg MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 2 - decodeMsg :: forall (pr :: PeerRole) s (st :: ReqResp req resp). - PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st) - decodeMsg stok = do + decodeMsg :: forall s (st :: ReqResp req resp). + SingI st + => CBOR.Decoder s (SomeMessage st) + decodeMsg = do _ <- CBOR.decodeListLen key <- CBOR.decodeWord - case (stok, key) of - (ClientAgency TokIdle, 0) -> SomeMessage . MsgReq <$> CBOR.decode - (ServerAgency TokBusy, 1) -> SomeMessage . MsgResp <$> CBOR.decode - (ClientAgency TokIdle, 2) -> return $ SomeMessage MsgDone + case (sing :: Sing st, key) of + (SingIdle, 0) -> SomeMessage . MsgReq <$> CBOR.decode + (SingBusy, 1) -> SomeMessage . MsgResp <$> CBOR.decode + (SingIdle, 2) -> return $ SomeMessage MsgDone -- TODO proper exceptions - (ClientAgency TokIdle, _) -> fail "codecReqResp.StIdle: unexpected key" - (ServerAgency TokBusy, _) -> fail "codecReqResp.StBusy: unexpected key" + (SingIdle, _) -> fail "codecReqResp.StIdle: unexpected key" + (SingBusy, _) -> fail "codecReqResp.StBusy: unexpected key" + (SingDone, _) -> fail "codecReqResp.StBusy: unexpected key" diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs index c10a70ed..fe06c04e 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.TypedProtocol.ReqResp.Examples where @@ -8,7 +9,7 @@ module Network.TypedProtocol.ReqResp.Examples where import Network.TypedProtocol.ReqResp.Client import Network.TypedProtocol.ReqResp.Server -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Peer.Client -- | An example request\/response client which ignores received responses. -- @@ -67,11 +68,11 @@ reqRespClientMap = go [] reqRespClientMapPipelined :: forall req resp m. Monad m => [req] - -> ReqRespClientPipelined req resp m [resp] + -> ReqRespClientPipelined req resp resp m [resp] reqRespClientMapPipelined reqs0 = ReqRespClientPipelined (go [] Zero reqs0) where - go :: [resp] -> Nat o -> [req] -> ReqRespSender req resp o resp m [resp] + go :: [resp] -> Nat o -> [req] -> ReqRespIdle req resp resp o m [resp] go resps Zero reqs = case reqs of [] -> SendMsgDonePipelined (reverse resps) @@ -82,10 +83,10 @@ reqRespClientMapPipelined reqs0 = (case reqs of [] -> Nothing req:reqs' -> Just (sendReq resps (Succ o) req reqs')) - (\resp -> go (resp:resps) o reqs) + (\resp -> return $ go (resp:resps) o reqs) sendReq :: [resp] -> Nat o -> req -> [req] - -> ReqRespSender req resp o resp m [resp] + -> ReqRespIdle req resp resp o m [resp] sendReq resps o req reqs' = SendMsgReqPipelined req (\resp -> return resp) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs index 56c1944c..9a3e1646 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs @@ -5,6 +5,7 @@ module Network.TypedProtocol.ReqResp.Server where import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Server import Network.TypedProtocol.ReqResp.Type @@ -25,11 +26,11 @@ data ReqRespServer req resp m a = ReqRespServer { reqRespServerPeer :: Monad m => ReqRespServer req resp m a - -> Peer (ReqResp req resp) AsServer StIdle m a + -> Server (ReqResp req resp) NonPipelined Z StIdle m a reqRespServerPeer ReqRespServer{..} = -- In the 'StIdle' the server is awaiting a request message - Await (ClientAgency TokIdle) $ \msg -> + Await $ \msg -> -- The client got to choose between two messages and we have to handle -- either of them @@ -37,10 +38,10 @@ reqRespServerPeer ReqRespServer{..} = -- The client sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + MsgDone -> Effect $ Done <$> recvMsgDone -- The client sent us a ping request, so now we're in the 'StBusy' state -- which means it's the server's turn to send. MsgReq req -> Effect $ do (resp, next) <- recvMsgReq req - pure $ Yield (ServerAgency TokBusy) (MsgResp resp) (reqRespServerPeer next) + pure $ Yield (MsgResp resp) (reqRespServerPeer next) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs index 059a8ed5..2f091821 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs @@ -9,6 +9,8 @@ module Network.TypedProtocol.ReqResp.Type where +import Data.Singletons + import Network.TypedProtocol.Core @@ -17,6 +19,22 @@ data ReqResp req resp where StBusy :: ReqResp req resp StDone :: ReqResp req resp +data SReqResp (st :: ReqResp req resp) where + SingIdle :: SReqResp StIdle + SingBusy :: SReqResp StBusy + SingDone :: SReqResp StDone + +deriving instance Show (SReqResp st) + +type instance Sing = SReqResp +instance SingI StIdle where + sing = SingIdle +instance SingI StBusy where + sing = SingBusy +instance SingI StDone where + sing = SingDone + + instance Protocol (ReqResp req resp) where data Message (ReqResp req resp) from to where @@ -24,18 +42,9 @@ instance Protocol (ReqResp req resp) where MsgResp :: resp -> Message (ReqResp req resp) StBusy StIdle MsgDone :: Message (ReqResp req resp) StIdle StDone - data ClientHasAgency st where - TokIdle :: ClientHasAgency StIdle - - data ServerHasAgency st where - TokBusy :: ServerHasAgency StBusy - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency StDone - - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} + type StateAgency StIdle = ClientAgency + type StateAgency StBusy = ServerAgency + type StateAgency StDone = NobodyAgency deriving instance (Show req, Show resp) @@ -43,9 +52,3 @@ deriving instance (Show req, Show resp) deriving instance (Eq req, Eq resp) => Eq (Message (ReqResp req resp) from to) - -instance Show (ClientHasAgency (st :: ReqResp req resp)) where - show TokIdle = "TokIdle" - -instance Show (ServerHasAgency (st :: ReqResp req resp)) where - show TokBusy = "TokBusy" diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 8728d5c1..e1e41240 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +-- orphaned arbitrary instances +{-# OPTIONS_GHC -Wno-orphans #-} module Network.TypedProtocol.PingPong.Tests ( tests @@ -16,6 +17,7 @@ module Network.TypedProtocol.PingPong.Tests import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec +import Network.TypedProtocol.Core import Network.TypedProtocol.Driver.Simple import Network.TypedProtocol.Proofs @@ -31,7 +33,7 @@ import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.ST (runST) -import Control.Tracer (Tracer, nullTracer) +import Control.Tracer (nullTracer) import Data.Functor.Identity (Identity (..)) import qualified Data.ByteString.Lazy as LBS @@ -95,7 +97,7 @@ direct (SendMsgPing kPong) PingPongServer{recvMsgPing} = do directPipelined :: Monad m - => PingPongClientPipelined m a + => PingPongClientPipelined c m a -> PingPongServer m b -> m (a, b) directPipelined (PingPongClientPipelined client0) server0 = @@ -103,8 +105,8 @@ directPipelined (PingPongClientPipelined client0) server0 = where go :: Monad m => Queue n c - -> PingPongSender n c m a - -> PingPongServer m b + -> PingPongClientIdle n c m a + -> PingPongServer m b -> m (a, b) go EmptyQ (SendMsgDonePipelined clientResult) PingPongServer{recvMsgDone} = pure (clientResult, recvMsgDone) @@ -114,7 +116,7 @@ directPipelined (PingPongClientPipelined client0) server0 = x <- kPong go (enqueue x q) client' server' - go (ConsQ x q) (CollectPipelined _ k) server = + go (ConsQ x q) (CollectPipelined _ k) server = do go q (k x) server @@ -182,7 +184,9 @@ prop_connect (NonNegative n) = (pingPongClientPeer (pingPongClientCount n)) (pingPongServerPeer pingPongServerCount)) - of ((), n', TerminalStates TokDone TokDone) -> n == n' + of ((), n', TerminalStates SingDone ReflNobodyAgency + SingDone ReflNobodyAgency) -> + n == n' -- @@ -193,16 +197,18 @@ prop_connect (NonNegative n) = -- should return the interleaving of messages it sent and received. This -- will be used to exercise various interleavings in properties below. -- -connect_pipelined :: PingPongClientPipelined Identity [Either Int Int] +connect_pipelined :: PingPongClientPipelined Int Identity [Either Int Int] -> [Bool] -> (Int, [Either Int Int]) connect_pipelined client cs = case runIdentity - (connectPipelined cs + (connectPipelined cs [] (pingPongClientPeerPipelined client) - (pingPongServerPeer pingPongServerCount)) + (promoteToPipelined $ pingPongServerPeer pingPongServerCount)) - of (reqResps, n, TerminalStates TokDone TokDone) -> (n, reqResps) + of (reqResps, n, TerminalStates SingDone ReflNobodyAgency + SingDone ReflNobodyAgency) -> + (n, reqResps) -- | Using a client that forces maximum pipeling, show that irrespective of @@ -283,11 +289,10 @@ prop_connect_pipelined5 choices (Positive omax) (NonNegative n) = -- prop_channel :: (MonadSTM m, MonadAsync m, MonadCatch m) => NonNegative Int - -> Tracer m (Role, TraceSendRecv PingPong) -> m Bool -prop_channel (NonNegative n) tr = do +prop_channel (NonNegative n) = do ((), n') <- runConnectedPeers createConnectedChannels - tr + nullTracer codecPingPong client server return (n' == n) where @@ -297,22 +302,22 @@ prop_channel (NonNegative n) tr = do prop_channel_IO :: NonNegative Int -> Property prop_channel_IO n = - ioProperty (prop_channel n nullTracer) + ioProperty (prop_channel n) prop_channel_ST :: NonNegative Int -> Bool prop_channel_ST n = - runSimOrThrow (prop_channel n nullTracer) + runSimOrThrow (prop_channel n) -- -- Codec properties -- -instance Arbitrary (AnyMessageAndAgency PingPong) where +instance Arbitrary (AnyMessage PingPong) where arbitrary = elements - [ AnyMessageAndAgency (ClientAgency TokIdle) MsgPing - , AnyMessageAndAgency (ServerAgency TokBusy) MsgPong - , AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + [ AnyMessage MsgPing + , AnyMessage MsgPong + , AnyMessage MsgDone ] instance Eq (AnyMessage PingPong) where @@ -321,20 +326,20 @@ instance Eq (AnyMessage PingPong) where AnyMessage MsgDone == AnyMessage MsgDone = True _ == _ = False -prop_codec_PingPong :: AnyMessageAndAgency PingPong -> Bool +prop_codec_PingPong :: AnyMessage PingPong -> Bool prop_codec_PingPong = prop_codec runIdentity codecPingPong -prop_codec_splits2_PingPong :: AnyMessageAndAgency PingPong -> Bool +prop_codec_splits2_PingPong :: AnyMessage PingPong -> Bool prop_codec_splits2_PingPong = prop_codec_splits splits2 runIdentity codecPingPong -prop_codec_splits3_PingPong :: AnyMessageAndAgency PingPong -> Bool +prop_codec_splits3_PingPong :: AnyMessage PingPong -> Bool prop_codec_splits3_PingPong = prop_codec_splits splits3 @@ -346,13 +351,13 @@ prop_codec_splits3_PingPong = -- prop_codec_cbor_PingPong - :: AnyMessageAndAgency PingPong + :: AnyMessage PingPong -> Bool prop_codec_cbor_PingPong msg = runST $ prop_codecM CBOR.codecPingPong msg prop_codec_cbor_splits2_PingPong - :: AnyMessageAndAgency PingPong + :: AnyMessage PingPong -> Bool prop_codec_cbor_splits2_PingPong msg = runST $ prop_codec_splitsM @@ -361,7 +366,7 @@ prop_codec_cbor_splits2_PingPong msg = msg prop_codec_cbor_splits3_PingPong - :: AnyMessageAndAgency PingPong + :: AnyMessage PingPong -> Bool prop_codec_cbor_splits3_PingPong msg = runST $ prop_codec_splitsM diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 158fb825..e2d827eb 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -1,16 +1,24 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- orphaned arbitrary instances +{-# OPTIONS_GHC -Wno-orphans #-} module Network.TypedProtocol.ReqResp.Tests (tests) where import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec +import Network.TypedProtocol.Core import Network.TypedProtocol.Driver.Simple import Network.TypedProtocol.Proofs @@ -82,16 +90,16 @@ direct (SendMsgReq req kResp) ReqRespServer{recvMsgReq} = do direct client' server' -directPipelined :: Monad m - => ReqRespClientPipelined req resp m a - -> ReqRespServer req resp m b +directPipelined :: forall req resp c m a b. Monad m + => ReqRespClientPipelined req resp c m a + -> ReqRespServer req resp m b -> m (a, b) directPipelined (ReqRespClientPipelined client0) server0 = go EmptyQ client0 server0 where - go :: Monad m - => Queue n c - -> ReqRespSender req resp n c m a + go :: forall n. + Queue n c + -> ReqRespIdle req resp c n m a -> ReqRespServer req resp m b -> m (a, b) go EmptyQ (SendMsgDonePipelined clientResult) ReqRespServer{recvMsgDone} = @@ -102,8 +110,9 @@ directPipelined (ReqRespClientPipelined client0) server0 = x <- kResp resp go (enqueue x q) client' server' - go (ConsQ x q) (CollectPipelined _ k) server = - go q (k x) server + go (ConsQ resp q) (CollectPipelined _ k) server = do + client' <- k resp + go q client' server prop_direct :: (Int -> Int -> (Int, Int)) -> [Int] -> Bool @@ -136,19 +145,21 @@ prop_connect f xs = (reqRespClientPeer (reqRespClientMap xs)) (reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates TokDone TokDone) -> + of (c, s, TerminalStates SingDone ReflNobodyAgency + SingDone ReflNobodyAgency) -> (s, c) == mapAccumL f 0 xs prop_connectPipelined :: [Bool] -> (Int -> Int -> (Int, Int)) -> [Int] -> Bool prop_connectPipelined cs f xs = case runIdentity - (connectPipelined cs + (connectPipelined cs [] (reqRespClientPeerPipelined (reqRespClientMapPipelined xs)) - (reqRespServerPeer (reqRespServerMapAccumL - (\a -> pure . f a) 0))) + (promoteToPipelined $ reqRespServerPeer + (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates TokDone TokDone) -> + of (c, s, TerminalStates SingDone ReflNobodyAgency + SingDone ReflNobodyAgency) -> (s, c) == mapAccumL f 0 xs @@ -183,22 +194,22 @@ prop_channel_ST f xs = -- instance (Arbitrary req, Arbitrary resp) => - Arbitrary (AnyMessageAndAgency (ReqResp req resp)) where + Arbitrary (AnyMessage (ReqResp req resp)) where arbitrary = oneof - [ AnyMessageAndAgency (ClientAgency TokIdle) . MsgReq <$> arbitrary - , AnyMessageAndAgency (ServerAgency TokBusy) . MsgResp <$> arbitrary - , return (AnyMessageAndAgency (ClientAgency TokIdle) MsgDone) + [ AnyMessage . MsgReq <$> arbitrary + , AnyMessage . MsgResp <$> arbitrary + , return (AnyMessage MsgDone) ] - shrink (AnyMessageAndAgency a (MsgReq r)) = - [ AnyMessageAndAgency a (MsgReq r') + shrink (AnyMessage (MsgReq r)) = + [ AnyMessage (MsgReq r') | r' <- shrink r ] - shrink (AnyMessageAndAgency a (MsgResp r)) = - [ AnyMessageAndAgency a (MsgResp r') + shrink (AnyMessage (MsgResp r)) = + [ AnyMessage (MsgResp r') | r' <- shrink r ] - shrink (AnyMessageAndAgency _ MsgDone) = [] + shrink (AnyMessage MsgDone) = [] instance (Eq req, Eq resp) => Eq (AnyMessage (ReqResp req resp)) where (AnyMessage (MsgReq r1)) == (AnyMessage (MsgReq r2)) = r1 == r2 @@ -206,13 +217,13 @@ instance (Eq req, Eq resp) => Eq (AnyMessage (ReqResp req resp)) where (AnyMessage MsgDone) == (AnyMessage MsgDone) = True _ == _ = False -prop_codec_ReqResp :: AnyMessageAndAgency (ReqResp String String) -> Bool +prop_codec_ReqResp :: AnyMessage (ReqResp String String) -> Bool prop_codec_ReqResp = prop_codec runIdentity codecReqResp -prop_codec_splits2_ReqResp :: AnyMessageAndAgency (ReqResp String String) +prop_codec_splits2_ReqResp :: AnyMessage (ReqResp String String) -> Bool prop_codec_splits2_ReqResp = prop_codec_splits @@ -220,7 +231,7 @@ prop_codec_splits2_ReqResp = runIdentity codecReqResp -prop_codec_splits3_ReqResp :: AnyMessageAndAgency (ReqResp String String) +prop_codec_splits3_ReqResp :: AnyMessage (ReqResp String String) -> Bool prop_codec_splits3_ReqResp = prop_codec_splits @@ -229,13 +240,13 @@ prop_codec_splits3_ReqResp = codecReqResp prop_codec_cbor_ReqResp - :: AnyMessageAndAgency (ReqResp String String) + :: AnyMessage (ReqResp String String) -> Bool prop_codec_cbor_ReqResp msg = runST $ prop_codecM codecReqResp msg prop_codec_cbor_splits2_ReqResp - :: AnyMessageAndAgency (ReqResp String String) + :: AnyMessage (ReqResp String String) -> Bool prop_codec_cbor_splits2_ReqResp msg = runST $ prop_codec_splitsM @@ -244,7 +255,7 @@ prop_codec_cbor_splits2_ReqResp msg = msg prop_codec_cbor_splits3_ReqResp - :: AnyMessageAndAgency (ReqResp String String) + :: AnyMessage (ReqResp String String) -> Bool prop_codec_cbor_splits3_ReqResp msg = runST $ prop_codec_splitsM diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 592a9817..9bc1d40d 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -47,6 +47,7 @@ library bytestring, cborg, serialise, + singletons, contra-tracer, io-classes, si-timers, From 88d246f6b63081377c5e9cb57214231195c42fa4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 6 Sep 2021 22:38:09 +0200 Subject: [PATCH 04/39] typed-protocols: ActiveAgency The 'IsActiveAgency' type class allows to limit cases in codecs. We don't need to write decoders for inactive states, ``notActiveState` allows to reduce them. Note that the advantage of the new approach to typed-protocols is that we have access to protocol state singleton in the decoder, without distinguishing which side has the agency. This simplifies writing codecs. --- .../src/Network/TypedProtocol/Codec/CBOR.hs | 22 +++-- .../Network/TypedProtocol/Driver/Simple.hs | 10 ++- .../Network/TypedProtocol/PingPong/Codec.hs | 45 ++++++---- .../TypedProtocol/PingPong/Codec/CBOR.hs | 24 +++--- .../Network/TypedProtocol/ReqResp/Codec.hs | 29 ++++--- .../TypedProtocol/ReqResp/Codec/CBOR.hs | 22 ++--- .../Network/TypedProtocol/PingPong/Tests.hs | 12 ++- .../Network/TypedProtocol/ReqResp/Tests.hs | 12 ++- .../src/Network/TypedProtocol/Codec.hs | 81 ++++++++++-------- .../src/Network/TypedProtocol/Core.hs | 84 ++++++++++++++++++- .../src/Network/TypedProtocol/Driver.hs | 11 ++- .../src/Network/TypedProtocol/Peer.hs | 35 ++++++-- .../src/Network/TypedProtocol/Peer/Client.hs | 7 +- .../src/Network/TypedProtocol/Peer/Server.hs | 7 +- .../src/Network/TypedProtocol/Proofs.hs | 1 + 15 files changed, 287 insertions(+), 115 deletions(-) diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index aabb1fc7..65a930a5 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -47,17 +49,19 @@ mkCodecCborStrictBS => (forall (st :: ps) (st' :: ps). SingI st + => ActiveState st => Message ps st st' -> CBOR.Encoding) -> (forall (st :: ps) s. - SingI st - => CBOR.Decoder s (SomeMessage st)) + ActiveState st + => Sing st + -> CBOR.Decoder s (SomeMessage st)) -> Codec ps DeserialiseFailure m BS.ByteString mkCodecCborStrictBS cborMsgEncode cborMsgDecode = Codec { - encode = \msg -> convertCborEncoder cborMsgEncode msg, - decode = convertCborDecoder cborMsgDecode + encode = \msg -> convertCborEncoder cborMsgEncode msg, + decode = \stok -> convertCborDecoder (cborMsgDecode stok) } where convertCborEncoder :: (a -> CBOR.Encoding) -> a -> BS.ByteString @@ -101,17 +105,19 @@ mkCodecCborLazyBS => (forall (st :: ps) (st' :: ps). SingI st + => ActiveState st => Message ps st st' -> CBOR.Encoding) -> (forall (st :: ps) s. - SingI st - => CBOR.Decoder s (SomeMessage st)) + ActiveState st + => Sing st + -> CBOR.Decoder s (SomeMessage st)) -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString mkCodecCborLazyBS cborMsgEncode cborMsgDecode = Codec { - encode = \msg -> convertCborEncoder cborMsgEncode msg, - decode = convertCborDecoder cborMsgDecode + encode = \msg -> convertCborEncoder cborMsgEncode msg, + decode = \stok -> convertCborDecoder (cborMsgDecode stok) } where convertCborEncoder :: (a -> CBOR.Encoding) -> a -> LBS.ByteString diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 7ccf8765..200fbe15 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -90,7 +90,9 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = Driver { sendMessage, recvMessage, initialDState = Nothing } where sendMessage :: forall (st :: ps) (st' :: ps). - SingI st + ( SingI st + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) WeHaveAgency (Relative pr (StateAgency st)) @@ -101,14 +103,16 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = traceWith tracer (TraceSendMsg (AnyMessage msg)) recvMessage :: forall (st :: ps). - SingI st + ( SingI st + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) TheyHaveAgency (Relative pr (StateAgency st)) -> Maybe bytes -> m (SomeMessage st, Maybe bytes) recvMessage !_refl trailing = do - decoder <- decode + decoder <- decode sing result <- runDecoderWithChannel channel trailing decoder case result of Right x@(SomeMessage msg, _trailing') -> do diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs index b2d0d270..e987276a 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} @@ -9,6 +10,7 @@ module Network.TypedProtocol.PingPong.Codec where import Data.Singletons import Network.TypedProtocol.Codec +import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Type @@ -26,14 +28,18 @@ codecPingPong = encode MsgPong = "pong\n" decode :: forall (st :: PingPong). - SingI st - => m (DecodeStep String CodecFailure m (SomeMessage st)) - decode = + ActiveState st + => Sing st + -> m (DecodeStep String CodecFailure m (SomeMessage st)) + decode stok = decodeTerminatedFrame '\n' $ \str trailing -> - case (sing :: Sing st, str) of - (SingBusy, "pong") -> DecodeDone (SomeMessage MsgPong) trailing - (SingIdle, "ping") -> DecodeDone (SomeMessage MsgPing) trailing - (SingIdle, "done") -> DecodeDone (SomeMessage MsgDone) trailing + case (stok, str) of + (SingBusy, "pong") -> + DecodeDone (SomeMessage MsgPong) trailing + (SingIdle, "ping") -> + DecodeDone (SomeMessage MsgPing) trailing + (SingIdle, "done") -> + DecodeDone (SomeMessage MsgDone) trailing (_ , _ ) -> DecodeFail failure where failure = CodecFailure ("unexpected server message: " ++ str) @@ -66,17 +72,18 @@ codecPingPongId = Codec{encode,decode} where encode :: forall (st :: PingPong) (st' :: PingPong) - . SingI st + . ( SingI st + , ActiveState st + ) => Message PingPong st st' -> AnyMessage PingPong encode msg = AnyMessage msg - decode :: forall (st :: PingPong) - . SingI st - => m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) - decode = - let stok :: Sing st - stok = sing in + decode :: forall (st :: PingPong). + ActiveState st + => Sing st + -> m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) + decode stok = pure $ DecodePartial $ \mb -> case mb of Nothing -> return $ DecodeFail (CodecFailure "expected more data") @@ -89,5 +96,11 @@ codecPingPongId = (SingIdle, MsgDone) -> DecodeDone (SomeMessage msg) Nothing - (_ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected client message: " ++ show msg ) + (SingIdle, _) -> + DecodeFail failure + where failure = CodecFailure ("unexpected client message: " ++ show msg) + (SingBusy, _) -> + DecodeFail failure + where failure = CodecFailure ("unexpected server message: " ++ show msg) + + (a@SingDone, _) -> notActiveState a diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs index cd41c36d..df891f01 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} @@ -34,18 +35,17 @@ codecPingPong = mkCodecCborLazyBS encodeMsg decodeMsg encodeMsg MsgDone = CBOR.encodeWord 2 decodeMsg :: forall s (st :: PingPong). - SingI st - => CBOR.Decoder s (SomeMessage st) - decodeMsg = do + ActiveState st + => Sing st + -> CBOR.Decoder s (SomeMessage st) + decodeMsg stok = do key <- CBOR.decodeWord - case (sing :: Sing st, key) of - (SingIdle, 0) -> return $ SomeMessage MsgPing - (SingBusy, 1) -> return $ SomeMessage MsgPong - (SingIdle, 2) -> return $ SomeMessage MsgDone + case (stok, key) of + (SingIdle, 0) -> return $ SomeMessage MsgPing + (SingBusy, 1) -> return $ SomeMessage MsgPong + (SingIdle, 2) -> return $ SomeMessage MsgDone -- TODO proper exceptions - (SingIdle, _) -> fail "codecPingPong.StIdle: unexpected key" - (SingBusy, _) -> fail "codecPingPong.StBusy: unexpected key" - (SingDone, _) -> fail "codecPingPong.StDone: unexpected key" - - + (SingIdle, _) -> fail "codecPingPong.StIdle: unexpected key" + (SingBusy, _) -> fail "codecPingPong.StBusy: unexpected key" + (a@SingDone, _) -> notActiveState a diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs index 9f7e6732..5a5dfc89 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs @@ -11,6 +11,7 @@ module Network.TypedProtocol.ReqResp.Codec where import Data.Singletons import Network.TypedProtocol.Codec +import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) import Network.TypedProtocol.ReqResp.Type import Text.Read (readMaybe) @@ -33,11 +34,12 @@ codecReqResp = decode :: forall req' resp' m' (st :: ReqResp req' resp') - . (Monad m', SingI st, Read req', Read resp') - => m' (DecodeStep String CodecFailure m' (SomeMessage st)) - decode = + . (Monad m', Read req', Read resp', ActiveState st) + => Sing st + -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) + decode stok = decodeTerminatedFrame '\n' $ \str trailing -> - case (sing :: Sing st, break (==' ') str) of + case (stok, break (==' ') str) of (SingIdle, ("MsgReq", str')) | Just resp <- readMaybe str' -> DecodeDone (SomeMessage (MsgReq resp)) trailing @@ -61,16 +63,16 @@ codecReqRespId = encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp) . SingI st + => ActiveState st => Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp) encode msg = AnyMessage msg decode :: forall (st :: ReqResp req resp) - . SingI st - => m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) - decode = - let stok :: Sing st - stok = sing in + . ActiveState st + => Sing st + -> m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) + decode stok = pure $ DecodePartial $ \mb -> case mb of Nothing -> return $ DecodeFail (CodecFailure "expected more data") @@ -83,6 +85,11 @@ codecReqRespId = (SingBusy, MsgResp{}) -> DecodeDone (SomeMessage msg) Nothing - (_ , _ ) -> DecodeFail failure - where failure = CodecFailure ("unexpected server message: " ++ show msg) + (SingIdle, _) -> + DecodeFail failure + where failure = CodecFailure ("unexpected client message: " ++ show msg) + (SingBusy, _) -> + DecodeFail failure + where failure = CodecFailure ("unexpected server message: " ++ show msg) + (a@SingDone, _) -> notActiveState a diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs index 2df5f9ba..5ece5605 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} @@ -44,18 +45,19 @@ codecReqResp = mkCodecCborLazyBS encodeMsg decodeMsg CBOR.encodeListLen 1 <> CBOR.encodeWord 2 decodeMsg :: forall s (st :: ReqResp req resp). - SingI st - => CBOR.Decoder s (SomeMessage st) - decodeMsg = do + ActiveState st + => Sing st + -> CBOR.Decoder s (SomeMessage st) + decodeMsg stok = do _ <- CBOR.decodeListLen key <- CBOR.decodeWord - case (sing :: Sing st, key) of - (SingIdle, 0) -> SomeMessage . MsgReq <$> CBOR.decode - (SingBusy, 1) -> SomeMessage . MsgResp <$> CBOR.decode - (SingIdle, 2) -> return $ SomeMessage MsgDone + case (stok, key) of + (SingIdle, 0) -> SomeMessage . MsgReq <$> CBOR.decode + (SingBusy, 1) -> SomeMessage . MsgResp <$> CBOR.decode + (SingIdle, 2) -> return $ SomeMessage MsgDone -- TODO proper exceptions - (SingIdle, _) -> fail "codecReqResp.StIdle: unexpected key" - (SingBusy, _) -> fail "codecReqResp.StBusy: unexpected key" - (SingDone, _) -> fail "codecReqResp.StBusy: unexpected key" + (SingIdle, _) -> fail "codecReqResp.StIdle: unexpected key" + (SingBusy, _) -> fail "codecReqResp.StBusy: unexpected key" + (a@SingDone, _) -> notActiveState a diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index e1e41240..5ef937ea 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -184,8 +184,10 @@ prop_connect (NonNegative n) = (pingPongClientPeer (pingPongClientCount n)) (pingPongServerPeer pingPongServerCount)) - of ((), n', TerminalStates SingDone ReflNobodyAgency - SingDone ReflNobodyAgency) -> + of ((), n', TerminalStates SingDone + ReflNobodyAgency + SingDone + ReflNobodyAgency) -> n == n' @@ -206,8 +208,10 @@ connect_pipelined client cs = (pingPongClientPeerPipelined client) (promoteToPipelined $ pingPongServerPeer pingPongServerCount)) - of (reqResps, n, TerminalStates SingDone ReflNobodyAgency - SingDone ReflNobodyAgency) -> + of (reqResps, n, TerminalStates SingDone + ReflNobodyAgency + SingDone + ReflNobodyAgency) -> (n, reqResps) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index e2d827eb..71dad165 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -145,8 +145,10 @@ prop_connect f xs = (reqRespClientPeer (reqRespClientMap xs)) (reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates SingDone ReflNobodyAgency - SingDone ReflNobodyAgency) -> + of (c, s, TerminalStates SingDone + ReflNobodyAgency + SingDone + ReflNobodyAgency) -> (s, c) == mapAccumL f 0 xs @@ -158,8 +160,10 @@ prop_connectPipelined cs f xs = (promoteToPipelined $ reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates SingDone ReflNobodyAgency - SingDone ReflNobodyAgency) -> + of (c, s, TerminalStates SingDone + ReflNobodyAgency + SingDone + ReflNobodyAgency) -> (s, c) == mapAccumL f 0 xs diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index a337c32e..fb7473d6 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- @UndecidableInstances@ extension is required for defining @Show@ instance of -- @'AnyMessage'@ and @'AnyMessage'@. -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Network.TypedProtocol.Codec ( -- * Defining and using Codecs @@ -19,6 +22,11 @@ module Network.TypedProtocol.Codec , isoCodec , mapFailureCodec -- ** Related types + , IsActiveState (..) + , ActiveState + , ActiveAgency + , ActiveAgency' (..) + , notActiveState , PeerRole (..) , SomeMessage (..) , CodecFailure (..) @@ -36,7 +44,7 @@ module Network.TypedProtocol.Codec , prop_codec_binary_compat , prop_codecs_compatM , prop_codecs_compat - , SamePeerHasAgency (..) + , SomeState (..) ) where import Control.Exception (Exception) @@ -45,9 +53,10 @@ import Data.Monoid (All (..)) import Data.Singletons -import Network.TypedProtocol.Core (PeerRole (..), Protocol (..)) +import Network.TypedProtocol.Core import Network.TypedProtocol.Driver (SomeMessage (..)) + -- | A codec for a 'Protocol' handles the encoding and decoding of typed -- protocol messages. This is typically used when sending protocol messages -- over untyped channels. The codec chooses the exact encoding, for example @@ -123,12 +132,14 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) data Codec ps failure m bytes = Codec { encode :: forall (st :: ps) (st' :: ps). SingI st + => ActiveState st => Message ps st st' -> bytes, decode :: forall (st :: ps). - SingI st - => m (DecodeStep bytes failure m (SomeMessage st)) + ActiveState st + => Sing st + -> m (DecodeStep bytes failure m (SomeMessage st)) } hoistCodec @@ -137,7 +148,7 @@ hoistCodec -> Codec ps failure m bytes -> Codec ps failure n bytes hoistCodec nat codec = codec - { decode = fmap (hoistDecodeStep nat) . nat $ decode codec + { decode = fmap (hoistDecodeStep nat) . nat . decode codec } isoCodec :: Functor m @@ -147,7 +158,7 @@ isoCodec :: Functor m -> Codec ps failure m bytes' isoCodec f finv Codec {encode, decode} = Codec { encode = \msg -> f $ encode msg, - decode = isoDecodeStep f finv <$> decode + decode = \tok -> isoDecodeStep f finv <$> decode tok } mapFailureCodec @@ -157,7 +168,7 @@ mapFailureCodec -> Codec ps failure' m bytes mapFailureCodec f Codec {encode, decode} = Codec { encode = encode, - decode = mapFailureDecodeStep f <$> decode + decode = \tok -> mapFailureDecodeStep f <$> decode tok } -- The types here are pretty fancy. The decode is polymorphic in the protocol @@ -284,7 +295,9 @@ runDecoderPure runM decoder bs = runM (runDecoder bs =<< decoder) -- data AnyMessage ps where AnyMessage :: forall ps (st :: ps) (st' :: ps). - SingI st + ( SingI st + , ActiveState st + ) => Message ps (st :: ps) (st' :: ps) -> AnyMessage ps @@ -306,7 +319,7 @@ prop_codecM -> AnyMessage ps -> m Bool prop_codecM Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do - r <- decode >>= runDecoder [encode msg] + r <- decode sing >>= runDecoder [encode msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $ AnyMessage msg' == AnyMessage msg Left _ -> return False @@ -345,7 +358,7 @@ prop_codec_splitsM prop_codec_splitsM splits Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do and <$> sequence - [ do r <- decode >>= runDecoder bytes' + [ do r <- decode sing >>= runDecoder bytes' case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! AnyMessage msg' == AnyMessage msg Left _ -> return False @@ -373,12 +386,12 @@ prop_codec_splits splits runM codec msg = -- Used for the existential @st :: ps@ parameter when expressing that for each -- value of 'PeerHasAgency' for protocol A, there is a corresponding -- 'PeerHasAgency' for protocol B of some @st :: ps@. -data SamePeerHasAgency (pr :: PeerRole) (ps :: Type) where - SamePeerHasAgency - :: forall (pr :: PeerRole) ps (st :: ps) proxy. - SingI st - => !(proxy st) - -> SamePeerHasAgency pr ps +data SomeState (ps :: Type) where + SomeState + :: forall ps (st :: ps). + ActiveState st + => Sing st + -> SomeState ps -- | Binary compatibility of two protocols -- @@ -400,7 +413,7 @@ prop_codec_binary_compatM ) => Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall pr (stA :: psA). Sing stA -> SamePeerHasAgency pr psB) + -> (forall (stA :: psA). ActiveState stA => Sing stA -> SomeState psB) -- ^ The states of A map directly of states of B. -> AnyMessage psA -> m Bool @@ -410,18 +423,18 @@ prop_codec_binary_compatM let stokA :: Sing stA stokA = sing in case stokEq stokA of - SamePeerHasAgency (_ :: proxy stB) -> do + SomeState (stokB :: Sing stB) -> do -- 1. let bytesA = encode codecA msgA -- 2. - r1 <- decode codecB >>= runDecoder [bytesA] + r1 <- decode codecB stokB >>= runDecoder [bytesA] case r1 :: Either failure (SomeMessage stB) of Left _ -> return False Right (SomeMessage msgB) -> do -- 3. let bytesB = encode codecB msgB -- 4. - r2 <- decode codecA >>= runDecoder [bytesB] + r2 <- decode codecA (sing :: Sing stA) >>= runDecoder [bytesB] case r2 :: Either failure (SomeMessage stA) of Left _ -> return False Right (SomeMessage msgA') -> return $ AnyMessage msgA' == AnyMessage msgA @@ -435,7 +448,7 @@ prop_codec_binary_compat => (forall a. m a -> a) -> Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall pr (stA :: psA). Sing stA -> SamePeerHasAgency pr psB) + -> (forall (stA :: psA). Sing stA -> SomeState psB) -> AnyMessage psA -> Bool prop_codec_binary_compat runM codecA codecB stokEq msgA = @@ -458,11 +471,11 @@ prop_codecs_compatM -> m Bool prop_codecs_compatM codecA codecB (AnyMessage (msg :: Message ps st st')) = - getAll <$> do r <- decode codecB >>= runDecoder [encode codecA msg] + getAll <$> do r <- decode codecB (sing :: Sing st) >>= runDecoder [encode codecA msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False - <> do r <- decode codecA >>= runDecoder [encode codecB msg] + <> do r <- decode codecA (sing :: Sing st) >>= runDecoder [encode codecB msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 70b1e028..314ea82c 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -1,15 +1,22 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} +-- need for 'Show' instance of 'ProtocolState' +{-# LANGUAGE UndecidableInstances #-} -- | This module defines the core of the typed protocol framework. @@ -26,11 +33,17 @@ module Network.TypedProtocol.Core , PeerRole (..) , SingPeerRole (..) , Agency (..) + , SingAgency (..) , RelativeAgency (..) , Relative , ReflRelativeAgency (..) , FlipAgency , Pipelined (..) + , ActiveAgency + , ActiveAgency' (..) + , IsActiveState (..) + , ActiveState + , notActiveState -- * Protocol proofs and tests -- $tests -- $lemmas @@ -40,7 +53,7 @@ module Network.TypedProtocol.Core , ReflNobodyHasAgency (..) ) where -import Data.Kind (Type) +import Data.Kind (Constraint, Type) import Data.Singletons @@ -207,6 +220,8 @@ data SingPeerRole pr where SingAsClient :: SingPeerRole AsClient SingAsServer :: SingPeerRole AsServer +deriving instance Show (SingPeerRole pr) + type instance Sing = SingPeerRole instance SingI AsClient where sing = SingAsClient @@ -226,6 +241,21 @@ data Agency where -- | Nobody has agency, terminal state. NobodyAgency :: Agency +type SingAgency :: Agency -> Type +data SingAgency a where + SingClientAgency :: SingAgency ClientAgency + SingServerAgency :: SingAgency ServerAgency + SingNobodyAgency :: SingAgency NobodyAgency + +deriving instance Show (SingAgency a) + +type instance Sing = SingAgency +instance SingI ClientAgency where + sing = SingClientAgency +instance SingI ServerAgency where + sing = SingServerAgency +instance SingI NobodyAgency where + sing = SingNobodyAgency -- | A promoted data type which indicates the effective agency (which is -- relative to current role). @@ -338,6 +368,56 @@ class Protocol ps where -- type StateAgency (st :: ps) :: Agency +type ActiveAgency' :: ps -> Agency -> Type +data ActiveAgency' st agency where + ClientHasAgency :: StateAgency st ~ ClientAgency + => ActiveAgency' st ClientAgency + ServerHasAgency :: StateAgency st ~ ServerAgency + => ActiveAgency' st ServerAgency + +deriving instance Show (ActiveAgency' st agency) + +type ActiveAgency :: ps -> Type +type ActiveAgency st = ActiveAgency' st (StateAgency st) + +-- | A type class which restricts states to ones that have `ClientAgency` or +-- `ServerAgency`, excluding `NobodyAgency`. +-- +-- One can use `notActive' to eliminate cases for which both @'IsActiveState' +-- st@ is in scope and for which we have an evidence that the state is not +-- active (i.e. a singleton). This is useful when writing a 'Codec'. +-- +class IsActiveState st (agency :: Agency) where + activeAgency :: ActiveAgency' st agency + +instance ClientAgency ~ StateAgency st + => IsActiveState st ClientAgency where + activeAgency = ClientHasAgency +instance ServerAgency ~ StateAgency st + => IsActiveState st ServerAgency where + activeAgency = ServerHasAgency + +type ActiveState :: ps -> Constraint +type ActiveState st = IsActiveState st (StateAgency st) + + +-- | This is useful function to eliminate cases where the `ActiveState st` is +-- provided but we are given a state in which neither side has agency +-- (`NobodyAgency`). For example when writing a codec, we only need to encode +-- / decode messages which are in active states, but to make such functions +-- total, `notActiveState` needs to be used to eliminate the states in which +-- nobody has agency. +-- +-- A good analogy for this function is @'Data.Void.absurd' :: 'Void' -> a@. +-- +notActiveState :: forall ps (st :: ps). + StateAgency st ~ NobodyAgency + => ActiveState st + => Sing st + -> forall a. a +notActiveState (_ :: Sing st) = + case activeAgency :: ActiveAgency st of {} + -- | A type function to flip the client and server roles. -- @@ -357,7 +437,7 @@ data ReflNobodyHasAgency ra ra' where -- | A proof that if both @Relative pr a@ and @Relative (FlipAgency pr) a@ are --- equal then nobody has agency. In particual this lemma excludes the +-- equal then nobody has agency. In particular this lemma excludes the -- possibility that client and server has agency at the same state. -- exclusionLemma_ClientAndServerHaveAgency diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index 096e41e1..ad7b18f0 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} @@ -68,6 +69,8 @@ data Driver ps (pr :: PeerRole) dstate m = Driver { sendMessage :: forall (st :: ps) (st' :: ps). SingI st + => SingI st' + => ActiveState st => ReflRelativeAgency (StateAgency st) WeHaveAgency (Relative pr (StateAgency st)) @@ -76,6 +79,7 @@ data Driver ps (pr :: PeerRole) dstate m = , recvMessage :: forall (st :: ps). SingI st + => ActiveState st => ReflRelativeAgency (StateAgency st) TheyHaveAgency (Relative pr (StateAgency st)) @@ -85,13 +89,18 @@ data Driver ps (pr :: PeerRole) dstate m = , initialDState :: dstate } + -- | When decoding a 'Message' we only know the expected \"from\" state. We -- cannot know the \"to\" state as this depends on the message we decode. To -- resolve this we use the 'SomeMessage' wrapper which uses an existential -- type to hide the \"to"\ state. -- data SomeMessage (st :: ps) where - SomeMessage :: Message ps st st' -> SomeMessage st + SomeMessage :: ( SingI st + , SingI st' + , ActiveState st + ) + => Message ps st st' -> SomeMessage st -- diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 02c88a56..94eb89a6 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -112,7 +113,8 @@ data Peer ps pr pl n st m a where -- > return $ ... -- another Peer value -- Effect - :: m (Peer ps pr pl n st m a) + :: forall ps pr pl n st m a. + m (Peer ps pr pl n st m a) -- ^ monadic continuation -> Peer ps pr pl n st m a @@ -125,7 +127,11 @@ data Peer ps pr pl n st m a where -- > Yield ReflClientAgency MsgPing $ ... -- Yield - :: SingI st + :: forall ps pr pl (st :: ps) (st' :: ps) m a. + ( SingI st + , SingI st' + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) WeHaveAgency (Relative pr (StateAgency st)) @@ -154,12 +160,15 @@ data Peer ps pr pl n st m a where -- > MsgPing -> ... -- Await - :: SingI st + :: forall ps pr pl (st :: ps) m a. + ( SingI st + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) TheyHaveAgency (Relative pr (StateAgency st)) -- ^ agency proof - -> (forall st'. Message ps st st' + -> (forall (st' :: ps). Message ps st st' -> Peer ps pr pl Z st' m a) -- ^ continuation -> Peer ps pr pl Z st m a @@ -175,7 +184,8 @@ data Peer ps pr pl n st m a where -- > (Done ReflNobodyAgency TokDone result) -- Done - :: SingI st + :: forall ps pr pl (st :: ps) m a. + SingI st => ReflRelativeAgency (StateAgency st) NobodyHasAgency (Relative pr (StateAgency st)) @@ -193,7 +203,11 @@ data Peer ps pr pl n st m a where -- the queue. -- YieldPipelined - :: (SingI st, SingI st') + :: forall ps pr (st :: ps) (st' :: ps) c n st'' m a. + ( SingI st + , SingI st' + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) WeHaveAgency (Relative pr (StateAgency st)) @@ -208,7 +222,10 @@ data Peer ps pr pl n st m a where -- | Partially collect promised transition. -- Collect - :: SingI st + :: forall ps pr c n st m a. + ( SingI st + , ActiveState st + ) => Maybe (Peer ps pr ('Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far -> (c -> Peer ps pr ('Pipelined c) n st m a) @@ -237,7 +254,9 @@ data Receiver ps pr st stdone m c where ReceiverDone :: c -> Receiver ps pr stdone stdone m c - ReceiverAwait :: SingI st + ReceiverAwait :: ( SingI st + , ActiveState st + ) => ReflRelativeAgency (StateAgency st) TheyHaveAgency (Relative pr (StateAgency st)) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index b6d81002..dcd6de47 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -63,6 +64,7 @@ pattern Yield :: forall ps pl st m a. () => forall st'. ( SingI st + , SingI st' , StateAgency st ~ ClientAgency ) => Message ps st st' @@ -122,7 +124,9 @@ pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg r -- pattern Collect :: forall ps st n c m a. () - => SingI st + => ( SingI st + , ActiveState st + ) => Maybe (Client ps ('Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far -> (c -> Client ps ('Pipelined c) n st m a) @@ -143,6 +147,7 @@ pattern ReceiverEffect k = TP.ReceiverEffect k pattern ReceiverAwait :: forall ps st stdone m c. () => ( SingI st + , ActiveState st , StateAgency st ~ ServerAgency ) => (forall st'. Message ps st st' diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 9aac1089..9fe9628c 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -63,6 +64,7 @@ pattern Yield :: forall ps pl st m a. () => forall st'. ( SingI st + , SingI st' , StateAgency st ~ ServerAgency ) => Message ps st st' @@ -122,7 +124,9 @@ pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg r -- pattern Collect :: forall ps st n c m a. () - => SingI st + => ( SingI st + , ActiveState st + ) => Maybe (Server ps ('Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far -> (c -> Server ps ('Pipelined c) n st m a) @@ -144,6 +148,7 @@ pattern ReceiverEffect k = TP.ReceiverEffect k pattern ReceiverAwait :: forall ps st stdone m c. () => ( SingI st + , ActiveState st , StateAgency st ~ ClientAgency ) => (forall st'. Message ps st st' diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index e6ff9558..91ae9172 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} From b121a808f485b595a277a65c3986a678b35612c2 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 27 Mar 2022 16:53:53 +0200 Subject: [PATCH 05/39] typed-protocols: simplify runPeerWithDriver There's no need to to pass initial `dstate` it is already passed inside `Driver` record. --- .../src/Network/TypedProtocol/Driver/Simple.hs | 4 ++-- typed-protocols/src/Network/TypedProtocol/Driver.hs | 10 ++++------ 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 200fbe15..44373d10 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -135,7 +135,7 @@ runPeer -> Peer ps pr 'NonPipelined Z st m a -> m (a, Maybe bytes) runPeer tracer codec channel peer = - runPeerWithDriver driver peer Nothing + runPeerWithDriver driver peer where driver = driverSimple tracer codec channel @@ -156,7 +156,7 @@ runPipelinedPeer -> Peer ps pr ('Pipelined c) Z st m a -> m (a, Maybe bytes) runPipelinedPeer tracer codec channel peer = - runPipelinedPeerWithDriver driver peer Nothing + runPipelinedPeerWithDriver driver peer where driver = driverSimple tracer codec channel diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index ad7b18f0..6f1cc6a0 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -116,10 +116,9 @@ runPeerWithDriver Monad m => Driver ps pr dstate m -> Peer ps pr NonPipelined Z st m a - -> dstate -> m (a, dstate) -runPeerWithDriver Driver{sendMessage, recvMessage} = - flip go +runPeerWithDriver Driver{sendMessage, recvMessage, initialDState} = + go initialDState where go :: forall st'. dstate @@ -166,15 +165,14 @@ runPipelinedPeerWithDriver MonadAsync m => Driver ps pr dstate m -> Peer ps pr ('Pipelined c) Z st m a - -> dstate -> m (a, dstate) -runPipelinedPeerWithDriver driver peer dstate0 = do +runPipelinedPeerWithDriver driver@Driver{initialDState} peer = do receiveQueue <- atomically newTQueue collectQueue <- atomically newTQueue a <- runPipelinedPeerReceiverQueue receiveQueue collectQueue driver `withAsyncLoop` runPipelinedPeerSender receiveQueue collectQueue driver - peer dstate0 + peer initialDState return a where From bdf810084689ce0474687ff58f5be29c7858620c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 23 May 2022 15:03:53 +0200 Subject: [PATCH 06/39] typed-protocols: internal lemmas module --- .../src/Network/TypedProtocol/Core.hs | 120 ---------------- .../src/Network/TypedProtocol/Lemmas.hs | 133 ++++++++++++++++++ .../src/Network/TypedProtocol/Proofs.hs | 1 + typed-protocols/typed-protocols.cabal | 1 + 4 files changed, 135 insertions(+), 120 deletions(-) create mode 100644 typed-protocols/src/Network/TypedProtocol/Lemmas.hs diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 314ea82c..187a9207 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -44,13 +44,6 @@ module Network.TypedProtocol.Core , IsActiveState (..) , ActiveState , notActiveState - -- * Protocol proofs and tests - -- $tests - -- $lemmas - , exclusionLemma_ClientAndServerHaveAgency - , terminationLemma_1 - , terminationLemma_2 - , ReflNobodyHasAgency (..) ) where import Data.Kind (Constraint, Type) @@ -427,119 +420,6 @@ type family FlipAgency pr where FlipAgency AsServer = AsClient --- | An evidence that both relative agencies are equal to 'NobodyHasAgency'. --- -type ReflNobodyHasAgency :: RelativeAgency -> RelativeAgency -> Type -data ReflNobodyHasAgency ra ra' where - ReflNobodyHasAgency :: ReflNobodyHasAgency - NobodyHasAgency - NobodyHasAgency - - --- | A proof that if both @Relative pr a@ and @Relative (FlipAgency pr) a@ are --- equal then nobody has agency. In particular this lemma excludes the --- possibility that client and server has agency at the same state. --- -exclusionLemma_ClientAndServerHaveAgency - :: forall (pr :: PeerRole) (a :: Agency) - (ra :: RelativeAgency). - SingPeerRole pr - -> ReflRelativeAgency a ra (Relative pr a) - -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) - -> ReflNobodyHasAgency (Relative pr a) - (Relative (FlipAgency pr) a) -exclusionLemma_ClientAndServerHaveAgency - SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency -exclusionLemma_ClientAndServerHaveAgency - SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency - -exclusionLemma_ClientAndServerHaveAgency - SingAsClient ReflClientAgency x = case x of {} -exclusionLemma_ClientAndServerHaveAgency - SingAsServer ReflClientAgency x = case x of {} -exclusionLemma_ClientAndServerHaveAgency - SingAsClient ReflServerAgency x = case x of {} -exclusionLemma_ClientAndServerHaveAgency - SingAsServer ReflServerAgency x = case x of {} - - --- | A proof that if one side has terminated, then the other side terminated as --- well. --- -terminationLemma_1 - :: SingPeerRole pr - -> ReflRelativeAgency a ra (Relative pr a) - -> ReflRelativeAgency a NobodyHasAgency (Relative (FlipAgency pr) a) - -> ReflNobodyHasAgency (Relative pr a) - (Relative (FlipAgency pr) a) -terminationLemma_1 - SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency -terminationLemma_1 - SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency -terminationLemma_1 SingAsClient ReflClientAgency x = case x of {} -terminationLemma_1 SingAsClient ReflServerAgency x = case x of {} -terminationLemma_1 SingAsServer ReflClientAgency x = case x of {} -terminationLemma_1 SingAsServer ReflServerAgency x = case x of {} - - --- | Internal; only need to formulate auxiliary lemmas in the proof of --- 'terminationLemma_2'. --- -type FlipRelAgency :: RelativeAgency -> RelativeAgency -type family FlipRelAgency ra where - FlipRelAgency WeHaveAgency = TheyHaveAgency - FlipRelAgency TheyHaveAgency = WeHaveAgency - FlipRelAgency NobodyHasAgency = NobodyHasAgency - - --- | Similar to 'terminationLemma_1'. --- --- Note: this could be proven the same way 'terminationLemma_1' is proved, but --- instead we use two lemmas to reduce the assumptions (arguments) and we apply --- 'terminationLemma_1'. --- -terminationLemma_2 - :: SingPeerRole pr - -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) - -> ReflRelativeAgency a NobodyHasAgency (Relative pr a) - -> ReflNobodyHasAgency (Relative (FlipAgency pr) a) - (Relative pr a) - -terminationLemma_2 singPeerRole refl refl' = - case terminationLemma_1 singPeerRole - (lemma_flip singPeerRole refl) - (lemma_flip' singPeerRole refl') - of x@ReflNobodyHasAgency -> x - -- note: if we'd swap arguments of the returned @ReflNobodyHasAgency@ type, - -- we wouldn't need to pattern match on the result. But in this form the - -- lemma is a symmetric version of 'terminationLemma_1'. - where - lemma_flip - :: SingPeerRole pr - -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) - -> ReflRelativeAgency a (FlipRelAgency ra) (Relative pr a) - - lemma_flip' - :: SingPeerRole pr - -> ReflRelativeAgency a ra (Relative pr a) - -> ReflRelativeAgency a (FlipRelAgency ra) (Relative (FlipAgency pr) a) - - -- both lemmas are identity functions: - lemma_flip SingAsClient ReflClientAgency = ReflClientAgency - lemma_flip SingAsClient ReflServerAgency = ReflServerAgency - lemma_flip SingAsClient ReflNobodyAgency = ReflNobodyAgency - lemma_flip SingAsServer ReflClientAgency = ReflClientAgency - lemma_flip SingAsServer ReflServerAgency = ReflServerAgency - lemma_flip SingAsServer ReflNobodyAgency = ReflNobodyAgency - - lemma_flip' SingAsClient ReflClientAgency = ReflClientAgency - lemma_flip' SingAsClient ReflServerAgency = ReflServerAgency - lemma_flip' SingAsClient ReflNobodyAgency = ReflNobodyAgency - lemma_flip' SingAsServer ReflClientAgency = ReflClientAgency - lemma_flip' SingAsServer ReflServerAgency = ReflServerAgency - lemma_flip' SingAsServer ReflNobodyAgency = ReflNobodyAgency - - -- | Promoted data type which indicates if 'Peer' is used in -- pipelined mode or not. -- diff --git a/typed-protocols/src/Network/TypedProtocol/Lemmas.hs b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs new file mode 100644 index 00000000..00bb6e57 --- /dev/null +++ b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use camelCase" #-} + +-- | The module contains exclusion lemmas which are proven using ad absurdum: +-- +-- * it's impossible for both client and server have agency +-- * it's impossible for either side to be in a terminal state (no agency) and +-- the other side have agency +-- +module Network.TypedProtocol.Lemmas where + +import Data.Kind (Type) +import Network.TypedProtocol.Core + + +-- | An evidence that both relative agencies are equal to 'NobodyHasAgency'. +-- +type ReflNobodyHasAgency :: RelativeAgency -> RelativeAgency -> Type +data ReflNobodyHasAgency ra ra' where + ReflNobodyHasAgency :: ReflNobodyHasAgency + NobodyHasAgency + NobodyHasAgency + + +-- | A proof that if both @Relative pr a@ and @Relative (FlipAgency pr) a@ are +-- equal then nobody has agency. In particular this lemma excludes the +-- possibility that client and server has agency at the same state. +-- +exclusionLemma_ClientAndServerHaveAgency + :: forall (pr :: PeerRole) (a :: Agency) + (ra :: RelativeAgency). + SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflNobodyHasAgency (Relative pr a) + (Relative (FlipAgency pr) a) +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency + +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflClientAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflClientAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsClient ReflServerAgency x = case x of {} +exclusionLemma_ClientAndServerHaveAgency + SingAsServer ReflServerAgency x = case x of {} + + +-- | A proof that if one side has terminated, then the other side terminated as +-- well. +-- +terminationLemma_1 + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a NobodyHasAgency (Relative (FlipAgency pr) a) + -> ReflNobodyHasAgency (Relative pr a) + (Relative (FlipAgency pr) a) +terminationLemma_1 + SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +terminationLemma_1 + SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency +terminationLemma_1 SingAsClient ReflClientAgency x = case x of {} +terminationLemma_1 SingAsClient ReflServerAgency x = case x of {} +terminationLemma_1 SingAsServer ReflClientAgency x = case x of {} +terminationLemma_1 SingAsServer ReflServerAgency x = case x of {} + + +-- | Internal; only need to formulate auxiliary lemmas in the proof of +-- 'terminationLemma_2'. +-- +type FlipRelAgency :: RelativeAgency -> RelativeAgency +type family FlipRelAgency ra where + FlipRelAgency WeHaveAgency = TheyHaveAgency + FlipRelAgency TheyHaveAgency = WeHaveAgency + FlipRelAgency NobodyHasAgency = NobodyHasAgency + + +-- | Similar to 'terminationLemma_1'. +-- +-- Note: this could be proven the same way 'terminationLemma_1' is proved, but +-- instead we use two lemmas to reduce the assumptions (arguments) and we apply +-- 'terminationLemma_1'. +-- +terminationLemma_2 + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflRelativeAgency a NobodyHasAgency (Relative pr a) + -> ReflNobodyHasAgency (Relative (FlipAgency pr) a) + (Relative pr a) + +terminationLemma_2 singPeerRole refl refl' = + case terminationLemma_1 singPeerRole + (lemma_flip singPeerRole refl) + (lemma_flip' singPeerRole refl') + of x@ReflNobodyHasAgency -> x + -- note: if we'd swap arguments of the returned @ReflNobodyHasAgency@ type, + -- we wouldn't need to pattern match on the result. But in this form the + -- lemma is a symmetric version of 'terminationLemma_1'. + where + lemma_flip + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -> ReflRelativeAgency a (FlipRelAgency ra) (Relative pr a) + + lemma_flip' + :: SingPeerRole pr + -> ReflRelativeAgency a ra (Relative pr a) + -> ReflRelativeAgency a (FlipRelAgency ra) (Relative (FlipAgency pr) a) + + -- both lemmas are identity functions: + lemma_flip SingAsClient ReflClientAgency = ReflClientAgency + lemma_flip SingAsClient ReflServerAgency = ReflServerAgency + lemma_flip SingAsClient ReflNobodyAgency = ReflNobodyAgency + lemma_flip SingAsServer ReflClientAgency = ReflClientAgency + lemma_flip SingAsServer ReflServerAgency = ReflServerAgency + lemma_flip SingAsServer ReflNobodyAgency = ReflNobodyAgency + + lemma_flip' SingAsClient ReflClientAgency = ReflClientAgency + lemma_flip' SingAsClient ReflServerAgency = ReflServerAgency + lemma_flip' SingAsClient ReflNobodyAgency = ReflNobodyAgency + lemma_flip' SingAsServer ReflClientAgency = ReflClientAgency + lemma_flip' SingAsServer ReflServerAgency = ReflServerAgency + lemma_flip' SingAsServer ReflNobodyAgency = ReflNobodyAgency diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index 91ae9172..aa5a28cf 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -38,6 +38,7 @@ module Network.TypedProtocol.Proofs import Data.Singletons import Network.TypedProtocol.Core +import Network.TypedProtocol.Lemmas import Network.TypedProtocol.Peer -- $about diff --git a/typed-protocols/typed-protocols.cabal b/typed-protocols/typed-protocols.cabal index 36c04101..7db0b84f 100644 --- a/typed-protocols/typed-protocols.cabal +++ b/typed-protocols/typed-protocols.cabal @@ -24,6 +24,7 @@ library , Network.TypedProtocol.Codec , Network.TypedProtocol.Driver , Network.TypedProtocol.Proofs + other-modules: Network.TypedProtocol.Lemmas other-extensions: GADTs , RankNTypes From 564da48877560bfe6fb72feef94112f527b88bfc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 13 Jul 2022 16:53:22 +0200 Subject: [PATCH 07/39] typed-protocols: provide ReflRelativeAgency type aliases * WeHaveAgencyProof * TheyHaveAgencyProof * NobodyHasAgencyProof --- .../src/Network/TypedProtocol/Core.hs | 41 +++++++++++++++++++ .../src/Network/TypedProtocol/Driver.hs | 8 +--- .../src/Network/TypedProtocol/Peer.hs | 20 +++------ 3 files changed, 48 insertions(+), 21 deletions(-) diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 187a9207..842c964b 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -37,6 +37,9 @@ module Network.TypedProtocol.Core , RelativeAgency (..) , Relative , ReflRelativeAgency (..) + , WeHaveAgencyProof + , TheyHaveAgencyProof + , NobodyHasAgencyProof , FlipAgency , Pipelined (..) , ActiveAgency @@ -282,6 +285,44 @@ data ReflRelativeAgency a r r' where ReflServerAgency :: ReflRelativeAgency ServerAgency r r ReflNobodyAgency :: ReflRelativeAgency NobodyAgency r r +-- | Type of the proof that we have the agency. +-- +-- 'ReflClientAgency' has this type only iff `'StateAgency' st ~ 'ClientAgency'` +-- and `pr ~ 'AsClient'`. +-- +-- 'ReflServerAgency' has this type only iff `'StateAgency' st ~ 'ServerAgency'` +-- and `pr ~ 'AsServer'` +-- +type WeHaveAgencyProof :: PeerRole -> ps -> Type +type WeHaveAgencyProof pr st = ReflRelativeAgency + (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) + +-- | Type of the proof that the remote side has the agency. +-- +-- 'ReflClientAgency' has this type only iff `'StateAgency' st ~ 'ClientAgency'` +-- and `pr ~ 'AsServer'`. +-- +-- 'ReflServerAgency' has this type only iff `'StateAgency' st ~ 'ServerAgency'` +-- and `pr ~ 'AsClient'` +-- +type TheyHaveAgencyProof :: PeerRole -> ps -> Type +type TheyHaveAgencyProof pr st = ReflRelativeAgency + (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) + + +-- | Type of the proof that nobody has agency in this state. +-- +-- Only 'ReflNobodyAgency' can fulfil the proof obligation. +-- +type NobodyHasAgencyProof :: PeerRole -> ps -> Type +type NobodyHasAgencyProof pr st = ReflRelativeAgency (StateAgency st) + NobodyHasAgency + (Relative pr (StateAgency st)) + -- $lemmas -- -- The 'connect' proof rely on lemmas about the protocol. Specifically they diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index 6f1cc6a0..f87276bb 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -71,18 +71,14 @@ data Driver ps (pr :: PeerRole) dstate m = SingI st => SingI st' => ActiveState st - => ReflRelativeAgency (StateAgency st) - WeHaveAgency - (Relative pr (StateAgency st)) + => WeHaveAgencyProof pr st -> Message ps st st' -> m () , recvMessage :: forall (st :: ps). SingI st => ActiveState st - => ReflRelativeAgency (StateAgency st) - TheyHaveAgency - (Relative pr (StateAgency st)) + => TheyHaveAgencyProof pr st -> dstate -> m (SomeMessage st, dstate) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 94eb89a6..343c6479 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -132,9 +132,7 @@ data Peer ps pr pl n st m a where , SingI st' , ActiveState st ) - => ReflRelativeAgency (StateAgency st) - WeHaveAgency - (Relative pr (StateAgency st)) + => WeHaveAgencyProof pr st -- ^ agency proof -> Message ps st st' -- ^ protocol message @@ -164,9 +162,7 @@ data Peer ps pr pl n st m a where ( SingI st , ActiveState st ) - => ReflRelativeAgency (StateAgency st) - TheyHaveAgency - (Relative pr (StateAgency st)) + => TheyHaveAgencyProof pr st -- ^ agency proof -> (forall (st' :: ps). Message ps st st' -> Peer ps pr pl Z st' m a) @@ -186,9 +182,7 @@ data Peer ps pr pl n st m a where Done :: forall ps pr pl (st :: ps) m a. SingI st - => ReflRelativeAgency (StateAgency st) - NobodyHasAgency - (Relative pr (StateAgency st)) + => NobodyHasAgencyProof pr st -- ^ (no) agency proof -> a -- ^ returned value @@ -208,9 +202,7 @@ data Peer ps pr pl n st m a where , SingI st' , ActiveState st ) - => ReflRelativeAgency (StateAgency st) - WeHaveAgency - (Relative pr (StateAgency st)) + => WeHaveAgencyProof pr st -- ^ agency proof -> Message ps st st' -- ^ protocol message @@ -257,9 +249,7 @@ data Receiver ps pr st stdone m c where ReceiverAwait :: ( SingI st , ActiveState st ) - => ReflRelativeAgency (StateAgency st) - TheyHaveAgency - (Relative pr (StateAgency st)) + => TheyHaveAgencyProof pr st -> (forall st'. Message ps st st' -> Receiver ps pr st' stdone m c) -> Receiver ps pr st stdone m c From 6f5ce41fe15935e6890599aee8d34ed798846c7d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 4 Sep 2021 08:41:35 +0200 Subject: [PATCH 08/39] typed-protocols-examples: socketAsChannel Illustrative example how to define a 'Channel' for a socket. The implementation is only given for posix platforms. It is using a non-blocking `recv` foreign call to provide `tryRecv`. --- scripts/check-stylish.sh | 2 +- .../src/Network/TypedProtocol/Channel.hs | 26 +++++++++++++++++++ .../typed-protocols-examples.cabal | 1 + 3 files changed, 28 insertions(+), 1 deletion(-) diff --git a/scripts/check-stylish.sh b/scripts/check-stylish.sh index 43ef543a..897adc8e 100755 --- a/scripts/check-stylish.sh +++ b/scripts/check-stylish.sh @@ -7,4 +7,4 @@ export LC_ALL=C.UTF-8 $FD . './typed-protocols' -e hs -E Setup.hs -X stylish-haskell -c .stylish-haskell.yaml -i $FD . './typed-protocols-cborg' -e hs -E Setup.hs -X stylish-haskell -c .stylish-haskell.yaml -i -$FD . './typed-protocols-examples' -e hs -E Setup.hs -X stylish-haskell -c .stylish-haskell.yaml -i +$FD . './typed-protocols-examples' -e hs -E Setup.hs -E Channel.hs -X stylish-haskell -c .stylish-haskell.yaml -i diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs index d7887f5b..b4f868ec 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -10,6 +11,9 @@ module Network.TypedProtocol.Channel , fixedInputChannel , mvarsAsChannel , handlesAsChannel +#if !defined(mingw32_HOST_OS) + , socketAsChannel +#endif , createConnectedChannels , createConnectedBufferedChannels , createPipelineTestChannels @@ -27,6 +31,11 @@ import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy.Internal (smallChunkSize) import Numeric.Natural +#if !defined(mingw32_HOST_OS) +import Network.Socket (Socket) +import qualified Network.Socket.ByteString.Lazy as Socket +#endif + import qualified System.IO as IO (Handle, hFlush, hIsEOF) @@ -251,6 +260,23 @@ delayChannel delay = channelEffect (\_ -> return ()) (\_ -> threadDelay delay) +#if !defined(mingw32_HOST_OS) +socketAsChannel :: Socket + -> Channel IO LBS.ByteString +socketAsChannel sock = + Channel{send, recv} + where + send :: LBS.ByteString -> IO () + send = Socket.sendAll sock + + recv :: IO (Maybe LBS.ByteString) + recv = do + bs <- Socket.recv sock (fromIntegral smallChunkSize) + if LBS.null bs + then return Nothing + else return (Just bs) +#endif + -- | Channel which logs sent and received messages. -- loggingChannel :: ( MonadSay m diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 9bc1d40d..ccdba8f2 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -51,6 +51,7 @@ library contra-tracer, io-classes, si-timers, + network, time, typed-protocols, typed-protocols-cborg From c69993a02883bef3d78ef6c21eab383510a8f28b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 17 Sep 2021 23:31:04 +0200 Subject: [PATCH 09/39] typed-protocols-examples: ReqResp2 example An example which demonstrates that one can pipeline two kinds of requests, and collect all the responses. --- .../Network/TypedProtocol/ReqResp2/Client.hs | 61 ++++++++++++++++++ .../Network/TypedProtocol/ReqResp2/Type.hs | 64 +++++++++++++++++++ .../typed-protocols-examples.cabal | 2 + 3 files changed, 127 insertions(+) create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs new file mode 100644 index 00000000..351ed67f --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + + + +module Network.TypedProtocol.ReqResp2.Client where + +import Network.TypedProtocol.ReqResp2.Type + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Client + + +reqResp2Client :: forall req resp m. + () + => [Either req req] + -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) Z StIdle m [Either resp resp] +reqResp2Client = send Zero + where + -- pipeline all the requests, either through `MsgReq` or `MsgReq'`. + send :: forall (n :: N). + Nat n + -> [Either req req] -- requests to send + -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) n StIdle m [Either resp resp] + + send !n (Left req : reqs) = + YieldPipelined (MsgReq req) receiver (send (Succ n) reqs) + + send !n (Right req : reqs) = + YieldPipelined (MsgReq' req) receiver' (send (Succ n) reqs) + + send !n [] = collect n [] + + + receiver :: Receiver (ReqResp2 req resp) StBusy StIdle m (Either resp resp) + receiver = ReceiverAwait (\(MsgResp resp) -> ReceiverDone (Left resp)) + + + receiver' :: Receiver (ReqResp2 req resp) StBusy' StIdle m (Either resp resp) + receiver' = ReceiverAwait (\(MsgResp' resp) -> ReceiverDone (Right resp)) + + + -- collect all the responses + collect :: Nat n + -> [Either resp resp] -- all the responses received so far + -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) n StIdle m [Either resp resp] + + collect Zero !resps = Yield MsgDone (Done (reverse resps)) + + collect (Succ n) !resps = + Collect Nothing $ \c -> collect n (c : resps) + + + diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs new file mode 100644 index 00000000..52b1893e --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + + +module Network.TypedProtocol.ReqResp2.Type where + +import Data.Singletons + +import Network.TypedProtocol.Core + + +data ReqResp2 req resp where + StIdle :: ReqResp2 req resp + StBusy :: ReqResp2 req resp + StBusy' :: ReqResp2 req resp + StDone :: ReqResp2 req resp + +data SReqResp2 (st :: ReqResp2 req resp) where + SingIdle :: SReqResp2 StIdle + SingBusy :: SReqResp2 StBusy + SingBusy' :: SReqResp2 StBusy' + SingDone :: SReqResp2 StDone + +deriving instance Show (SReqResp2 st) + +type instance Sing = SReqResp2 +instance SingI StIdle where + sing = SingIdle +instance SingI StBusy where + sing = SingBusy +instance SingI StBusy' where + sing = SingBusy' +instance SingI StDone where + sing = SingDone + + +instance Protocol (ReqResp2 req resp) where + + data Message (ReqResp2 req resp) from to where + MsgReq :: req -> Message (ReqResp2 req resp) StIdle StBusy + MsgResp :: resp -> Message (ReqResp2 req resp) StBusy StIdle + + MsgReq' :: req -> Message (ReqResp2 req resp) StIdle StBusy' + MsgResp' :: resp -> Message (ReqResp2 req resp) StBusy' StIdle + + MsgDone :: Message (ReqResp2 req resp) StIdle StDone + + type StateAgency StIdle = ClientAgency + type StateAgency StBusy = ServerAgency + type StateAgency StBusy' = ServerAgency + type StateAgency StDone = NobodyAgency + + +deriving instance (Show req, Show resp) + => Show (Message (ReqResp2 req resp) from to) + +deriving instance (Eq req, Eq resp) + => Eq (Message (ReqResp2 req resp) from to) + diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index ccdba8f2..312bedf1 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -35,6 +35,8 @@ library , Network.TypedProtocol.ReqResp.Codec.CBOR , Network.TypedProtocol.ReqResp.Examples + , Network.TypedProtocol.ReqResp2.Type + , Network.TypedProtocol.ReqResp2.Client other-extensions: GADTs , RankNTypes , PolyKinds From e4bcf98cbc55f3136234edb632454217705e529b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 18 Sep 2021 12:23:03 +0200 Subject: [PATCH 10/39] typed-protocols-examples: Wedge --- .../src/Network/TypedProtocol/Trans/Wedge.hs | 165 ++++++++++++++++++ .../typed-protocols-examples.cabal | 2 + 2 files changed, 167 insertions(+) create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs new file mode 100644 index 00000000..c1bc2896 --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Network.TypedProtocol.Trans.Wedge where + +import Data.Singletons + +import Network.TypedProtocol.Core + +import qualified Network.TypedProtocol.Peer.Client as Client +import qualified Network.TypedProtocol.PingPong.Type as PingPong + + +-- | A [wedge](https://hackage.haskell.org/package/smash-0.1.2/docs/Data-Wedge.html) +-- sum of two protocols. +-- +-- One can interleave both protocols using protocol pipelining. Termination +-- must be done by terminating one of the protocols. +-- +data Wedge ps (stIdle :: ps) ps' (stIdle' :: ps') where + StIdle :: Wedge ps stIdle ps' stIdle' + StFst :: ps -> Wedge ps stIdle ps' stIdle' + StSnd :: ps' -> Wedge ps stIdle ps' stIdle' + + +data SingWedge (st :: Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where + SingStIdle :: SingWedge StIdle + SingStFst :: Sing st + -> SingWedge (StFst st) + SingStSnd :: Sing st' + -> SingWedge (StSnd st') + +instance Show (SingWedge StIdle) where + show SingStIdle = "SingStIdle" +instance Show (Sing st) => Show (SingWedge (StFst st)) where + show (SingStFst s) = "SingStFst " ++ show s +instance Show (Sing st) => Show (SingWedge (StSnd st)) where + show (SingStSnd s) = "SingStSnd " ++ show s + +type instance Sing = SingWedge +instance SingI StIdle where + sing = SingStIdle +instance SingI st => SingI (StFst st) where + sing = SingStFst (sing @st) +instance SingI st => SingI (StSnd st) where + sing = SingStSnd (sing @st) + + +-- | A Singleton type which allows to pick the starting protocol state. +-- +data SingStart (st :: Wedge ps stIdle ps' stIdle') where + AtFst :: SingStart (StFst stIdle) + AtSnd :: SingStart (StSnd stIdle) + + +-- Note: This does not require @(Protocol ps, Protocol ps')@, ghc is not +-- requiring class constraints for associated type families / data types the +-- same way as for terms. +-- +instance Protocol (Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where + + data Message (Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) from to where + -- | Signal that starts one of the protocols. + -- + MsgStart :: SingStart st + -> Message (Wedge ps stIdle ps' stIdle') + StIdle st + + -- | Embed any @ps@ message. + -- + MsgFst :: Message ps st st' + -> Message (Wedge ps stIdle ps' stIdle') + (StFst st) (StFst st') + + + -- | Embed any @ps'@ message. + MsgSnd :: Message ps' st st' + -> Message (Wedge ps stIdle ps' stIdle') + (StSnd st) (StSnd st') + + -- | Switch from @ps@ to @ps'@. + -- + MsgFstToSnd :: Message (Wedge ps stIdle ps' stIdle') + (StFst stIdle) (StSnd stIdle') + + -- | Switch from @ps'@ to @ps@. + -- + MsgSndToFst :: Message (Wedge ps stIdle ps' stIdle') + (StSnd stIdle') (StFst stIdle) + + + type StateAgency StIdle = ClientAgency + type StateAgency (StFst st) = StateAgency st + type StateAgency (StSnd st) = StateAgency st + + +type PingPong2 = Wedge PingPong.PingPong PingPong.StIdle + PingPong.PingPong PingPong.StIdle + + +pingPong2Client :: Client.Client PingPong2 NonPipelined Client.Z StIdle m () +pingPong2Client = + Client.Yield (MsgStart AtFst) + $ Client.Yield (MsgFst PingPong.MsgPing) + $ Client.Await $ \(MsgFst PingPong.MsgPong) -> + Client.Yield MsgFstToSnd + $ Client.Yield (MsgSnd PingPong.MsgPing) + $ Client.Await $ \(MsgSnd PingPong.MsgPong) -> + -- terminate, through the second protocol + Client.Yield (MsgSnd PingPong.MsgDone) + $ Client.Done () + + +pingPong2Client' :: forall m. Client.Client PingPong2 ('Pipelined ()) Client.Z StIdle m () +pingPong2Client' = + -- + -- Pipeline first protocol + -- + + Client.YieldPipelined (MsgStart AtFst) + (Client.ReceiverDone ()) + $ Client.YieldPipelined (MsgFst PingPong.MsgPing) + (Client.ReceiverAwait (\(MsgFst PingPong.MsgPong) -> Client.ReceiverDone ())) + + -- + -- Pipeline second protocol + -- + + $ Client.YieldPipelined MsgFstToSnd + (Client.ReceiverDone ()) + $ Client.YieldPipelined (MsgSnd PingPong.MsgPing) + (Client.ReceiverAwait (\(MsgSnd PingPong.MsgPong) -> Client.ReceiverDone ())) + + -- + -- Collect responses from the first protocol + -- + + $ Client.Collect Nothing $ \() -> -- collect transition pushed by `MsgStartFst` + Client.Collect Nothing $ \() -> -- collect reply received with `MsgFst MsgPong` + + -- + -- Collect responses from the second protocol + -- + + Client.Collect Nothing $ \() -> -- collect transition pushed by MsgFstToSnd + Client.Collect Nothing $ \() -> -- collect reply received with `MsgSnd MsgPong` + + -- + -- Terminate the protocol + -- + + Client.Yield (MsgSnd PingPong.MsgDone) + $ Client.Done () diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 312bedf1..5a7c027c 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -37,6 +37,8 @@ library , Network.TypedProtocol.ReqResp2.Type , Network.TypedProtocol.ReqResp2.Client + + , Network.TypedProtocol.Trans.Wedge other-extensions: GADTs , RankNTypes , PolyKinds From 86d007adc626dcdd6c9c4ff852ac4fdd08784be1 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 28 Sep 2021 08:56:21 +0200 Subject: [PATCH 11/39] typed-protocols-examples: requestOnce An example function how 'ReqResp' protocol can be used to build a synchronous interface to request a single response from a server. This allows to build `req -> m resp` function out of any 'ReqResp' server. --- .../src/Network/TypedProtocol/ReqResp/Client.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs index dd8928ad..6f7c5089 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.TypedProtocol.ReqResp.Client @@ -12,10 +13,14 @@ module Network.TypedProtocol.ReqResp.Client , reqRespClientPeerPipelined , ReqRespIdle (..) , reqRespClientPeerIdle + -- * Request once + , requestOnce ) where import Network.TypedProtocol.Core import Network.TypedProtocol.Peer.Client +import Network.TypedProtocol.Peer.Server (Server) +import Network.TypedProtocol.Proofs (connect) import Network.TypedProtocol.ReqResp.Type data ReqRespClient req resp m a where @@ -60,6 +65,18 @@ reqRespClientPeer (SendMsgReq req next) = pure $ reqRespClientPeer client + +requestOnce :: forall req resp m. + Monad m + => (forall x. Server (ReqResp req resp) NonPipelined Z StIdle m x) + -> (req -> m resp) +requestOnce server req = (\(resp, _, _) -> resp) + <$> reqRespClientPeer client `connect` server + where + client :: ReqRespClient req resp m resp + client = SendMsgReq req $ \resp -> pure $ SendMsgDone (pure resp) + + -- -- Pipelined client -- From b4070d4c979089861ae673773a49cc654368b0e2 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 2 Oct 2021 22:25:37 +0200 Subject: [PATCH 12/39] typed-protocols-examples: fixed cborg tests They ought to use cborg codec. --- .../test/Network/TypedProtocol/ReqResp/Tests.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 71dad165..2517fbef 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -24,6 +24,7 @@ import Network.TypedProtocol.Proofs import Network.TypedProtocol.ReqResp.Client import Network.TypedProtocol.ReqResp.Codec +import qualified Network.TypedProtocol.ReqResp.Codec.CBOR as CBOR import Network.TypedProtocol.ReqResp.Examples import Network.TypedProtocol.ReqResp.Server import Network.TypedProtocol.ReqResp.Type @@ -39,7 +40,8 @@ import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) import Data.Tuple (swap) -import Network.TypedProtocol.PingPong.Tests (splits2, splits3) +import Network.TypedProtocol.PingPong.Tests (splits2, splits2BS, + splits3, splits3BS) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -247,15 +249,15 @@ prop_codec_cbor_ReqResp :: AnyMessage (ReqResp String String) -> Bool prop_codec_cbor_ReqResp msg = - runST $ prop_codecM codecReqResp msg + runST $ prop_codecM CBOR.codecReqResp msg prop_codec_cbor_splits2_ReqResp :: AnyMessage (ReqResp String String) -> Bool prop_codec_cbor_splits2_ReqResp msg = runST $ prop_codec_splitsM - splits2 - codecReqResp + splits2BS + CBOR.codecReqResp msg prop_codec_cbor_splits3_ReqResp @@ -263,6 +265,6 @@ prop_codec_cbor_splits3_ReqResp -> Bool prop_codec_cbor_splits3_ReqResp msg = runST $ prop_codec_splitsM - splits3 - codecReqResp + splits3BS + CBOR.codecReqResp msg From 74a64f2b3bd55c3dbd24d173df1078b1c5922ce1 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 2 Oct 2021 22:27:15 +0200 Subject: [PATCH 13/39] typed-protocols-examples: pipelined tests * using TBQueue based channels in ST and IO * using unix named pipes and 'handleAsChannel' * using sockets and 'socketAsChannel' --- .../src/Network/TypedProtocol/Channel.hs | 3 +- .../Network/TypedProtocol/PingPong/Tests.hs | 72 ++++++++++- .../Network/TypedProtocol/ReqResp/Tests.hs | 112 +++++++++++++++++- .../typed-protocols-examples.cabal | 6 + 4 files changed, 189 insertions(+), 4 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs index b4f868ec..d95808f7 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs @@ -203,7 +203,8 @@ createPipelineTestChannels sz = do -- -- The Handles should be open in the appropriate read or write mode, and in -- binary mode. Writes are flushed after each write, so it is safe to use --- a buffering mode. +-- a buffering mode. On unix named pipes can be used, see +-- 'Network.TypedProtocol.ReqResp.Test.prop_namedPipePipelined_IO' -- -- For bidirectional handles it is safe to pass the same handle for both. -- diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 5ef937ea..aa21d94f 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -34,10 +35,17 @@ import Control.Monad.Class.MonadThrow import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.ST (runST) import Control.Tracer (nullTracer) + import Data.Functor.Identity (Identity (..)) +import Data.List (inits, tails) import qualified Data.ByteString.Lazy as LBS -import Data.List (inits, tails) +#if !defined(mingw32_HOST_OS) +import qualified Network.Socket as Socket +import System.Directory (removeFile) +import System.IO +import qualified System.Posix.Files as Posix +#endif import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -61,6 +69,10 @@ tests = testGroup "Network.TypedProtocol.PingPong" , testProperty "connect_pipelined 5" prop_connect_pipelined5 , testProperty "channel ST" prop_channel_ST , testProperty "channel IO" prop_channel_IO +#if !defined(mingw32_HOST_OS) + , testProperty "namedPipePipelined" prop_namedPipePipelined_IO + , testProperty "socketPipelined" prop_socketPipelined_IO +#endif , testGroup "Codec" [ testProperty "codec" prop_codec_PingPong , testProperty "codec 2-splits" prop_codec_splits2_PingPong @@ -313,6 +325,64 @@ prop_channel_ST n = runSimOrThrow (prop_channel n) +#if !defined(mingw32_HOST_OS) +prop_namedPipePipelined_IO :: NonNegative Int + -> Property +prop_namedPipePipelined_IO (NonNegative n) = ioProperty $ do + let client = pingPongClientPeer (pingPongClientCount n) + server = pingPongServerPeer pingPongServerCount + + let cliPath = "client.sock" + srvPath = "server.sock" + mode = Posix.ownerModes + + Posix.createNamedPipe cliPath mode + Posix.createNamedPipe srvPath mode + + bracket (openFile cliPath ReadWriteMode) + (\_ -> removeFile cliPath) + $ \cliHandle -> + bracket (openFile srvPath ReadWriteMode) + (\_ -> removeFile srvPath) + $ \srvHandle -> do + ((), n') <- runConnectedPeers (return ( handlesAsChannel cliHandle srvHandle + , handlesAsChannel srvHandle cliHandle + )) + nullTracer + CBOR.codecPingPong client server + return (n' == n) +#endif + + +#if !defined(mingw32_HOST_OS) +prop_socketPipelined_IO :: NonNegative Int + -> Property +prop_socketPipelined_IO (NonNegative n) = ioProperty $ do + ai : _ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") Nothing + bracket + ((,) <$> Socket.openSocket ai + <*> Socket.openSocket ai) + ( \ (sock, sock') -> Socket.close sock + >> Socket.close sock') + $ \ (sock, sock') -> do + Socket.bind sock (Socket.addrAddress ai) + addr <- Socket.getSocketName sock + Socket.listen sock 1 + Socket.connect sock' addr + bracket (fst <$> Socket.accept sock) Socket.close + $ \sock'' -> do + let client = pingPongClientPeer (pingPongClientCount n) + server = pingPongServerPeer pingPongServerCount + + ((), n') <- runConnectedPeers (return ( socketAsChannel sock' + , socketAsChannel sock'' + )) + nullTracer + CBOR.codecPingPong client server + return (n' == n) +#endif + + -- -- Codec properties -- diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 2517fbef..dfcbba87 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -29,16 +30,25 @@ import Network.TypedProtocol.ReqResp.Examples import Network.TypedProtocol.ReqResp.Server import Network.TypedProtocol.ReqResp.Type +import Control.Exception (throw) import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.IOSim (runSimOrThrow) +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim import Control.Monad.ST (runST) import Control.Tracer (nullTracer) import Data.Functor.Identity (Identity (..)) -import Data.List (mapAccumL) +import Data.List (intercalate, mapAccumL) import Data.Tuple (swap) +#if !defined(mingw32_HOST_OS) +import qualified Network.Socket as Socket +import System.Directory (removeFile) +import System.IO +import qualified System.Posix.Files as Posix +#endif import Network.TypedProtocol.PingPong.Tests (splits2, splits2BS, splits3, splits3BS) @@ -61,6 +71,12 @@ tests = testGroup "Network.TypedProtocol.ReqResp" , testProperty "connectPipelined" prop_connectPipelined , testProperty "channel ST" prop_channel_ST , testProperty "channel IO" prop_channel_IO + , testProperty "channelPipelined ST" prop_channelPipelined_ST + , testProperty "channelPipelined IO" prop_channelPipelined_IO +#if !defined(mingw32_HOST_OS) + , testProperty "namedPipePipelined" prop_namedPipePipelined_IO + , testProperty "socketPipelined" prop_socketPipelined_IO +#endif , testGroup "Codec" [ testProperty "codec" prop_codec_ReqResp , testProperty "codec 2-splits" prop_codec_splits2_ReqResp @@ -186,6 +202,7 @@ prop_channel f xs = do server = reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0) + prop_channel_IO :: (Int -> Int -> (Int, Int)) -> [Int] -> Property prop_channel_IO f xs = ioProperty (prop_channel f xs) @@ -195,6 +212,97 @@ prop_channel_ST f xs = runSimOrThrow (prop_channel f xs) +prop_channelPipelined :: ( MonadLabelledSTM m, MonadAsync m, MonadCatch m + , MonadDelay m, MonadST m) + => (Int -> Int -> (Int, Int)) -> [Int] + -> m Bool +prop_channelPipelined f xs = do + (c, s) <- runConnectedPeersPipelined + (createPipelineTestChannels 100) + nullTracer + CBOR.codecReqResp + client server + return ((s, c) == mapAccumL f 0 xs) + where + client = reqRespClientPeerPipelined (reqRespClientMapPipelined xs) + server = reqRespServerPeer (reqRespServerMapAccumL + (\a -> pure . f a) 0) + +prop_channelPipelined_IO :: (Int -> Int -> (Int, Int)) -> [Int] -> Property +prop_channelPipelined_IO f xs = + ioProperty (prop_channelPipelined f xs) + +prop_channelPipelined_ST :: (Int -> Int -> (Int, Int)) -> [Int] -> Property +prop_channelPipelined_ST f xs = + let tr = runSimTrace (prop_channelPipelined f xs) in + counterexample (intercalate "\n" $ map show $ traceEvents tr) + $ case traceResult True tr of + Left err -> throw err + Right res -> res + + +#if !defined(mingw32_HOST_OS) +prop_namedPipePipelined_IO :: (Int -> Int -> (Int, Int)) -> [Int] + -> Property +prop_namedPipePipelined_IO f xs = ioProperty $ do + let client = reqRespClientPeerPipelined (reqRespClientMapPipelined xs) + server = reqRespServerPeer (reqRespServerMapAccumL + (\a -> pure . f a) 0) + let cliPath = "client.sock" + srvPath = "server.sock" + mode = Posix.ownerModes + + Posix.createNamedPipe cliPath mode + Posix.createNamedPipe srvPath mode + + bracket (openFile cliPath ReadWriteMode) + (\_ -> removeFile cliPath) + $ \cliHandle -> + bracket (openFile srvPath ReadWriteMode) + (\_ -> removeFile srvPath) + $ \srvHandle -> do + (c, s) <- runConnectedPeersPipelined + (return ( handlesAsChannel cliHandle srvHandle + , handlesAsChannel srvHandle cliHandle + )) + nullTracer + CBOR.codecReqResp + client server + return ((s, c) == mapAccumL f 0 xs) +#endif + + +#if !defined(mingw32_HOST_OS) +prop_socketPipelined_IO :: (Int -> Int -> (Int, Int)) -> [Int] + -> Property +prop_socketPipelined_IO f xs = ioProperty $ do + ai : _ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") Nothing + bracket + ((,) <$> Socket.openSocket ai + <*> Socket.openSocket ai) + ( \ (sock, sock') -> Socket.close sock + >> Socket.close sock') + $ \ (sock, sock') -> do + Socket.bind sock (Socket.addrAddress ai) + addr <- Socket.getSocketName sock + Socket.listen sock 1 + Socket.connect sock' addr + bracket (fst <$> Socket.accept sock) Socket.close + $ \sock'' -> do + let client = reqRespClientPeerPipelined (reqRespClientMapPipelined xs) + server = reqRespServerPeer (reqRespServerMapAccumL + (\a -> pure . f a) 0) + + (c, s) <- runConnectedPeersPipelined + (return ( socketAsChannel sock' + , socketAsChannel sock'' + )) + nullTracer + CBOR.codecReqResp + client server + return ((s, c) == mapAccumL f 0 xs) +#endif + -- -- Codec properties -- diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 5a7c027c..5a04a18c 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -89,6 +89,12 @@ test-suite test , QuickCheck , tasty , tasty-quickcheck + + if !os(windows) + build-depends: directory + , network + , unix + default-language: Haskell2010 ghc-options: -rtsopts -Wall From 5ef5f2d7dc6d394afca09eb4fa03f7e1118464c6 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 27 Mar 2022 17:09:01 +0200 Subject: [PATCH 14/39] typed-protocols-examples: unbounded buffered channel A channel based on `TQueue`. It is useful for testing pipelined protocols, where pipelining depth is not taken into account. --- .../src/Network/TypedProtocol/Channel.hs | 38 +++++++++++++++++-- .../Network/TypedProtocol/PingPong/Tests.hs | 2 +- .../Network/TypedProtocol/ReqResp/Tests.hs | 2 +- 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs index d95808f7..3333928a 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Channel.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Network.TypedProtocol.Channel ( Channel (..) @@ -16,6 +17,7 @@ module Network.TypedProtocol.Channel #endif , createConnectedChannels , createConnectedBufferedChannels + , createConnectedBufferedChannelsUnbounded , createPipelineTestChannels , channelEffect , delayChannel @@ -29,6 +31,7 @@ import Control.Monad.Class.MonadTimer.SI import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy.Internal (smallChunkSize) +import Data.Proxy import Numeric.Natural #if !defined(mingw32_HOST_OS) @@ -128,12 +131,20 @@ mvarsAsChannel bufferRead bufferWrite = -- -- This is primarily useful for testing protocols. -- -createConnectedChannels :: MonadSTM m => m (Channel m a, Channel m a) +createConnectedChannels :: forall m a. (MonadLabelledSTM m, MonadTraceSTM m, Show a) => m (Channel m a, Channel m a) createConnectedChannels = do -- Create two TMVars to act as the channel buffer (one for each direction) -- and use them to make both ends of a bidirectional channel - bufferA <- atomically $ newEmptyTMVar - bufferB <- atomically $ newEmptyTMVar + bufferA <- atomically $ do + v <- newEmptyTMVar + labelTMVar v "buffer-a" + traceTMVar (Proxy @m) v $ \_ a -> pure $ TraceString ("buffer-a: " ++ show a) + return v + bufferB <- atomically $ do + v <- newEmptyTMVar + traceTMVar (Proxy @m) v $ \_ a -> pure $ TraceString ("buffer-b: " ++ show a) + labelTMVar v "buffer-b" + return v return (mvarsAsChannel bufferB bufferA, mvarsAsChannel bufferA bufferB) @@ -165,6 +176,27 @@ createConnectedBufferedChannels sz = do recv = atomically (Just <$> readTBQueue bufferRead) +-- | Create a pair of channels that are connected via two unbounded buffers. +-- +-- This is primarily useful for testing protocols. +-- +createConnectedBufferedChannelsUnbounded :: forall m a. MonadSTM m + => m (Channel m a, Channel m a) +createConnectedBufferedChannelsUnbounded = do + -- Create two TQueues to act as the channel buffers (one for each + -- direction) and use them to make both ends of a bidirectional channel + bufferA <- newTQueueIO + bufferB <- newTQueueIO + + return (queuesAsChannel bufferB bufferA, + queuesAsChannel bufferA bufferB) + where + queuesAsChannel bufferRead bufferWrite = + Channel{send, recv} + where + send x = atomically (writeTQueue bufferWrite x) + recv = atomically ( Just <$> readTQueue bufferRead) + -- | Create a pair of channels that are connected via N-place buffers. -- -- This variant /fails/ when 'send' would exceed the maximum buffer size. diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index aa21d94f..4c877317 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -303,7 +303,7 @@ prop_connect_pipelined5 choices (Positive omax) (NonNegative n) = -- | Run a non-pipelined client and server over a channel using a codec. -- -prop_channel :: (MonadSTM m, MonadAsync m, MonadCatch m) +prop_channel :: (MonadLabelledSTM m, MonadTraceSTM m, MonadAsync m, MonadCatch m) => NonNegative Int -> m Bool prop_channel (NonNegative n) = do diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index dfcbba87..1ac48f1a 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -189,7 +189,7 @@ prop_connectPipelined cs f xs = -- Properties using channels, codecs and drivers. -- -prop_channel :: (MonadSTM m, MonadAsync m, MonadCatch m) +prop_channel :: (MonadLabelledSTM m, MonadTraceSTM m, MonadAsync m, MonadCatch m) => (Int -> Int -> (Int, Int)) -> [Int] -> m Bool prop_channel f xs = do From ce833a9bb4957589d7daf1708c0e41eeed4c80c5 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 27 Mar 2022 17:10:14 +0200 Subject: [PATCH 15/39] typed-protocols-examples: added runConnectedPeersAsymetric --- .../Network/TypedProtocol/Driver/Simple.hs | 26 +++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 44373d10..8bcf50b5 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -25,6 +25,7 @@ module Network.TypedProtocol.Driver.Simple -- * Connected peers , runConnectedPeers , runConnectedPeersPipelined + , runConnectedPeersAsymmetric -- * Driver utilities -- | This may be useful if you want to write your own driver. , driverSimple @@ -228,3 +229,28 @@ runConnectedPeersPipelined createChannels tracer codec client server = tracerClient = contramap ((,) AsClient) tracer tracerServer = contramap ((,) AsServer) tracer + +-- Run the same protocol with different codes. This is useful for testing +-- 'Handshake' protocol which knows how to decode different versions. +-- +runConnectedPeersAsymmetric + :: ( MonadAsync m + , MonadMask m + , Exception failure + ) + => m (Channel m bytes, Channel m bytes) + -> Tracer m (Role, TraceSendRecv ps) + -> Codec ps failure m bytes + -> Codec ps failure m bytes + -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b + -> m (a, b) +runConnectedPeersAsymmetric createChannels tracer codec codec' client server = + createChannels >>= \(clientChannel, serverChannel) -> + + (fst <$> runPipelinedPeer tracerClient codec clientChannel client) + `concurrently` + (fst <$> runPeer tracerServer codec' serverChannel server) + where + tracerClient = contramap ((,) Client) tracer + tracerServer = contramap ((,) Server) tracer From 1ca4aa7597d71720d924645917891c90ea4be5a7 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 13 May 2022 08:00:24 +0200 Subject: [PATCH 16/39] typed-protocols: simplify evidence of termination in a terminal state The simplest solution seem to add `StateAgency st ~ NobodyAgency` to the `Done` constructor. Which can be carried over to `TerminalStates`. --- .../Network/TypedProtocol/PingPong/Tests.hs | 13 ++------ .../Network/TypedProtocol/ReqResp/Tests.hs | 15 ++------- .../src/Network/TypedProtocol/Peer.hs | 4 ++- .../src/Network/TypedProtocol/Proofs.hs | 32 ++++++++----------- 4 files changed, 21 insertions(+), 43 deletions(-) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 4c877317..86b7c130 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -18,7 +18,6 @@ module Network.TypedProtocol.PingPong.Tests import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec -import Network.TypedProtocol.Core import Network.TypedProtocol.Driver.Simple import Network.TypedProtocol.Proofs @@ -196,11 +195,7 @@ prop_connect (NonNegative n) = (pingPongClientPeer (pingPongClientCount n)) (pingPongServerPeer pingPongServerCount)) - of ((), n', TerminalStates SingDone - ReflNobodyAgency - SingDone - ReflNobodyAgency) -> - n == n' + of ((), n', TerminalStates SingDone SingDone) -> n == n' -- @@ -219,11 +214,7 @@ connect_pipelined client cs = (connectPipelined cs [] (pingPongClientPeerPipelined client) (promoteToPipelined $ pingPongServerPeer pingPongServerCount)) - - of (reqResps, n, TerminalStates SingDone - ReflNobodyAgency - SingDone - ReflNobodyAgency) -> + of (reqResps, n, TerminalStates SingDone SingDone) -> (n, reqResps) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 1ac48f1a..1cf0d54e 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,10 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -- orphaned arbitrary instances {-# OPTIONS_GHC -Wno-orphans #-} @@ -19,7 +15,6 @@ module Network.TypedProtocol.ReqResp.Tests (tests) where import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec -import Network.TypedProtocol.Core import Network.TypedProtocol.Driver.Simple import Network.TypedProtocol.Proofs @@ -163,10 +158,7 @@ prop_connect f xs = (reqRespClientPeer (reqRespClientMap xs)) (reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates SingDone - ReflNobodyAgency - SingDone - ReflNobodyAgency) -> + of (c, s, TerminalStates SingDone SingDone) -> (s, c) == mapAccumL f 0 xs @@ -178,10 +170,7 @@ prop_connectPipelined cs f xs = (promoteToPipelined $ reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) - of (c, s, TerminalStates SingDone - ReflNobodyAgency - SingDone - ReflNobodyAgency) -> + of (c, s, TerminalStates SingDone SingDone) -> (s, c) == mapAccumL f 0 xs diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 343c6479..82348858 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -181,7 +181,9 @@ data Peer ps pr pl n st m a where -- Done :: forall ps pr pl (st :: ps) m a. - SingI st + ( SingI st + , StateAgency st ~ NobodyAgency + ) => NobodyHasAgencyProof pr st -- ^ (no) agency proof -> a diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index aa5a28cf..6c291d0b 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- This is already implied by the -Wall in the .cabal file, but lets just be @@ -82,7 +83,7 @@ connect (Monad m, SingI pr) => Peer ps pr NonPipelined Z initSt m a -> Peer ps (FlipAgency pr) NonPipelined Z initSt m b - -> m (a, b, TerminalStates ps pr) + -> m (a, b, TerminalStates ps) connect = go where singPeerRole :: Sing pr @@ -91,14 +92,14 @@ connect = go go :: forall (st :: ps). Peer ps pr NonPipelined Z st m a -> Peer ps (FlipAgency pr) NonPipelined Z st m b - -> m (a, b, TerminalStates ps pr) - go (Done reflA a) (Done reflB b) = return (a, b, terminals) + -> m (a, b, TerminalStates ps) + go (Done ReflNobodyAgency a) (Done ReflNobodyAgency b) = + return (a, b, terminals) where - terminals :: TerminalStates ps pr + terminals :: TerminalStates ps terminals = TerminalStates (sing :: Sing st) - reflA (sing :: Sing st) - reflB + go (Effect a ) b = a >>= \a' -> go a' b go a (Effect b) = b >>= \b' -> go a b' go (Yield _ msg a) (Await _ b) = go a (b msg) @@ -134,18 +135,13 @@ connect = go -- | The terminal states for the protocol. Used in 'connect' and -- 'connectPipelined' to return the states in which the peers terminated. -- -data TerminalStates ps (pr :: PeerRole) where +data TerminalStates ps where TerminalStates - :: forall ps pr (st :: ps) (st' :: ps). - Sing st - -> ReflRelativeAgency (StateAgency st) - NobodyHasAgency - (Relative pr (StateAgency st)) - -> Sing st' - -> ReflRelativeAgency (StateAgency st') - NobodyHasAgency - (Relative (FlipAgency pr) (StateAgency st')) - -> TerminalStates ps pr + :: forall ps (st :: ps). + (StateAgency st ~ NobodyAgency) + => Sing st + -> Sing st + -> TerminalStates ps -- -- Remove Pipelining @@ -248,7 +244,7 @@ connectPipelined -> [Bool] -> Peer ps pr ('Pipelined c) Z st m a -> Peer ps (FlipAgency pr) ('Pipelined c') Z st m b - -> m (a, b, TerminalStates ps pr) + -> m (a, b, TerminalStates ps) connectPipelined csA csB a b = connect (forgetPipelined csA a) (forgetPipelined csB b) From 558a9fcecc2d25e2454cc2ab971bbd4c9173535f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 23 Jun 2022 10:10:31 +0200 Subject: [PATCH 17/39] typed-protocols: added StateToken type family to Protocol type class --- .../src/Network/TypedProtocol/PingPong/Type.hs | 2 ++ .../src/Network/TypedProtocol/ReqResp/Type.hs | 2 ++ .../src/Network/TypedProtocol/ReqResp2/Type.hs | 2 ++ .../src/Network/TypedProtocol/Trans/Wedge.hs | 2 ++ typed-protocols/src/Network/TypedProtocol/Core.hs | 12 ++++++++++++ 5 files changed, 20 insertions(+) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs index 794e4fc2..2e21d95b 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs @@ -76,5 +76,7 @@ instance Protocol PingPong where type StateAgency StBusy = ServerAgency type StateAgency StDone = NobodyAgency + type StateToken = SPingPong + deriving instance Show (Message PingPong from to) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs index 2f091821..4c055390 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs @@ -46,6 +46,8 @@ instance Protocol (ReqResp req resp) where type StateAgency StBusy = ServerAgency type StateAgency StDone = NobodyAgency + type StateToken = SReqResp + deriving instance (Show req, Show resp) => Show (Message (ReqResp req resp) from to) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs index 52b1893e..5aebf76a 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs @@ -55,6 +55,8 @@ instance Protocol (ReqResp2 req resp) where type StateAgency StBusy' = ServerAgency type StateAgency StDone = NobodyAgency + type StateToken = SReqResp2 + deriving instance (Show req, Show resp) => Show (Message (ReqResp2 req resp) from to) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs index c1bc2896..c1840559 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs @@ -105,6 +105,8 @@ instance Protocol (Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where type StateAgency (StFst st) = StateAgency st type StateAgency (StSnd st) = StateAgency st + type StateToken = SingWedge + type PingPong2 = Wedge PingPong.PingPong PingPong.StIdle PingPong.PingPong PingPong.StIdle diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 842c964b..48bd9991 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -47,6 +47,8 @@ module Network.TypedProtocol.Core , IsActiveState (..) , ActiveState , notActiveState + -- * Utils + , stateToken ) where import Data.Kind (Constraint, Type) @@ -402,6 +404,16 @@ class Protocol ps where -- type StateAgency (st :: ps) :: Agency + -- | A type alias for protocol state token, e.g. term level representation of + -- type level state (also known as singleton). + -- + type StateToken :: ps -> Type + +-- | An alias for 'sing'. +-- +stateToken :: (SingI st, Sing st ~ StateToken st) => StateToken st +stateToken = sing + type ActiveAgency' :: ps -> Agency -> Type data ActiveAgency' st agency where ClientHasAgency :: StateAgency st ~ ClientAgency From 03270e44d331639251d5679615dc639a2a54eea4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 13 Jul 2022 17:03:02 +0200 Subject: [PATCH 18/39] typed-protocols: renamed Pipelined kind to IsPipelined This allows us to not worry about the promoted type and kind to have the same name. --- .../src/Network/TypedProtocol/PingPong/Client.hs | 6 +++--- .../src/Network/TypedProtocol/ReqResp/Client.hs | 6 +++--- .../src/Network/TypedProtocol/ReqResp2/Client.hs | 6 +++--- .../src/Network/TypedProtocol/Trans/Wedge.hs | 2 +- typed-protocols/src/Network/TypedProtocol/Core.hs | 8 ++++---- typed-protocols/src/Network/TypedProtocol/Peer.hs | 12 ++++++------ .../src/Network/TypedProtocol/Peer/Client.hs | 14 +++++++------- .../src/Network/TypedProtocol/Peer/Server.hs | 14 +++++++------- .../src/Network/TypedProtocol/Proofs.hs | 9 +++++++-- 9 files changed, 41 insertions(+), 36 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs index 5c031f6d..c454a88f 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs @@ -141,7 +141,7 @@ data PingPongClientIdle (n :: Outstanding) c m a where pingPongClientPeerPipelined :: Functor m => PingPongClientPipelined c m a - -> Client PingPong ('Pipelined c) Z StIdle m a + -> Client PingPong (Pipelined c) Z StIdle m a pingPongClientPeerPipelined (PingPongClientPipelined peer) = pingPongClientPeerIdle peer @@ -149,12 +149,12 @@ pingPongClientPeerPipelined (PingPongClientPipelined peer) = pingPongClientPeerIdle :: forall (n :: Outstanding) c m a. Functor m => PingPongClientIdle n c m a - -> Client PingPong ('Pipelined c) n StIdle m a + -> Client PingPong (Pipelined c) n StIdle m a pingPongClientPeerIdle = go where go :: forall (n' :: Outstanding). PingPongClientIdle n' c m a - -> Client PingPong ('Pipelined c) n' StIdle m a + -> Client PingPong (Pipelined c) n' StIdle m a go (SendMsgPingPipelined receive next) = -- Pipelined yield: send `MsgPing`, immediately follow with the next step. diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs index 6f7c5089..5f5409d6 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs @@ -118,7 +118,7 @@ data ReqRespIdle req resp c n m a where reqRespClientPeerPipelined :: Functor m => ReqRespClientPipelined req resp c m a - -> Client (ReqResp req resp) ('Pipelined c) Z StIdle m a + -> Client (ReqResp req resp) (Pipelined c) Z StIdle m a reqRespClientPeerPipelined (ReqRespClientPipelined peer) = reqRespClientPeerIdle peer @@ -127,13 +127,13 @@ reqRespClientPeerIdle :: forall req resp n c m a. Functor m => ReqRespIdle req resp c n m a - -> Client (ReqResp req resp) ('Pipelined c) n StIdle m a + -> Client (ReqResp req resp) (Pipelined c) n StIdle m a reqRespClientPeerIdle = go where go :: forall n'. ReqRespIdle req resp c n' m a - -> Client (ReqResp req resp) ('Pipelined c) n' StIdle m a + -> Client (ReqResp req resp) (Pipelined c) n' StIdle m a go (SendMsgReqPipelined req receive next) = -- Pipelined yield: send `MsgReq`, immediately follow with the next step. diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs index 351ed67f..d4bc7ce8 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs @@ -21,14 +21,14 @@ import Network.TypedProtocol.Peer.Client reqResp2Client :: forall req resp m. () => [Either req req] - -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) Z StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) Z StIdle m [Either resp resp] reqResp2Client = send Zero where -- pipeline all the requests, either through `MsgReq` or `MsgReq'`. send :: forall (n :: N). Nat n -> [Either req req] -- requests to send - -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) n StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) n StIdle m [Either resp resp] send !n (Left req : reqs) = YieldPipelined (MsgReq req) receiver (send (Succ n) reqs) @@ -50,7 +50,7 @@ reqResp2Client = send Zero -- collect all the responses collect :: Nat n -> [Either resp resp] -- all the responses received so far - -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) n StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) n StIdle m [Either resp resp] collect Zero !resps = Yield MsgDone (Done (reverse resps)) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs index c1840559..bfba70d9 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs @@ -125,7 +125,7 @@ pingPong2Client = $ Client.Done () -pingPong2Client' :: forall m. Client.Client PingPong2 ('Pipelined ()) Client.Z StIdle m () +pingPong2Client' :: forall m. Client.Client PingPong2 (Pipelined ()) Client.Z StIdle m () pingPong2Client' = -- -- Pipeline first protocol diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 48bd9991..eca0e0ea 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -41,7 +41,7 @@ module Network.TypedProtocol.Core , TheyHaveAgencyProof , NobodyHasAgencyProof , FlipAgency - , Pipelined (..) + , IsPipelined (..) , ActiveAgency , ActiveAgency' (..) , IsActiveState (..) @@ -476,10 +476,10 @@ type family FlipAgency pr where -- | Promoted data type which indicates if 'Peer' is used in -- pipelined mode or not. -- -data Pipelined where +data IsPipelined where -- | Pipelined peer which is using `c :: Type` for collecting responses -- from a pipelined messages. - Pipelined :: Type -> Pipelined + Pipelined :: Type -> IsPipelined -- | Non-pipelined peer. - NonPipelined :: Pipelined + NonPipelined :: IsPipelined diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 82348858..fdaf5bdd 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -95,7 +95,7 @@ import Network.TypedProtocol.Core as Core -- type Peer :: forall ps -> PeerRole - -> Pipelined + -> IsPipelined -> Outstanding -> ps -> (Type -> Type) @@ -209,9 +209,9 @@ data Peer ps pr pl n st m a where -> Message ps st st' -- ^ protocol message -> Receiver ps pr st' st'' m c - -> Peer ps pr ('Pipelined c) (S n) st'' m a + -> Peer ps pr (Pipelined c) (S n) st'' m a -- ^ continuation - -> Peer ps pr ('Pipelined c) n st m a + -> Peer ps pr (Pipelined c) n st m a -- | Partially collect promised transition. -- @@ -220,11 +220,11 @@ data Peer ps pr pl n st m a where ( SingI st , ActiveState st ) - => Maybe (Peer ps pr ('Pipelined c) (S n) st m a) + => Maybe (Peer ps pr (Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Peer ps pr ('Pipelined c) n st m a) + -> (c -> Peer ps pr (Pipelined c) n st m a) -- ^ continuation - -> Peer ps pr ('Pipelined c) (S n) st m a + -> Peer ps pr (Pipelined c) (S n) st m a deriving instance Functor m => Functor (Peer ps pr pl n st m) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index dcd6de47..ddcaa987 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -24,7 +24,7 @@ module Network.TypedProtocol.Peer.Client , pattern ReceiverAwait , pattern ReceiverDone -- * re-exports - , Pipelined (..) + , IsPipelined (..) , Outstanding , N (..) , Nat (..) @@ -40,7 +40,7 @@ import qualified Network.TypedProtocol.Peer as TP type Client :: forall ps - -> Pipelined + -> IsPipelined -> Outstanding -> ps -> (Type -> Type) @@ -114,9 +114,9 @@ pattern YieldPipelined :: forall ps st n c m a. => Message ps st st' -- ^ pipelined message -> Receiver ps st' st'' m c - -> Client ps ('Pipelined c) (S n) st'' m a + -> Client ps (Pipelined c) (S n) st'' m a -- ^ continuation - -> Client ps ('Pipelined c) n st m a + -> Client ps (Pipelined c) n st m a pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg receiver k @@ -127,11 +127,11 @@ pattern Collect :: forall ps st n c m a. => ( SingI st , ActiveState st ) - => Maybe (Client ps ('Pipelined c) (S n) st m a) + => Maybe (Client ps (Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Client ps ('Pipelined c) n st m a) + -> (c -> Client ps (Pipelined c) n st m a) -- ^ continuation - -> Client ps ('Pipelined c) (S n) st m a + -> Client ps (Pipelined c) (S n) st m a pattern Collect k' k = TP.Collect k' k {-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 9fe9628c..cae718d6 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -24,7 +24,7 @@ module Network.TypedProtocol.Peer.Server , pattern ReceiverAwait , pattern ReceiverDone -- * re-exports - , Pipelined (..) + , IsPipelined (..) , Outstanding , N (..) , Nat (..) @@ -40,7 +40,7 @@ import qualified Network.TypedProtocol.Peer as TP type Server :: forall ps - -> Pipelined + -> IsPipelined -> Outstanding -> ps -> (Type -> Type) @@ -114,9 +114,9 @@ pattern YieldPipelined :: forall ps st n c m a. => Message ps st st' -- ^ pipelined message -> Receiver ps st' st'' m c - -> Server ps ('Pipelined c) (S n) st'' m a + -> Server ps (Pipelined c) (S n) st'' m a -- ^ continuation - -> Server ps ('Pipelined c) n st m a + -> Server ps (Pipelined c) n st m a pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg receiver k @@ -127,11 +127,11 @@ pattern Collect :: forall ps st n c m a. => ( SingI st , ActiveState st ) - => Maybe (Server ps ('Pipelined c) (S n) st m a) + => Maybe (Server ps (Pipelined c) (S n) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Server ps ('Pipelined c) n st m a) + -> (c -> Server ps (Pipelined c) n st m a) -- ^ continuation - -> Server ps ('Pipelined c) (S n) st m a + -> Server ps (Pipelined c) (S n) st m a pattern Collect k' k = TP.Collect k' k diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index 6c291d0b..ce225717 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -172,8 +172,13 @@ forgetPipelined :: forall ps (pr :: PeerRole) (st :: ps) c m a. Functor m => [Bool] - -> Peer ps pr ('Pipelined c) Z st m a - -> Peer ps pr 'NonPipelined Z st m a + -- ^ interleaving choices for pipelining allowed by + -- `Collect` and `CollectSTM` primitive. False values or `[]` give no + -- pipelining. For the 'CollectSTM' primitive, the stm action must not + -- block otherwise even if the choice is to pipeline more (a 'True' value), + -- we'll actually collect a result. + -> Peer ps pr (Pipelined c) Z st m a + -> Peer ps pr NonPipelined Z st m a forgetPipelined = goSender EmptyQ where goSender :: forall st' n. From 6b6118d4485e5ef07f970152a23ae71e549d60fd Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 8 Sep 2023 23:22:06 +0200 Subject: [PATCH 19/39] typed-protocols: added AnyMessageAndAgency pattern synonym --- .../src/Network/TypedProtocol/Codec.hs | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index fb7473d6..cda6f9cf 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} @@ -14,6 +15,7 @@ -- @UndecidableInstances@ extension is required for defining @Show@ instance of -- @'AnyMessage'@ and @'AnyMessage'@. {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module Network.TypedProtocol.Codec ( -- * Defining and using Codecs @@ -36,6 +38,7 @@ module Network.TypedProtocol.Codec , runDecoderPure -- ** Codec properties , AnyMessage (..) + , pattern AnyMessageAndAgency , prop_codecM , prop_codec , prop_codec_splitsM @@ -301,12 +304,34 @@ data AnyMessage ps where => Message ps (st :: ps) (st' :: ps) -> AnyMessage ps + -- requires @UndecidableInstances@ and @QuantifiedConstraints@. instance (forall (st :: ps) (st' :: ps). Show (Message ps st st')) => Show (AnyMessage ps) where show (AnyMessage (msg :: Message ps st st')) = "AnyMessage " ++ show msg + +-- | A convenient pattern synonym which unwrap 'AnyMessage' giving both the +-- singleton for the state and the message. +-- +pattern AnyMessageAndAgency :: forall ps. () + => forall (st :: ps) (st' :: ps). + (SingI st, ActiveState st) + => Sing st + -> Message ps st st' + -> AnyMessage ps +pattern AnyMessageAndAgency sing msg <- AnyMessage (getAgency -> (msg, sing)) + where + AnyMessageAndAgency _ msg = AnyMessage msg +{-# COMPLETE AnyMessageAndAgency #-} + +-- | Internal view pattern for 'AnyMessageAndAgency' +-- +getAgency :: SingI st => Message ps st st' -> (Message ps st st', Sing st) +getAgency msg = (msg, sing) + + -- | The 'Codec' round-trip property: decode after encode gives the same -- message. Every codec must satisfy this property. -- From abecdaf63ab8342d43170c5504eb60a67d604d61 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 26 Sep 2023 17:26:37 +0200 Subject: [PATCH 20/39] typed-protocols: added application specific singletons for protocol states We still have `singletons` as a dependency though. --- .../src/Network/TypedProtocol/Codec/CBOR.hs | 9 ++-- .../Network/TypedProtocol/Driver/Simple.hs | 8 ++-- .../Network/TypedProtocol/PingPong/Codec.hs | 8 ++-- .../TypedProtocol/PingPong/Codec/CBOR.hs | 3 +- .../Network/TypedProtocol/PingPong/Type.hs | 16 +++---- .../Network/TypedProtocol/ReqResp/Codec.hs | 8 ++-- .../TypedProtocol/ReqResp/Codec/CBOR.hs | 3 +- .../src/Network/TypedProtocol/ReqResp/Type.hs | 15 +++--- .../Network/TypedProtocol/ReqResp2/Client.hs | 3 -- .../Network/TypedProtocol/ReqResp2/Type.hs | 19 ++++---- .../src/Network/TypedProtocol/Trans/Wedge.hs | 23 ++++----- .../src/Network/TypedProtocol/Codec.hs | 47 ++++++++++--------- .../src/Network/TypedProtocol/Core.hs | 27 ++++++----- .../src/Network/TypedProtocol/Driver.hs | 11 ++--- .../src/Network/TypedProtocol/Peer.hs | 17 ++++--- .../src/Network/TypedProtocol/Peer/Client.hs | 17 ++++--- .../src/Network/TypedProtocol/Peer/Server.hs | 17 ++++--- .../src/Network/TypedProtocol/Proofs.hs | 8 ++-- 18 files changed, 118 insertions(+), 141 deletions(-) diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index 65a930a5..ee301ca9 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -24,7 +24,6 @@ import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Internal as LBS (smallChunkSize) -import Data.Singletons import Network.TypedProtocol.Codec import Network.TypedProtocol.Core @@ -48,13 +47,13 @@ mkCodecCborStrictBS :: forall ps m. MonadST m => (forall (st :: ps) (st' :: ps). - SingI st + StateTokenI st => ActiveState st => Message ps st st' -> CBOR.Encoding) -> (forall (st :: ps) s. ActiveState st - => Sing st + => StateToken st -> CBOR.Decoder s (SomeMessage st)) -> Codec ps DeserialiseFailure m BS.ByteString @@ -104,13 +103,13 @@ mkCodecCborLazyBS :: forall ps m. MonadST m => (forall (st :: ps) (st' :: ps). - SingI st + StateTokenI st => ActiveState st => Message ps st st' -> CBOR.Encoding) -> (forall (st :: ps) s. ActiveState st - => Sing st + => StateToken st -> CBOR.Decoder s (SomeMessage st)) -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 8bcf50b5..39e0afef 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -32,8 +32,6 @@ module Network.TypedProtocol.Driver.Simple , runDecoderWithChannel ) where -import Data.Singletons - import Network.TypedProtocol.Channel import Network.TypedProtocol.Codec import Network.TypedProtocol.Core @@ -91,7 +89,7 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = Driver { sendMessage, recvMessage, initialDState = Nothing } where sendMessage :: forall (st :: ps) (st' :: ps). - ( SingI st + ( StateTokenI st , ActiveState st ) => ReflRelativeAgency (StateAgency st) @@ -104,7 +102,7 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = traceWith tracer (TraceSendMsg (AnyMessage msg)) recvMessage :: forall (st :: ps). - ( SingI st + ( StateTokenI st , ActiveState st ) => ReflRelativeAgency (StateAgency st) @@ -113,7 +111,7 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} = -> Maybe bytes -> m (SomeMessage st, Maybe bytes) recvMessage !_refl trailing = do - decoder <- decode sing + decoder <- decode stateToken result <- runDecoderWithChannel channel trailing decoder case result of Right x@(SomeMessage msg, _trailing') -> do diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs index e987276a..f825dae7 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec.hs @@ -7,8 +7,6 @@ module Network.TypedProtocol.PingPong.Codec where -import Data.Singletons - import Network.TypedProtocol.Codec import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Type @@ -29,7 +27,7 @@ codecPingPong = decode :: forall (st :: PingPong). ActiveState st - => Sing st + => StateToken st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode stok = decodeTerminatedFrame '\n' $ \str trailing -> @@ -72,7 +70,7 @@ codecPingPongId = Codec{encode,decode} where encode :: forall (st :: PingPong) (st' :: PingPong) - . ( SingI st + . ( StateTokenI st , ActiveState st ) => Message PingPong st st' @@ -81,7 +79,7 @@ codecPingPongId = decode :: forall (st :: PingPong). ActiveState st - => Sing st + => StateToken st -> m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) decode stok = pure $ DecodePartial $ \mb -> diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs index df891f01..0d674a3b 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Codec/CBOR.hs @@ -10,7 +10,6 @@ module Network.TypedProtocol.PingPong.Codec.CBOR where import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) -import Data.Singletons import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeWord) import qualified Codec.CBOR.Encoding as CBOR (Encoding, encodeWord) @@ -36,7 +35,7 @@ codecPingPong = mkCodecCborLazyBS encodeMsg decodeMsg decodeMsg :: forall s (st :: PingPong). ActiveState st - => Sing st + => StateToken st -> CBOR.Decoder s (SomeMessage st) decodeMsg stok = do key <- CBOR.decodeWord diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs index 2e21d95b..98ac0f73 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs @@ -8,8 +8,6 @@ module Network.TypedProtocol.PingPong.Type where -import Data.Singletons - import Network.TypedProtocol.Core @@ -44,14 +42,12 @@ data SPingPong (st :: PingPong) where deriving instance Show (SPingPong st) -type instance Sing = SPingPong -instance SingI StIdle where - sing = SingIdle -instance SingI StBusy where - sing = SingBusy -instance SingI StDone where - sing = SingDone - +instance StateTokenI StIdle where + stateToken = SingIdle +instance StateTokenI StBusy where + stateToken = SingBusy +instance StateTokenI StDone where + stateToken = SingDone instance Protocol PingPong where diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs index 5a5dfc89..95e77c27 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs @@ -8,8 +8,6 @@ module Network.TypedProtocol.ReqResp.Codec where -import Data.Singletons - import Network.TypedProtocol.Codec import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) @@ -35,7 +33,7 @@ codecReqResp = decode :: forall req' resp' m' (st :: ReqResp req' resp') . (Monad m', Read req', Read resp', ActiveState st) - => Sing st + => StateToken st -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) decode stok = decodeTerminatedFrame '\n' $ \str trailing -> @@ -62,7 +60,7 @@ codecReqRespId = where encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp) - . SingI st + . StateTokenI st => ActiveState st => Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp) @@ -70,7 +68,7 @@ codecReqRespId = decode :: forall (st :: ReqResp req resp) . ActiveState st - => Sing st + => StateToken st -> m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) decode stok = pure $ DecodePartial $ \mb -> diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs index 5ece5605..0f12bb3b 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec/CBOR.hs @@ -10,7 +10,6 @@ module Network.TypedProtocol.ReqResp.Codec.CBOR where import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) -import Data.Singletons import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeListLen, decodeWord) @@ -46,7 +45,7 @@ codecReqResp = mkCodecCborLazyBS encodeMsg decodeMsg decodeMsg :: forall s (st :: ReqResp req resp). ActiveState st - => Sing st + => StateToken st -> CBOR.Decoder s (SomeMessage st) decodeMsg stok = do _ <- CBOR.decodeListLen diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs index 4c055390..bd41a9f5 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Type.hs @@ -9,8 +9,6 @@ module Network.TypedProtocol.ReqResp.Type where -import Data.Singletons - import Network.TypedProtocol.Core @@ -26,13 +24,12 @@ data SReqResp (st :: ReqResp req resp) where deriving instance Show (SReqResp st) -type instance Sing = SReqResp -instance SingI StIdle where - sing = SingIdle -instance SingI StBusy where - sing = SingBusy -instance SingI StDone where - sing = SingDone +instance StateTokenI StIdle where + stateToken = SingIdle +instance StateTokenI StBusy where + stateToken = SingBusy +instance StateTokenI StDone where + stateToken = SingDone instance Protocol (ReqResp req resp) where diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs index d4bc7ce8..37458220 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs @@ -1,12 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs index 5aebf76a..14a567b0 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs @@ -9,8 +9,6 @@ module Network.TypedProtocol.ReqResp2.Type where -import Data.Singletons - import Network.TypedProtocol.Core @@ -28,15 +26,14 @@ data SReqResp2 (st :: ReqResp2 req resp) where deriving instance Show (SReqResp2 st) -type instance Sing = SReqResp2 -instance SingI StIdle where - sing = SingIdle -instance SingI StBusy where - sing = SingBusy -instance SingI StBusy' where - sing = SingBusy' -instance SingI StDone where - sing = SingDone +instance StateTokenI StIdle where + stateToken = SingIdle +instance StateTokenI StBusy where + stateToken = SingBusy +instance StateTokenI StBusy' where + stateToken = SingBusy' +instance StateTokenI StDone where + stateToken = SingDone instance Protocol (ReqResp2 req resp) where diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs index bfba70d9..d01ddd45 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs @@ -15,8 +15,6 @@ module Network.TypedProtocol.Trans.Wedge where -import Data.Singletons - import Network.TypedProtocol.Core import qualified Network.TypedProtocol.Peer.Client as Client @@ -37,25 +35,24 @@ data Wedge ps (stIdle :: ps) ps' (stIdle' :: ps') where data SingWedge (st :: Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where SingStIdle :: SingWedge StIdle - SingStFst :: Sing st + SingStFst :: StateToken st -> SingWedge (StFst st) - SingStSnd :: Sing st' + SingStSnd :: StateToken st' -> SingWedge (StSnd st') instance Show (SingWedge StIdle) where show SingStIdle = "SingStIdle" -instance Show (Sing st) => Show (SingWedge (StFst st)) where +instance Show (StateToken st) => Show (SingWedge (StFst st)) where show (SingStFst s) = "SingStFst " ++ show s -instance Show (Sing st) => Show (SingWedge (StSnd st)) where +instance Show (StateToken st) => Show (SingWedge (StSnd st)) where show (SingStSnd s) = "SingStSnd " ++ show s -type instance Sing = SingWedge -instance SingI StIdle where - sing = SingStIdle -instance SingI st => SingI (StFst st) where - sing = SingStFst (sing @st) -instance SingI st => SingI (StSnd st) where - sing = SingStSnd (sing @st) +instance StateTokenI StIdle where + stateToken = SingStIdle +instance StateTokenI st => StateTokenI (StFst st) where + stateToken = SingStFst (stateToken @st) +instance StateTokenI st => StateTokenI (StSnd st) where + stateToken = SingStSnd (stateToken @st) -- | A Singleton type which allows to pick the starting protocol state. diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index cda6f9cf..246cd5e7 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -48,14 +48,15 @@ module Network.TypedProtocol.Codec , prop_codecs_compatM , prop_codecs_compat , SomeState (..) + -- ** StateToken + , StateToken + , StateTokenI (..) ) where import Control.Exception (Exception) import Data.Kind (Type) import Data.Monoid (All (..)) -import Data.Singletons - import Network.TypedProtocol.Core import Network.TypedProtocol.Driver (SomeMessage (..)) @@ -115,7 +116,7 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- > => m (DecodeStep String String m (SomeMessage st)) -- > decode = -- > decodeTerminatedFrame '\n' $ \str trailing -> --- > case (sing :: Sing st, str) of +-- > case (stateToken :: StateToken st, str) of -- > (TokBusy, "pong") -> -- > DecodeDone (SomeMessage MsgPong) trailing -- > (TokIdle, "ping") -> @@ -134,14 +135,14 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- data Codec ps failure m bytes = Codec { encode :: forall (st :: ps) (st' :: ps). - SingI st + StateTokenI st => ActiveState st => Message ps st st' -> bytes, decode :: forall (st :: ps). ActiveState st - => Sing st + => StateToken st -> m (DecodeStep bytes failure m (SomeMessage st)) } @@ -290,7 +291,7 @@ runDecoderPure runM decoder bs = runM (runDecoder bs =<< decoder) -- Codec properties -- --- | Any message for a protocol, with a 'SingI' constraint which gives access to +-- | Any message for a protocol, with a 'StateTokenI' constraint which gives access to -- protocol state. -- -- Used where we don't know statically what the state type is, but need the @@ -298,7 +299,7 @@ runDecoderPure runM decoder bs = runM (runDecoder bs =<< decoder) -- data AnyMessage ps where AnyMessage :: forall ps (st :: ps) (st' :: ps). - ( SingI st + ( StateTokenI st , ActiveState st ) => Message ps (st :: ps) (st' :: ps) @@ -317,19 +318,19 @@ instance (forall (st :: ps) (st' :: ps). Show (Message ps st st')) -- pattern AnyMessageAndAgency :: forall ps. () => forall (st :: ps) (st' :: ps). - (SingI st, ActiveState st) - => Sing st + (StateTokenI st, ActiveState st) + => StateToken st -> Message ps st st' -> AnyMessage ps -pattern AnyMessageAndAgency sing msg <- AnyMessage (getAgency -> (msg, sing)) +pattern AnyMessageAndAgency stateToken msg <- AnyMessage (getAgency -> (msg, stateToken)) where AnyMessageAndAgency _ msg = AnyMessage msg {-# COMPLETE AnyMessageAndAgency #-} -- | Internal view pattern for 'AnyMessageAndAgency' -- -getAgency :: SingI st => Message ps st st' -> (Message ps st st', Sing st) -getAgency msg = (msg, sing) +getAgency :: StateTokenI st => Message ps st st' -> (Message ps st st', StateToken st) +getAgency msg = (msg, stateToken) -- | The 'Codec' round-trip property: decode after encode gives the same @@ -344,7 +345,7 @@ prop_codecM -> AnyMessage ps -> m Bool prop_codecM Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do - r <- decode sing >>= runDecoder [encode msg] + r <- decode stateToken >>= runDecoder [encode msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $ AnyMessage msg' == AnyMessage msg Left _ -> return False @@ -383,7 +384,7 @@ prop_codec_splitsM prop_codec_splitsM splits Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do and <$> sequence - [ do r <- decode sing >>= runDecoder bytes' + [ do r <- decode stateToken >>= runDecoder bytes' case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! AnyMessage msg' == AnyMessage msg Left _ -> return False @@ -415,7 +416,7 @@ data SomeState (ps :: Type) where SomeState :: forall ps (st :: ps). ActiveState st - => Sing st + => StateToken st -> SomeState ps -- | Binary compatibility of two protocols @@ -438,17 +439,17 @@ prop_codec_binary_compatM ) => Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall (stA :: psA). ActiveState stA => Sing stA -> SomeState psB) + -> (forall (stA :: psA). ActiveState stA => StateToken stA -> SomeState psB) -- ^ The states of A map directly of states of B. -> AnyMessage psA -> m Bool prop_codec_binary_compatM codecA codecB stokEq (AnyMessage (msgA :: Message psA stA stA')) = - let stokA :: Sing stA - stokA = sing + let stokA :: StateToken stA + stokA = stateToken in case stokEq stokA of - SomeState (stokB :: Sing stB) -> do + SomeState (stokB :: StateToken stB) -> do -- 1. let bytesA = encode codecA msgA -- 2. @@ -459,7 +460,7 @@ prop_codec_binary_compatM -- 3. let bytesB = encode codecB msgB -- 4. - r2 <- decode codecA (sing :: Sing stA) >>= runDecoder [bytesB] + r2 <- decode codecA (stateToken :: StateToken stA) >>= runDecoder [bytesB] case r2 :: Either failure (SomeMessage stA) of Left _ -> return False Right (SomeMessage msgA') -> return $ AnyMessage msgA' == AnyMessage msgA @@ -473,7 +474,7 @@ prop_codec_binary_compat => (forall a. m a -> a) -> Codec psA failure m bytes -> Codec psB failure m bytes - -> (forall (stA :: psA). Sing stA -> SomeState psB) + -> (forall (stA :: psA). StateToken stA -> SomeState psB) -> AnyMessage psA -> Bool prop_codec_binary_compat runM codecA codecB stokEq msgA = @@ -496,11 +497,11 @@ prop_codecs_compatM -> m Bool prop_codecs_compatM codecA codecB (AnyMessage (msg :: Message ps st st')) = - getAll <$> do r <- decode codecB (sing :: Sing st) >>= runDecoder [encode codecA msg] + getAll <$> do r <- decode codecB (stateToken :: StateToken st) >>= runDecoder [encode codecA msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False - <> do r <- decode codecA (sing :: Sing st) >>= runDecoder [encode codecB msg] + <> do r <- decode codecA (stateToken :: StateToken st) >>= runDecoder [encode codecB msg] case r :: Either failure (SomeMessage st) of Right (SomeMessage msg') -> return $! All $ AnyMessage msg' == AnyMessage msg Left _ -> return $! All False diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index eca0e0ea..a0ac602e 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -18,16 +18,15 @@ -- need for 'Show' instance of 'ProtocolState' {-# LANGUAGE UndecidableInstances #-} - -- | This module defines the core of the typed protocol framework. -- - module Network.TypedProtocol.Core ( -- * Introduction -- $intro -- * Defining protocols -- $defining Protocol (..) + , StateTokenI (..) -- $lemmas -- * Engaging in protocols , PeerRole (..) @@ -47,8 +46,6 @@ module Network.TypedProtocol.Core , IsActiveState (..) , ActiveState , notActiveState - -- * Utils - , stateToken ) where import Data.Kind (Constraint, Type) @@ -372,6 +369,15 @@ type NobodyHasAgencyProof pr st = ReflRelativeAgency (StateAgency st) -- These lemmas are proven for all protocols. -- +-- | A type class which hides a state token / singleton inside a class +-- dictionary. +-- +-- This is similar to the 'SingI' instance, but specific to protocol state +-- singletons. +-- +class StateTokenI st where + stateToken :: StateToken st + -- | The protocol type class bundles up all the requirements for a typed -- protocol. -- @@ -404,15 +410,14 @@ class Protocol ps where -- type StateAgency (st :: ps) :: Agency - -- | A type alias for protocol state token, e.g. term level representation of + -- | A type family for protocol state token, e.g. term level representation of -- type level state (also known as singleton). -- + -- This type family is similar to 'Sing' type class in the "singletons" + -- package, but specific for protocol states. + -- type StateToken :: ps -> Type --- | An alias for 'sing'. --- -stateToken :: (SingI st, Sing st ~ StateToken st) => StateToken st -stateToken = sing type ActiveAgency' :: ps -> Agency -> Type data ActiveAgency' st agency where @@ -459,9 +464,9 @@ type ActiveState st = IsActiveState st (StateAgency st) notActiveState :: forall ps (st :: ps). StateAgency st ~ NobodyAgency => ActiveState st - => Sing st + => StateToken st -> forall a. a -notActiveState (_ :: Sing st) = +notActiveState (_ :: StateToken st) = case activeAgency :: ActiveAgency st of {} diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index f87276bb..569d94bd 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -23,7 +23,6 @@ module Network.TypedProtocol.Driver , runPipelinedPeerWithDriver ) where -import Data.Singletons import Data.Void (Void) import Network.TypedProtocol.Core @@ -68,15 +67,15 @@ import Control.Monad.Class.MonadSTM data Driver ps (pr :: PeerRole) dstate m = Driver { sendMessage :: forall (st :: ps) (st' :: ps). - SingI st - => SingI st' + StateTokenI st + => StateTokenI st' => ActiveState st => WeHaveAgencyProof pr st -> Message ps st st' -> m () , recvMessage :: forall (st :: ps). - SingI st + StateTokenI st => ActiveState st => TheyHaveAgencyProof pr st -> dstate @@ -92,8 +91,8 @@ data Driver ps (pr :: PeerRole) dstate m = -- type to hide the \"to"\ state. -- data SomeMessage (st :: ps) where - SomeMessage :: ( SingI st - , SingI st' + SomeMessage :: ( StateTokenI st + , StateTokenI st' , ActiveState st ) => Message ps st st' -> SomeMessage st diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index fdaf5bdd..010fed04 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -28,7 +28,6 @@ module Network.TypedProtocol.Peer ) where import Data.Kind (Type) -import Data.Singletons import Unsafe.Coerce (unsafeCoerce) import Network.TypedProtocol.Core as Core @@ -128,8 +127,8 @@ data Peer ps pr pl n st m a where -- Yield :: forall ps pr pl (st :: ps) (st' :: ps) m a. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , ActiveState st ) => WeHaveAgencyProof pr st @@ -159,7 +158,7 @@ data Peer ps pr pl n st m a where -- Await :: forall ps pr pl (st :: ps) m a. - ( SingI st + ( StateTokenI st , ActiveState st ) => TheyHaveAgencyProof pr st @@ -181,7 +180,7 @@ data Peer ps pr pl n st m a where -- Done :: forall ps pr pl (st :: ps) m a. - ( SingI st + ( StateTokenI st , StateAgency st ~ NobodyAgency ) => NobodyHasAgencyProof pr st @@ -200,8 +199,8 @@ data Peer ps pr pl n st m a where -- YieldPipelined :: forall ps pr (st :: ps) (st' :: ps) c n st'' m a. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , ActiveState st ) => WeHaveAgencyProof pr st @@ -217,7 +216,7 @@ data Peer ps pr pl n st m a where -- Collect :: forall ps pr c n st m a. - ( SingI st + ( StateTokenI st , ActiveState st ) => Maybe (Peer ps pr (Pipelined c) (S n) st m a) @@ -248,7 +247,7 @@ data Receiver ps pr st stdone m c where ReceiverDone :: c -> Receiver ps pr stdone stdone m c - ReceiverAwait :: ( SingI st + ReceiverAwait :: ( StateTokenI st , ActiveState st ) => TheyHaveAgencyProof pr st diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index ddcaa987..e45c315f 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -31,7 +31,6 @@ module Network.TypedProtocol.Peer.Client ) where import Data.Kind (Type) -import Data.Singletons import Network.TypedProtocol.Core import Network.TypedProtocol.Peer (Peer, N (..), @@ -63,8 +62,8 @@ pattern Effect mclient = TP.Effect mclient pattern Yield :: forall ps pl st m a. () => forall st'. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , StateAgency st ~ ClientAgency ) => Message ps st st' @@ -79,7 +78,7 @@ pattern Yield msg k = TP.Yield ReflClientAgency msg k -- pattern Await :: forall ps pl st m a. () - => ( SingI st + => ( StateTokenI st , StateAgency st ~ ServerAgency ) => (forall st'. Message ps st st' @@ -93,7 +92,7 @@ pattern Await k = TP.Await ReflServerAgency k -- pattern Done :: forall ps pl st m a. () - => ( SingI st + => ( StateTokenI st , StateAgency st ~ NobodyAgency ) => a @@ -107,8 +106,8 @@ pattern Done a = TP.Done ReflNobodyAgency a pattern YieldPipelined :: forall ps st n c m a. () => forall st' st''. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , StateAgency st ~ ClientAgency ) => Message ps st st' @@ -124,7 +123,7 @@ pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg r -- pattern Collect :: forall ps st n c m a. () - => ( SingI st + => ( StateTokenI st , ActiveState st ) => Maybe (Client ps (Pipelined c) (S n) st m a) @@ -146,7 +145,7 @@ pattern ReceiverEffect k = TP.ReceiverEffect k pattern ReceiverAwait :: forall ps st stdone m c. () - => ( SingI st + => ( StateTokenI st , ActiveState st , StateAgency st ~ ServerAgency ) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index cae718d6..5ffbdbc8 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -31,7 +31,6 @@ module Network.TypedProtocol.Peer.Server ) where import Data.Kind (Type) -import Data.Singletons import Network.TypedProtocol.Core import Network.TypedProtocol.Peer (Peer, N (..), @@ -63,8 +62,8 @@ pattern Effect mclient = TP.Effect mclient pattern Yield :: forall ps pl st m a. () => forall st'. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , StateAgency st ~ ServerAgency ) => Message ps st st' @@ -79,7 +78,7 @@ pattern Yield msg k = TP.Yield ReflServerAgency msg k -- pattern Await :: forall ps pl st m a. () - => ( SingI st + => ( StateTokenI st , StateAgency st ~ ClientAgency ) => (forall st'. Message ps st st' @@ -93,7 +92,7 @@ pattern Await k = TP.Await ReflClientAgency k -- pattern Done :: forall ps pl st m a. () - => ( SingI st + => ( StateTokenI st , StateAgency st ~ NobodyAgency ) => a @@ -107,8 +106,8 @@ pattern Done a = TP.Done ReflNobodyAgency a pattern YieldPipelined :: forall ps st n c m a. () => forall st' st''. - ( SingI st - , SingI st' + ( StateTokenI st + , StateTokenI st' , StateAgency st ~ ServerAgency ) => Message ps st st' @@ -124,7 +123,7 @@ pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg r -- pattern Collect :: forall ps st n c m a. () - => ( SingI st + => ( StateTokenI st , ActiveState st ) => Maybe (Server ps (Pipelined c) (S n) st m a) @@ -147,7 +146,7 @@ pattern ReceiverEffect k = TP.ReceiverEffect k pattern ReceiverAwait :: forall ps st stdone m c. () - => ( SingI st + => ( StateTokenI st , ActiveState st , StateAgency st ~ ClientAgency ) diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index ce225717..400b1425 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -97,8 +97,8 @@ connect = go return (a, b, terminals) where terminals :: TerminalStates ps - terminals = TerminalStates (sing :: Sing st) - (sing :: Sing st) + terminals = TerminalStates (stateToken :: StateToken st) + (stateToken :: StateToken st) go (Effect a ) b = a >>= \a' -> go a' b go a (Effect b) = b >>= \b' -> go a b' @@ -139,8 +139,8 @@ data TerminalStates ps where TerminalStates :: forall ps (st :: ps). (StateAgency st ~ NobodyAgency) - => Sing st - -> Sing st + => StateToken st + -> StateToken st -> TerminalStates ps -- From a81caa1f63e72fb0d3f92aeed8217bcd62a3a5af Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 1 Jul 2022 09:27:29 +0200 Subject: [PATCH 21/39] typed-protocols-examples: relaxed constraint in PingPong client Functor constraint is enough. --- .../src/Network/TypedProtocol/PingPong/Client.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs index c454a88f..8f89c843 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs @@ -52,7 +52,7 @@ data PingPongClient m a where -- 'PingPong' protocol. -- pingPongClientPeer - :: Monad m + :: Functor m => PingPongClient m a -> Client PingPong NonPipelined Z StIdle m a @@ -76,9 +76,7 @@ pingPongClientPeer (SendMsgPing next) = -- one corresponding continuation 'kPong' to handle that response. -- The pong reply has no content so there's nothing to pass to our -- continuation, but if there were we would. - Effect $ do - client <- next - pure $ pingPongClientPeer client + Effect $ pingPongClientPeer <$> next -- From 166f5af00d6feef723dbb4761f9e8e6f391ec2bf Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 17 Aug 2022 16:00:42 +0200 Subject: [PATCH 22/39] typed-protocols-examples: fixed a socket test on macos --- .../test/Network/TypedProtocol/PingPong/Tests.hs | 6 +++++- .../test/Network/TypedProtocol/ReqResp/Tests.hs | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 86b7c130..763bcc49 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -349,7 +349,11 @@ prop_namedPipePipelined_IO (NonNegative n) = ioProperty $ do prop_socketPipelined_IO :: NonNegative Int -> Property prop_socketPipelined_IO (NonNegative n) = ioProperty $ do - ai : _ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") Nothing + ai : _ <- Socket.getAddrInfo (Just Socket.defaultHints + { Socket.addrFamily = Socket.AF_INET, + Socket.addrFlags = [Socket.AI_PASSIVE], + Socket.addrSocketType = Socket.Stream }) + (Just "127.0.0.1") Nothing bracket ((,) <$> Socket.openSocket ai <*> Socket.openSocket ai) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 1cf0d54e..19a04d5a 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -265,7 +265,11 @@ prop_namedPipePipelined_IO f xs = ioProperty $ do prop_socketPipelined_IO :: (Int -> Int -> (Int, Int)) -> [Int] -> Property prop_socketPipelined_IO f xs = ioProperty $ do - ai : _ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") Nothing + ai : _ <- Socket.getAddrInfo (Just Socket.defaultHints + { Socket.addrFamily = Socket.AF_INET, + Socket.addrFlags = [Socket.AI_PASSIVE], + Socket.addrSocketType = Socket.Stream }) + (Just "127.0.0.1") Nothing bracket ((,) <$> Socket.openSocket ai <*> Socket.openSocket ai) From f5ccedd81f1d5eb7016ebb5be010c34c76da50e4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 25 Aug 2023 16:06:17 +0200 Subject: [PATCH 23/39] typed-protocols: bump version to `0.2.0.0` --- typed-protocols-examples/typed-protocols-examples.cabal | 2 +- typed-protocols/typed-protocols.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 5a04a18c..eba310df 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -57,7 +57,7 @@ library si-timers, network, time, - typed-protocols, + typed-protocols ^>= 0.2, typed-protocols-cborg hs-source-dirs: src diff --git a/typed-protocols/typed-protocols.cabal b/typed-protocols/typed-protocols.cabal index 7db0b84f..a178384e 100644 --- a/typed-protocols/typed-protocols.cabal +++ b/typed-protocols/typed-protocols.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: typed-protocols -version: 0.1.1.0 +version: 0.2.0.0 synopsis: A framework for strongly typed protocols -- description: license: Apache-2.0 From 148a91bd302542fea0709e5297adc00d65d74179 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 17 May 2022 07:38:46 +0200 Subject: [PATCH 24/39] Added CHANGELOG and bumped versions of the packages --- .../typed-protocols-cborg.cabal | 2 +- .../typed-protocols-examples.cabal | 2 +- typed-protocols/CHANGELOG.md | 18 ++++++++++++++++++ 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/typed-protocols-cborg/typed-protocols-cborg.cabal b/typed-protocols-cborg/typed-protocols-cborg.cabal index b7a80a80..cda8d8ad 100644 --- a/typed-protocols-cborg/typed-protocols-cborg.cabal +++ b/typed-protocols-cborg/typed-protocols-cborg.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: typed-protocols-cborg -version: 0.1.0.4 +version: 0.2.0.0 synopsis: CBOR codecs for typed-protocols -- description: license: Apache-2.0 diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index eba310df..8f2beaa2 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: typed-protocols-examples -version: 0.2.0.2 +version: 0.3.0.0 synopsis: Examples and tests for the typed-protocols framework -- description: license: Apache-2.0 diff --git a/typed-protocols/CHANGELOG.md b/typed-protocols/CHANGELOG.md index 59c0ee18..8ad6716b 100644 --- a/typed-protocols/CHANGELOG.md +++ b/typed-protocols/CHANGELOG.md @@ -1,6 +1,24 @@ # Revision history for typed-protocols +## [Unreleased] + +- A major redesign of `typed-protocols`. `Protocol` class requires data family + `Message` and new associated type familiy instance `StateAgency`. One also + needs to define singletons and `Sing` & `SingI` instances from the + [`singletons`][singletons-3.0.1] package. + ## 0.1.1.1 * unbuildable (with `base < 0` constraint in CHaP); We cannot support `io-classes-1.{6,7}` until `Haskell.Nix` support for public sublibraries is merged. + +## 0.1.0.7 -- 2023-10-20 + +* Improved performance of `prop_codecs_splitsM` and `prop_codecs_compatM`. + +## 0.1.0.5 -- 2023-03-08 + +* Support `ghc-9.6.1`. +* Use `io-classes-1.1.0.0`. + +[singletons-3.0.1]: https://hackage.haskell.org/package/singletons From 6c6a8ce9abc3a6a1bb50407353f384ef15532d04 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 23 Jul 2024 09:21:19 +0200 Subject: [PATCH 25/39] typed-protocols: moved outstanding counter into IsPipelined kind --- .../Network/TypedProtocol/Driver/Simple.hs | 16 +++---- .../Network/TypedProtocol/PingPong/Client.hs | 18 ++++---- .../Network/TypedProtocol/PingPong/Server.hs | 2 +- .../Network/TypedProtocol/ReqResp/Client.hs | 34 +++++++------- .../Network/TypedProtocol/ReqResp/Examples.hs | 4 +- .../Network/TypedProtocol/ReqResp/Server.hs | 2 +- .../Network/TypedProtocol/ReqResp2/Client.hs | 6 +-- .../src/Network/TypedProtocol/Trans/Wedge.hs | 4 +- .../Network/TypedProtocol/ReqResp/Tests.hs | 2 +- .../src/Network/TypedProtocol/Core.hs | 18 +++++++- .../src/Network/TypedProtocol/Driver.hs | 10 ++-- .../src/Network/TypedProtocol/Peer.hs | 46 ++++++++----------- .../src/Network/TypedProtocol/Peer/Client.hs | 35 +++++++------- .../src/Network/TypedProtocol/Peer/Server.hs | 35 +++++++------- .../src/Network/TypedProtocol/Proofs.hs | 28 +++++------ 15 files changed, 134 insertions(+), 126 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index 39e0afef..a76f3924 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -131,7 +131,7 @@ runPeer => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> Peer ps pr 'NonPipelined Z st m a + -> Peer ps pr 'NonPipelined st m a -> m (a, Maybe bytes) runPeer tracer codec channel peer = runPeerWithDriver driver peer @@ -152,7 +152,7 @@ runPipelinedPeer => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps pr ('Pipelined Z c) st m a -> m (a, Maybe bytes) runPipelinedPeer tracer codec channel peer = runPipelinedPeerWithDriver driver peer @@ -196,8 +196,8 @@ runConnectedPeers :: (MonadAsync m, MonadCatch m, => m (Channel m bytes, Channel m bytes) -> Tracer m (Role, TraceSendRecv ps) -> Codec ps failure m bytes - -> Peer ps pr 'NonPipelined Z st m a - -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b + -> Peer ps pr 'NonPipelined st m a + -> Peer ps (FlipAgency pr) 'NonPipelined st m b -> m (a, b) runConnectedPeers createChannels tracer codec client server = createChannels >>= \(clientChannel, serverChannel) -> @@ -214,8 +214,8 @@ runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m, => m (Channel m bytes, Channel m bytes) -> Tracer m (PeerRole, TraceSendRecv ps) -> Codec ps failure m bytes - -> Peer ps pr ('Pipelined c) Z st m a - -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b + -> Peer ps pr ('Pipelined Z c) st m a + -> Peer ps (FlipAgency pr) 'NonPipelined st m b -> m (a, b) runConnectedPeersPipelined createChannels tracer codec client server = createChannels >>= \(clientChannel, serverChannel) -> @@ -240,8 +240,8 @@ runConnectedPeersAsymmetric -> Tracer m (Role, TraceSendRecv ps) -> Codec ps failure m bytes -> Codec ps failure m bytes - -> Peer ps pr ('Pipelined c) Z st m a - -> Peer ps (FlipAgency pr) 'NonPipelined Z st m b + -> Peer ps pr ('Pipelined Z c) st m a + -> Peer ps (FlipAgency pr) 'NonPipelined st m b -> m (a, b) runConnectedPeersAsymmetric createChannels tracer codec codec' client server = createChannels >>= \(clientChannel, serverChannel) -> diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs index 8f89c843..003e21dc 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs @@ -54,7 +54,7 @@ data PingPongClient m a where pingPongClientPeer :: Functor m => PingPongClient m a - -> Client PingPong NonPipelined Z StIdle m a + -> Client PingPong NonPipelined StIdle m a pingPongClientPeer (SendMsgDone result) = -- We do an actual transition using 'yield', to go from the 'StIdle' to @@ -94,7 +94,7 @@ data PingPongClientPipelined c m a where -> PingPongClientPipelined c m a -data PingPongClientIdle (n :: Outstanding) c m a where +data PingPongClientIdle (n :: N) c m a where -- | Send a `Ping` message but alike in `PingPongClient` do not await for the -- response, instead supply a monadic action which will run on a received -- `Pong` message. @@ -139,20 +139,20 @@ data PingPongClientIdle (n :: Outstanding) c m a where pingPongClientPeerPipelined :: Functor m => PingPongClientPipelined c m a - -> Client PingPong (Pipelined c) Z StIdle m a + -> Client PingPong (Pipelined Z c) StIdle m a pingPongClientPeerPipelined (PingPongClientPipelined peer) = pingPongClientPeerIdle peer pingPongClientPeerIdle - :: forall (n :: Outstanding) c m a. Functor m - => PingPongClientIdle n c m a - -> Client PingPong (Pipelined c) n StIdle m a + :: forall (n :: N) c m a. Functor m + => PingPongClientIdle n c m a + -> Client PingPong (Pipelined n c) StIdle m a pingPongClientPeerIdle = go where - go :: forall (n' :: Outstanding). - PingPongClientIdle n' c m a - -> Client PingPong (Pipelined c) n' StIdle m a + go :: forall (n' :: N). + PingPongClientIdle n' c m a + -> Client PingPong (Pipelined n' c) StIdle m a go (SendMsgPingPipelined receive next) = -- Pipelined yield: send `MsgPing`, immediately follow with the next step. diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs index 53f27954..768b9621 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Server.hs @@ -26,7 +26,7 @@ data PingPongServer m a = PingPongServer { pingPongServerPeer :: Monad m => PingPongServer m a - -> Server PingPong NonPipelined Z StIdle m a + -> Server PingPong NonPipelined StIdle m a pingPongServerPeer PingPongServer{..} = -- In the 'StIdle' the server is awaiting a request message diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs index 5f5409d6..495976a8 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs @@ -37,7 +37,7 @@ data ReqRespClient req resp m a where reqRespClientPeer :: Monad m => ReqRespClient req resp m a - -> Client (ReqResp req resp) NonPipelined Z StIdle m a + -> Client (ReqResp req resp) NonPipelined StIdle m a reqRespClientPeer (SendMsgDone result) = -- We do an actual transition using 'yield', to go from the 'StIdle' to @@ -68,7 +68,7 @@ reqRespClientPeer (SendMsgReq req next) = requestOnce :: forall req resp m. Monad m - => (forall x. Server (ReqResp req resp) NonPipelined Z StIdle m x) + => (forall x. Server (ReqResp req resp) NonPipelined StIdle m x) -> (req -> m resp) requestOnce server req = (\(resp, _, _) -> resp) <$> reqRespClientPeer client `connect` server @@ -88,28 +88,28 @@ data ReqRespClientPipelined req resp c m a where -- | A 'PingPongSender', but starting with zero outstanding pipelined -- responses, and for any internal collect type @c@. ReqRespClientPipelined :: - ReqRespIdle req resp c Z m a - -> ReqRespClientPipelined req resp c m a + ReqRespIdle req resp Z c m a + -> ReqRespClientPipelined req resp c m a -data ReqRespIdle req resp c n m a where +data ReqRespIdle req resp n c m a where -- | Send a `Req` message but alike in `ReqRespClient` do not await for the -- resopnse, instead supply a monadic action which will run on a received -- `Pong` message. SendMsgReqPipelined :: req -> (resp -> m c) -- receive action - -> ReqRespIdle req resp c (S n) m a -- continuation - -> ReqRespIdle req resp c n m a + -> ReqRespIdle req resp (S n) c m a -- continuation + -> ReqRespIdle req resp n c m a CollectPipelined - :: Maybe (ReqRespIdle req resp c (S n) m a) - -> (c -> m (ReqRespIdle req resp c n m a)) - -> ReqRespIdle req resp c (S n) m a + :: Maybe (ReqRespIdle req resp (S n) c m a) + -> (c -> m (ReqRespIdle req resp n c m a)) + -> ReqRespIdle req resp (S n) c m a -- | Termination of the req-resp protocol. SendMsgDonePipelined - :: a -> ReqRespIdle req resp c Z m a + :: a -> ReqRespIdle req resp Z c m a -- | Interpret a pipelined client as a 'Peer' on the client side of @@ -117,8 +117,8 @@ data ReqRespIdle req resp c n m a where -- reqRespClientPeerPipelined :: Functor m - => ReqRespClientPipelined req resp c m a - -> Client (ReqResp req resp) (Pipelined c) Z StIdle m a + => ReqRespClientPipelined req resp c m a + -> Client (ReqResp req resp) (Pipelined Z c) StIdle m a reqRespClientPeerPipelined (ReqRespClientPipelined peer) = reqRespClientPeerIdle peer @@ -126,14 +126,14 @@ reqRespClientPeerPipelined (ReqRespClientPipelined peer) = reqRespClientPeerIdle :: forall req resp n c m a. Functor m - => ReqRespIdle req resp c n m a - -> Client (ReqResp req resp) (Pipelined c) n StIdle m a + => ReqRespIdle req resp n c m a + -> Client (ReqResp req resp) (Pipelined n c) StIdle m a reqRespClientPeerIdle = go where go :: forall n'. - ReqRespIdle req resp c n' m a - -> Client (ReqResp req resp) (Pipelined c) n' StIdle m a + ReqRespIdle req resp n' c m a + -> Client (ReqResp req resp) (Pipelined n' c) StIdle m a go (SendMsgReqPipelined req receive next) = -- Pipelined yield: send `MsgReq`, immediately follow with the next step. diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs index fe06c04e..bbf6a24c 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs @@ -72,7 +72,7 @@ reqRespClientMapPipelined :: forall req resp m. reqRespClientMapPipelined reqs0 = ReqRespClientPipelined (go [] Zero reqs0) where - go :: [resp] -> Nat o -> [req] -> ReqRespIdle req resp resp o m [resp] + go :: [resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp] go resps Zero reqs = case reqs of [] -> SendMsgDonePipelined (reverse resps) @@ -86,7 +86,7 @@ reqRespClientMapPipelined reqs0 = (\resp -> return $ go (resp:resps) o reqs) sendReq :: [resp] -> Nat o -> req -> [req] - -> ReqRespIdle req resp resp o m [resp] + -> ReqRespIdle req resp o resp m [resp] sendReq resps o req reqs' = SendMsgReqPipelined req (\resp -> return resp) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs index 9a3e1646..dcb91806 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Server.hs @@ -26,7 +26,7 @@ data ReqRespServer req resp m a = ReqRespServer { reqRespServerPeer :: Monad m => ReqRespServer req resp m a - -> Server (ReqResp req resp) NonPipelined Z StIdle m a + -> Server (ReqResp req resp) NonPipelined StIdle m a reqRespServerPeer ReqRespServer{..} = -- In the 'StIdle' the server is awaiting a request message diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs index 37458220..aa2fd081 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs @@ -18,14 +18,14 @@ import Network.TypedProtocol.Peer.Client reqResp2Client :: forall req resp m. () => [Either req req] - -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) Z StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined Z (Either resp resp)) StIdle m [Either resp resp] reqResp2Client = send Zero where -- pipeline all the requests, either through `MsgReq` or `MsgReq'`. send :: forall (n :: N). Nat n -> [Either req req] -- requests to send - -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) n StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined n (Either resp resp)) StIdle m [Either resp resp] send !n (Left req : reqs) = YieldPipelined (MsgReq req) receiver (send (Succ n) reqs) @@ -47,7 +47,7 @@ reqResp2Client = send Zero -- collect all the responses collect :: Nat n -> [Either resp resp] -- all the responses received so far - -> Client (ReqResp2 req resp) (Pipelined (Either resp resp)) n StIdle m [Either resp resp] + -> Client (ReqResp2 req resp) (Pipelined n (Either resp resp)) StIdle m [Either resp resp] collect Zero !resps = Yield MsgDone (Done (reverse resps)) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs index d01ddd45..05a628ad 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Trans/Wedge.hs @@ -109,7 +109,7 @@ type PingPong2 = Wedge PingPong.PingPong PingPong.StIdle PingPong.PingPong PingPong.StIdle -pingPong2Client :: Client.Client PingPong2 NonPipelined Client.Z StIdle m () +pingPong2Client :: Client.Client PingPong2 NonPipelined StIdle m () pingPong2Client = Client.Yield (MsgStart AtFst) $ Client.Yield (MsgFst PingPong.MsgPing) @@ -122,7 +122,7 @@ pingPong2Client = $ Client.Done () -pingPong2Client' :: forall m. Client.Client PingPong2 (Pipelined ()) Client.Z StIdle m () +pingPong2Client' :: forall m. Client.Client PingPong2 (Pipelined Client.Z ()) StIdle m () pingPong2Client' = -- -- Pipeline first protocol diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 19a04d5a..63c8caa9 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -112,7 +112,7 @@ directPipelined (ReqRespClientPipelined client0) server0 = where go :: forall n. Queue n c - -> ReqRespIdle req resp c n m a + -> ReqRespIdle req resp n c m a -> ReqRespServer req resp m b -> m (a, b) go EmptyQ (SendMsgDonePipelined clientResult) ReqRespServer{recvMsgDone} = diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index a0ac602e..1cf97f24 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -41,6 +41,8 @@ module Network.TypedProtocol.Core , NobodyHasAgencyProof , FlipAgency , IsPipelined (..) + , Outstanding + , N (..) , ActiveAgency , ActiveAgency' (..) , IsActiveState (..) @@ -478,13 +480,27 @@ type family FlipAgency pr where FlipAgency AsServer = AsClient +-- | A type level inductive natural number. +data N = Z | S N + -- | Promoted data type which indicates if 'Peer' is used in -- pipelined mode or not. -- data IsPipelined where -- | Pipelined peer which is using `c :: Type` for collecting responses -- from a pipelined messages. - Pipelined :: Type -> IsPipelined + Pipelined :: N -> Type -> IsPipelined -- | Non-pipelined peer. NonPipelined :: IsPipelined + +-- | Type level count of the number of outstanding pipelined yields for which +-- we have not yet collected a receiver result. Used in 'PeerSender' to ensure +-- 'SenderCollect' is only used when there are outstanding results to collect, +-- and to ensure 'SenderYield', 'SenderAwait' and 'SenderDone' are only used +-- when there are none. +-- +type Outstanding :: IsPipelined -> N +type family Outstanding pl where + Outstanding 'NonPipelined = Z + Outstanding ('Pipelined n _) = n diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index 569d94bd..a9e7d73b 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -110,14 +110,14 @@ runPeerWithDriver :: forall ps (st :: ps) pr dstate m a. Monad m => Driver ps pr dstate m - -> Peer ps pr NonPipelined Z st m a + -> Peer ps pr NonPipelined st m a -> m (a, dstate) runPeerWithDriver Driver{sendMessage, recvMessage, initialDState} = go initialDState where go :: forall st'. dstate - -> Peer ps pr 'NonPipelined Z st' m a + -> Peer ps pr 'NonPipelined st' m a -> m (a, dstate) go dstate (Effect k) = k >>= go dstate go dstate (Done _ x) = return (x, dstate) @@ -159,7 +159,7 @@ runPipelinedPeerWithDriver :: forall ps (st :: ps) pr dstate c m a. MonadAsync m => Driver ps pr dstate m - -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps pr ('Pipelined Z c) st m a -> m (a, dstate) runPipelinedPeerWithDriver driver@Driver{initialDState} peer = do receiveQueue <- atomically newTQueue @@ -238,7 +238,7 @@ runPipelinedPeerSender => TQueue m (ReceiveHandler dstate ps pr m c) -> TQueue m (c, dstate) -> Driver ps pr dstate m - -> Peer ps pr ('Pipelined c) Z st m a + -> Peer ps pr ('Pipelined Z c) st m a -> dstate -> m (a, dstate) runPipelinedPeerSender receiveQueue collectQueue @@ -251,7 +251,7 @@ runPipelinedPeerSender receiveQueue collectQueue go :: forall st' n. Nat n -> MaybeDState dstate n - -> Peer ps pr ('Pipelined c) n st' m a + -> Peer ps pr ('Pipelined n c) st' m a -> m (a, dstate) go n dstate (Effect k) = k >>= go n dstate go Zero (HasDState dstate) (Done _ x) = return (x, dstate) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 010fed04..0a02af49 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -32,7 +32,6 @@ import Unsafe.Coerce (unsafeCoerce) import Network.TypedProtocol.Core as Core - -- | A description of a peer that engages in a protocol. -- -- The protocol describes what messages peers /may/ send or /must/ accept. @@ -95,13 +94,12 @@ import Network.TypedProtocol.Core as Core type Peer :: forall ps -> PeerRole -> IsPipelined - -> Outstanding -> ps -> (Type -> Type) -- ^ monad's kind -> Type -> Type -data Peer ps pr pl n st m a where +data Peer ps pr pl st m a where -- | Perform a local monadic effect and then continue. -- @@ -112,10 +110,10 @@ data Peer ps pr pl n st m a where -- > return $ ... -- another Peer value -- Effect - :: forall ps pr pl n st m a. - m (Peer ps pr pl n st m a) + :: forall ps pr pl st m a. + m (Peer ps pr pl st m a) -- ^ monadic continuation - -> Peer ps pr pl n st m a + -> Peer ps pr pl st m a -- | Send a message to the other peer and then continue. This takes the -- message and the continuation. It also requires evidence that we have @@ -130,14 +128,15 @@ data Peer ps pr pl n st m a where ( StateTokenI st , StateTokenI st' , ActiveState st + , Outstanding pl ~ Z ) => WeHaveAgencyProof pr st -- ^ agency proof -> Message ps st st' -- ^ protocol message - -> Peer ps pr pl Z st' m a + -> Peer ps pr pl st' m a -- ^ continuation - -> Peer ps pr pl Z st m a + -> Peer ps pr pl st m a -- | Waits to receive a message from the other peer and then continues. -- This takes the continuation that is supplied with the received message. It @@ -160,13 +159,14 @@ data Peer ps pr pl n st m a where :: forall ps pr pl (st :: ps) m a. ( StateTokenI st , ActiveState st + , Outstanding pl ~ Z ) => TheyHaveAgencyProof pr st -- ^ agency proof -> (forall (st' :: ps). Message ps st st' - -> Peer ps pr pl Z st' m a) + -> Peer ps pr pl st' m a) -- ^ continuation - -> Peer ps pr pl Z st m a + -> Peer ps pr pl st m a -- | Terminate with a result. A state token must be provided from the -- 'NobodyHasAgency' states, to show that this is a state in which we can @@ -182,12 +182,13 @@ data Peer ps pr pl n st m a where :: forall ps pr pl (st :: ps) m a. ( StateTokenI st , StateAgency st ~ NobodyAgency + , Outstanding pl ~ Z ) => NobodyHasAgencyProof pr st -- ^ (no) agency proof -> a -- ^ returned value - -> Peer ps pr pl Z st m a + -> Peer ps pr pl st m a -- -- Pipelining primitives @@ -208,9 +209,9 @@ data Peer ps pr pl n st m a where -> Message ps st st' -- ^ protocol message -> Receiver ps pr st' st'' m c - -> Peer ps pr (Pipelined c) (S n) st'' m a + -> Peer ps pr (Pipelined (S n) c) st'' m a -- ^ continuation - -> Peer ps pr (Pipelined c) n st m a + -> Peer ps pr (Pipelined n c) st m a -- | Partially collect promised transition. -- @@ -219,13 +220,13 @@ data Peer ps pr pl n st m a where ( StateTokenI st , ActiveState st ) - => Maybe (Peer ps pr (Pipelined c) (S n) st m a) + => Maybe (Peer ps pr (Pipelined (S n) c) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Peer ps pr (Pipelined c) n st m a) + -> (c -> Peer ps pr (Pipelined n c) st m a) -- ^ continuation - -> Peer ps pr (Pipelined c) (S n) st m a + -> Peer ps pr (Pipelined (S n) c) st m a -deriving instance Functor m => Functor (Peer ps pr pl n st m) +deriving instance Functor m => Functor (Peer ps pr pl st m) -- | Receiver @@ -257,17 +258,6 @@ data Receiver ps pr st stdone m c where deriving instance Functor m => Functor (Receiver ps pr st stdone m) --- | Type level count of the number of outstanding pipelined yields for which --- we have not yet collected a receiver result. Used in 'PeerSender' to ensure --- 'SenderCollect' is only used when there are outstanding results to collect, --- and to ensure 'SenderYield', 'SenderAwait' and 'SenderDone' are only used --- when there are none. --- -type Outstanding = N - --- | A type level inductive natural number. -data N = Z | S N - -- | A value level inductive natural number, indexed by the corresponding type -- level natural number 'N'. -- diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index e45c315f..6daf6760 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -33,27 +33,25 @@ module Network.TypedProtocol.Peer.Client import Data.Kind (Type) import Network.TypedProtocol.Core -import Network.TypedProtocol.Peer (Peer, N (..), - Nat (..), Outstanding) +import Network.TypedProtocol.Peer (Peer, Nat (..)) import qualified Network.TypedProtocol.Peer as TP type Client :: forall ps -> IsPipelined - -> Outstanding -> ps -> (Type -> Type) -> Type -> Type -type Client ps pl q st m a = Peer ps AsClient pl q st m a +type Client ps pl st m a = Peer ps AsClient pl st m a -- | Client role pattern for 'TP.Effect'. -- -pattern Effect :: forall ps pl n st m a. - m (Client ps pl n st m a) +pattern Effect :: forall ps pl st m a. + m (Client ps pl st m a) -- ^ monadic continuation - -> Client ps pl n st m a + -> Client ps pl st m a pattern Effect mclient = TP.Effect mclient @@ -65,12 +63,13 @@ pattern Yield :: forall ps pl st m a. ( StateTokenI st , StateTokenI st' , StateAgency st ~ ClientAgency + , Outstanding pl ~ Z ) => Message ps st st' -- ^ protocol message - -> Client ps pl Z st' m a + -> Client ps pl st' m a -- ^ continuation - -> Client ps pl Z st m a + -> Client ps pl st m a pattern Yield msg k = TP.Yield ReflClientAgency msg k @@ -80,11 +79,12 @@ pattern Await :: forall ps pl st m a. () => ( StateTokenI st , StateAgency st ~ ServerAgency + , Outstanding pl ~ Z ) => (forall st'. Message ps st st' - -> Client ps pl Z st' m a) + -> Client ps pl st' m a) -- ^ continuation - -> Client ps pl Z st m a + -> Client ps pl st m a pattern Await k = TP.Await ReflServerAgency k @@ -94,10 +94,11 @@ pattern Done :: forall ps pl st m a. () => ( StateTokenI st , StateAgency st ~ NobodyAgency + , Outstanding pl ~ Z ) => a -- ^ protocol return value - -> Client ps pl Z st m a + -> Client ps pl st m a pattern Done a = TP.Done ReflNobodyAgency a @@ -113,9 +114,9 @@ pattern YieldPipelined :: forall ps st n c m a. => Message ps st st' -- ^ pipelined message -> Receiver ps st' st'' m c - -> Client ps (Pipelined c) (S n) st'' m a + -> Client ps (Pipelined (S n) c) st'' m a -- ^ continuation - -> Client ps (Pipelined c) n st m a + -> Client ps (Pipelined n c) st m a pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg receiver k @@ -126,11 +127,11 @@ pattern Collect :: forall ps st n c m a. => ( StateTokenI st , ActiveState st ) - => Maybe (Client ps (Pipelined c) (S n) st m a) + => Maybe (Client ps (Pipelined (S n) c) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Client ps (Pipelined c) n st m a) + -> (c -> Client ps (Pipelined n c) st m a) -- ^ continuation - -> Client ps (Pipelined c) (S n) st m a + -> Client ps (Pipelined (S n) c) st m a pattern Collect k' k = TP.Collect k' k {-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 5ffbdbc8..47746329 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -33,27 +33,25 @@ module Network.TypedProtocol.Peer.Server import Data.Kind (Type) import Network.TypedProtocol.Core -import Network.TypedProtocol.Peer (Peer, N (..), - Nat (..), Outstanding) +import Network.TypedProtocol.Peer (Peer, Nat (..)) import qualified Network.TypedProtocol.Peer as TP type Server :: forall ps -> IsPipelined - -> Outstanding -> ps -> (Type -> Type) -> Type -> Type -type Server ps pl q st m a = Peer ps AsServer pl q st m a +type Server ps pl st m a = Peer ps AsServer pl st m a -- | Server role pattern for 'TP.Effect'. -- -pattern Effect :: forall ps pl n st m a. - m (Server ps pl n st m a) +pattern Effect :: forall ps pl st m a. + m (Server ps pl st m a) -- ^ monadic continuation - -> Server ps pl n st m a + -> Server ps pl st m a pattern Effect mclient = TP.Effect mclient @@ -65,12 +63,13 @@ pattern Yield :: forall ps pl st m a. ( StateTokenI st , StateTokenI st' , StateAgency st ~ ServerAgency + , Outstanding pl ~ Z ) => Message ps st st' -- ^ protocol message - -> Server ps pl Z st' m a + -> Server ps pl st' m a -- ^ continuation - -> Server ps pl Z st m a + -> Server ps pl st m a pattern Yield msg k = TP.Yield ReflServerAgency msg k @@ -80,11 +79,12 @@ pattern Await :: forall ps pl st m a. () => ( StateTokenI st , StateAgency st ~ ClientAgency + , Outstanding pl ~ Z ) => (forall st'. Message ps st st' - -> Server ps pl Z st' m a) + -> Server ps pl st' m a) -- ^ continuation - -> Server ps pl Z st m a + -> Server ps pl st m a pattern Await k = TP.Await ReflClientAgency k @@ -94,10 +94,11 @@ pattern Done :: forall ps pl st m a. () => ( StateTokenI st , StateAgency st ~ NobodyAgency + , Outstanding pl ~ Z ) => a -- ^ protocol return value - -> Server ps pl Z st m a + -> Server ps pl st m a pattern Done a = TP.Done ReflNobodyAgency a @@ -113,9 +114,9 @@ pattern YieldPipelined :: forall ps st n c m a. => Message ps st st' -- ^ pipelined message -> Receiver ps st' st'' m c - -> Server ps (Pipelined c) (S n) st'' m a + -> Server ps (Pipelined (S n) c) st'' m a -- ^ continuation - -> Server ps (Pipelined c) n st m a + -> Server ps (Pipelined n c) st m a pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg receiver k @@ -126,11 +127,11 @@ pattern Collect :: forall ps st n c m a. => ( StateTokenI st , ActiveState st ) - => Maybe (Server ps (Pipelined c) (S n) st m a) + => Maybe (Server ps (Pipelined (S n) c) st m a) -- ^ continuation, executed if no message has arrived so far - -> (c -> Server ps (Pipelined c) n st m a) + -> (c -> Server ps (Pipelined n c) st m a) -- ^ continuation - -> Server ps (Pipelined c) (S n) st m a + -> Server ps (Pipelined (S n) c) st m a pattern Collect k' k = TP.Collect k' k diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index 400b1425..d531ece5 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -81,8 +81,8 @@ import Network.TypedProtocol.Peer connect :: forall ps (pr :: PeerRole) (initSt :: ps) m a b. (Monad m, SingI pr) - => Peer ps pr NonPipelined Z initSt m a - -> Peer ps (FlipAgency pr) NonPipelined Z initSt m b + => Peer ps pr NonPipelined initSt m a + -> Peer ps (FlipAgency pr) NonPipelined initSt m b -> m (a, b, TerminalStates ps) connect = go where @@ -90,8 +90,8 @@ connect = go singPeerRole = sing go :: forall (st :: ps). - Peer ps pr NonPipelined Z st m a - -> Peer ps (FlipAgency pr) NonPipelined Z st m b + Peer ps pr NonPipelined st m a + -> Peer ps (FlipAgency pr) NonPipelined st m b -> m (a, b, TerminalStates ps) go (Done ReflNobodyAgency a) (Done ReflNobodyAgency b) = return (a, b, terminals) @@ -177,15 +177,15 @@ forgetPipelined -- pipelining. For the 'CollectSTM' primitive, the stm action must not -- block otherwise even if the choice is to pipeline more (a 'True' value), -- we'll actually collect a result. - -> Peer ps pr (Pipelined c) Z st m a - -> Peer ps pr NonPipelined Z st m a + -> Peer ps pr (Pipelined Z c) st m a + -> Peer ps pr NonPipelined st m a forgetPipelined = goSender EmptyQ where goSender :: forall st' n. Queue n c -> [Bool] - -> Peer ps pr ('Pipelined c) n st' m a - -> Peer ps pr 'NonPipelined Z st' m a + -> Peer ps pr ('Pipelined n c) st' m a + -> Peer ps pr 'NonPipelined st' m a goSender EmptyQ _cs (Done refl k) = Done refl k goSender q cs (Effect k) = Effect (goSender q cs <$> k) @@ -199,9 +199,9 @@ forgetPipelined = goSender EmptyQ goReceiver :: forall stCurrent stNext n. Queue n c -> [Bool] - -> Peer ps pr ('Pipelined c) (S n) stNext m a + -> Peer ps pr ('Pipelined (S n) c) stNext m a -> Receiver ps pr stCurrent stNext m c - -> Peer ps pr 'NonPipelined Z stCurrent m a + -> Peer ps pr 'NonPipelined stCurrent m a goReceiver q cs s (ReceiverDone x) = goSender (enqueue x q) cs s goReceiver q cs s (ReceiverEffect k) = Effect (goReceiver q cs s <$> k) @@ -220,8 +220,8 @@ forgetPipelined = goSender EmptyQ promoteToPipelined :: forall ps (pr :: PeerRole) st c m a. Functor m - => Peer ps pr 'NonPipelined Z st m a - -> Peer ps pr ('Pipelined c) Z st m a + => Peer ps pr 'NonPipelined st m a + -> Peer ps pr ('Pipelined Z c) st m a promoteToPipelined (Effect k) = Effect $ promoteToPipelined <$> k promoteToPipelined (Yield refl msg k) = Yield refl msg @@ -247,8 +247,8 @@ connectPipelined (Monad m, SingI pr) => [Bool] -> [Bool] - -> Peer ps pr ('Pipelined c) Z st m a - -> Peer ps (FlipAgency pr) ('Pipelined c') Z st m b + -> Peer ps pr ('Pipelined Z c) st m a + -> Peer ps (FlipAgency pr) ('Pipelined Z c') st m b -> m (a, b, TerminalStates ps) connectPipelined csA csB a b = connect (forgetPipelined csA a) From d2f1e747e1fba60e98d94fcbb0065940ad63bfdc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 24 Jul 2024 09:08:37 +0200 Subject: [PATCH 26/39] typed-protocols-stateful: non-pipelined stateful Peer We don't provide pipelined stateful peer, as safe API requires tracking of pipelined transitions rather than just the depth of pipelining at the type level of a `Peer`. See the `coot/typed-protocols-rewrite` branch how this can be done. --- cabal.project | 2 + .../src/Network/TypedProtocol/Codec/CBOR.hs | 2 + .../TypedProtocol/Stateful/PingPong/Client.hs | 51 ++++ .../TypedProtocol/Stateful/ReqResp/Client.hs | 52 ++++ .../Stateful/ReqResp/Examples.hs | 50 ++++ .../typed-protocols-examples.cabal | 7 +- typed-protocols-stateful-cborg/ChangeLog.md | 6 + typed-protocols-stateful-cborg/LICENSE | 177 +++++++++++ typed-protocols-stateful-cborg/NOTICE | 14 + typed-protocols-stateful-cborg/README.md | 6 + .../TypedProtocol/Stateful/Codec/CBOR.hs | 129 ++++++++ .../typed-protocols-stateful-cborg.cabal | 43 +++ typed-protocols-stateful/LICENSE | 177 +++++++++++ typed-protocols-stateful/NOTICE | 14 + typed-protocols-stateful/README.md | 6 + .../src/Network/TypedProtocol.hs | 134 +++++++++ .../Network/TypedProtocol/Stateful/Codec.hs | 281 ++++++++++++++++++ .../Network/TypedProtocol/Stateful/Driver.hs | 107 +++++++ .../Network/TypedProtocol/Stateful/Peer.hs | 178 +++++++++++ .../TypedProtocol/Stateful/Peer/Client.hs | 97 ++++++ .../TypedProtocol/Stateful/Peer/Server.hs | 96 ++++++ .../Network/TypedProtocol/Stateful/Proofs.hs | 82 +++++ .../typed-protocols-stateful.cabal | 52 ++++ .../src/Network/TypedProtocol/Codec.hs | 3 + 24 files changed, 1765 insertions(+), 1 deletion(-) create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs create mode 100644 typed-protocols-stateful-cborg/ChangeLog.md create mode 100644 typed-protocols-stateful-cborg/LICENSE create mode 100644 typed-protocols-stateful-cborg/NOTICE create mode 100644 typed-protocols-stateful-cborg/README.md create mode 100644 typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs create mode 100644 typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal create mode 100644 typed-protocols-stateful/LICENSE create mode 100644 typed-protocols-stateful/NOTICE create mode 100644 typed-protocols-stateful/README.md create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs create mode 100644 typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Proofs.hs create mode 100644 typed-protocols-stateful/typed-protocols-stateful.cabal diff --git a/cabal.project b/cabal.project index 5c9b7552..5c05c7e9 100644 --- a/cabal.project +++ b/cabal.project @@ -16,6 +16,8 @@ index-state: packages: ./typed-protocols ./typed-protocols-cborg + ./typed-protocols-stateful + ./typed-protocols-stateful-cborg ./typed-protocols-examples ./typed-protocols-doc diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index ee301ca9..814d30b3 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -10,6 +10,8 @@ module Network.TypedProtocol.Codec.CBOR , DeserialiseFailure , mkCodecCborLazyBS , mkCodecCborStrictBS + , convertCborDecoderBS + , convertCborDecoderLBS ) where import Control.Monad.Class.MonadST (MonadST (..)) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs new file mode 100644 index 00000000..c56e364c --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Network.TypedProtocol.Stateful.PingPong.Client + ( -- * Non-pipelined peer + PingPongClient (..) + , pingPongClientPeer + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.PingPong.Type +import Network.TypedProtocol.Stateful.Peer.Client + + +data PingPongClient (f :: PingPong -> Type) m a where + -- | Choose to go for sending a ping message. The ping has no body so + -- all we have to provide here is a continuation for the single legal + -- reply message. + -- + SendMsgPing :: f StBusy + -> m (PingPongClient f m a) -- continuation for Pong response + -> PingPongClient f m a + + -- | Choose to terminate the protocol. This is an actual but nullary message, + -- we terminate with the local result value. So this ends up being much like + -- 'return' in this case, but in general the termination is a message that + -- can communicate final information. + -- + SendMsgDone :: f StDone -> a -> PingPongClient f m a + + +pingPongClientPeer + :: Functor m + => (f StBusy -> f StIdle) + -> PingPongClient f m a + -> Client PingPong StIdle f m (a, f StDone) + +pingPongClientPeer _busytoIdle (SendMsgDone f result) = + Yield f MsgDone (Done (result, f)) + +pingPongClientPeer busyToIdle (SendMsgPing f next) = + Yield f MsgPing $ + Await $ \f' MsgPong -> + ( Effect $ pingPongClientPeer busyToIdle <$> next + , busyToIdle f' + ) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs new file mode 100644 index 00000000..505daaed --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Network.TypedProtocol.Stateful.ReqResp.Client + ( -- * Non-Pipelined Client + ReqRespClient (..) + , reqRespClientPeer + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.ReqResp.Type +import Network.TypedProtocol.Stateful.Peer.Client + + +data ReqRespClient req resp (f :: ReqResp req resp -> Type) m a where + SendMsgReq :: f StBusy + -> req + -> (f StBusy -> resp -> ( m (ReqRespClient req resp f m a) + , f StIdle + )) + -> ReqRespClient req resp f m a + + SendMsgDone :: f StDone + -> m a + -> ReqRespClient req resp f m a + + +reqRespClientPeer + :: Monad m + => ReqRespClient req resp f m a + -> Client (ReqResp req resp) StIdle f m a + +reqRespClientPeer (SendMsgDone f result) = + Effect $ do + r <- result + return $ Yield f MsgDone (Done r) + +reqRespClientPeer (SendMsgReq f req next) = + Yield f (MsgReq req) $ + Await $ \f' (MsgResp resp) -> + case next f' resp of + (client, f'') -> + ( Effect $ reqRespClientPeer <$> client + , f'' + ) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs new file mode 100644 index 00000000..72556c02 --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.TypedProtocol.Stateful.ReqResp.Examples + ( ReqRespStateCallbacks (..) + , reqRespClientMap + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.ReqResp.Type +import Network.TypedProtocol.Stateful.ReqResp.Client + + +data ReqRespStateCallbacks (f :: ReqResp req resp -> Type) = + ReqRespStateCallbacks { + rrBusyToIdle :: f StBusy -> f StIdle + , rrBusyToBusy :: f StBusy -> f StBusy + , rrBusyToDone :: f StBusy -> f StDone + } + +reqRespClientMap + :: forall req resp f m. + Monad m + => ReqRespStateCallbacks f + -> f StBusy + -> [req] + -> ReqRespClient req resp f m ([resp], f StDone) +reqRespClientMap ReqRespStateCallbacks + { rrBusyToIdle + , rrBusyToBusy + , rrBusyToDone + } = go [] + where + go :: [resp] + -> f StBusy + -> [req] + -> ReqRespClient req resp f m ([resp], f StDone) + go resps f [] = SendMsgDone f' (pure (reverse resps, f')) + where + f' = rrBusyToDone f + go resps f (req:reqs) = + SendMsgReq f req $ \f' resp -> + ( return (go (resp:resps) (rrBusyToBusy f') reqs) + , rrBusyToIdle f' + ) + diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 8f2beaa2..3bed5292 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -38,6 +38,10 @@ library , Network.TypedProtocol.ReqResp2.Type , Network.TypedProtocol.ReqResp2.Client + , Network.TypedProtocol.Stateful.PingPong.Client + , Network.TypedProtocol.Stateful.ReqResp.Client + , Network.TypedProtocol.Stateful.ReqResp.Examples + , Network.TypedProtocol.Trans.Wedge other-extensions: GADTs , RankNTypes @@ -58,7 +62,8 @@ library network, time, typed-protocols ^>= 0.2, - typed-protocols-cborg + typed-protocols-cborg, + typed-protocols-stateful hs-source-dirs: src default-language: Haskell2010 diff --git a/typed-protocols-stateful-cborg/ChangeLog.md b/typed-protocols-stateful-cborg/ChangeLog.md new file mode 100644 index 00000000..adaf4516 --- /dev/null +++ b/typed-protocols-stateful-cborg/ChangeLog.md @@ -0,0 +1,6 @@ +# Revision history for typed-protocols-cborg + +## 0.1.0.0 -- 2021-07-28 + +* Initial experiments and prototyping + diff --git a/typed-protocols-stateful-cborg/LICENSE b/typed-protocols-stateful-cborg/LICENSE new file mode 100644 index 00000000..f433b1a5 --- /dev/null +++ b/typed-protocols-stateful-cborg/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/typed-protocols-stateful-cborg/NOTICE b/typed-protocols-stateful-cborg/NOTICE new file mode 100644 index 00000000..d027fe3c --- /dev/null +++ b/typed-protocols-stateful-cborg/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022-2024 Input Output Global Inc (IOG) + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/typed-protocols-stateful-cborg/README.md b/typed-protocols-stateful-cborg/README.md new file mode 100644 index 00000000..16b89de2 --- /dev/null +++ b/typed-protocols-stateful-cborg/README.md @@ -0,0 +1,6 @@ +typed-protocols-stateful-cborg +============================== + +[CBOR](https://hackage.haskell.org/package/cborg) codecs for +[typed-protocols-stateful](https://input-output-hk.github.io/ouroboros-network/typed-protocols/Network-TypedProtocol-Stateful-Peer.html) +package. diff --git a/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs new file mode 100644 index 00000000..254a8a72 --- /dev/null +++ b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.TypedProtocol.Stateful.Codec.CBOR + ( module Network.TypedProtocol.Stateful.Codec + , DeserialiseFailure + , mkCodecCborLazyBS + , mkCodecCborStrictBS + ) where + +import Control.Monad.Class.MonadST (MonadST (..)) + +import Codec.CBOR.Decoding qualified as CBOR (Decoder) +import Codec.CBOR.Encoding qualified as CBOR (Encoding) +import Codec.CBOR.Read qualified as CBOR +import Codec.CBOR.Write qualified as CBOR +import Data.ByteString qualified as BS +import Data.ByteString.Builder qualified as BS +import Data.ByteString.Builder.Extra qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Internal qualified as LBS (smallChunkSize) + +import Network.TypedProtocol.Stateful.Codec +import Network.TypedProtocol.Codec.CBOR (DeserialiseFailure, + convertCborDecoderBS, convertCborDecoderLBS) +import Network.TypedProtocol.Core + + +-- | Construct a 'Codec' for a CBOR based serialisation format, using strict +-- 'BS.ByteString's. +-- +-- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. +-- +-- It takes encode and decode functions for the protocol messages that use the +-- CBOR library encoder and decoder. +-- +-- Note that this is /less/ efficient than the 'mkCodecCborLazyBS' variant +-- because it has to copy and concatenate the result of the encoder (which +-- natively produces chunks). +-- +mkCodecCborStrictBS + :: forall ps f m. MonadST m + + => (forall (st :: ps) (st' :: ps). + StateTokenI st + =>ActiveState st + => f st' -> Message ps st st' -> CBOR.Encoding) + + -> (forall (st :: ps) s. + ActiveState st + => StateToken st + -> f st + -> CBOR.Decoder s (SomeMessage st)) + + -> Codec ps DeserialiseFailure f m BS.ByteString +mkCodecCborStrictBS cborMsgEncode cborMsgDecode = + Codec { + encode = \f msg -> convertCborEncoder (cborMsgEncode f) msg, + decode = \stok f -> convertCborDecoder (cborMsgDecode stok f) + } + where + convertCborEncoder :: (a -> CBOR.Encoding) -> a -> BS.ByteString + convertCborEncoder cborEncode = + CBOR.toStrictByteString + . cborEncode + + convertCborDecoder + :: (forall s. CBOR.Decoder s a) + -> m (DecodeStep BS.ByteString DeserialiseFailure m a) + convertCborDecoder cborDecode = + withLiftST (convertCborDecoderBS cborDecode) + +-- | Construct a 'Codec' for a CBOR based serialisation format, using lazy +-- 'BS.ByteString's. +-- +-- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. +-- +-- It takes encode and decode functions for the protocol messages that use the +-- CBOR library encoder and decoder. +-- +mkCodecCborLazyBS + :: forall ps f m. MonadST m + + => (forall (st :: ps) (st' :: ps). + StateTokenI st + => ActiveState st + => f st' + -> Message ps st st' -> CBOR.Encoding) + + -> (forall (st :: ps) s. + ActiveState st + => StateToken st + -> f st + -> CBOR.Decoder s (SomeMessage st)) + + -> Codec ps CBOR.DeserialiseFailure f m LBS.ByteString +mkCodecCborLazyBS cborMsgEncode cborMsgDecode = + Codec { + encode = \f msg -> convertCborEncoder (cborMsgEncode f) msg, + decode = \stok f -> convertCborDecoder (cborMsgDecode stok f) + } + where + convertCborEncoder :: (a -> CBOR.Encoding) -> a -> LBS.ByteString + convertCborEncoder cborEncode = + toLazyByteString + . CBOR.toBuilder + . cborEncode + + convertCborDecoder + :: (forall s. CBOR.Decoder s a) + -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) + convertCborDecoder cborDecode = + withLiftST (convertCborDecoderLBS cborDecode) + +{-# NOINLINE toLazyByteString #-} +toLazyByteString :: BS.Builder -> LBS.ByteString +toLazyByteString = BS.toLazyByteStringWith strategy LBS.empty + where + -- Buffer strategy and sizes better tuned to our network protocol situation. + -- + -- The LBS.smallChunkSize is 4k - heap object overheads, so that + -- it does fit in a 4k overall. + -- + strategy = BS.untrimmedStrategy 800 LBS.smallChunkSize + diff --git a/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal b/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal new file mode 100644 index 00000000..5d41dfc9 --- /dev/null +++ b/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal @@ -0,0 +1,43 @@ +name: typed-protocols-stateful-cborg +version: 0.2.0.0 +synopsis: CBOR codecs for typed-protocols +-- description: +license: Apache-2.0 +license-files: + LICENSE + NOTICE +copyright: 2022-2024 Input Output Global Inc (IOG) +author: Marcin Szamotulski +maintainer: marcin.szamotulski@iohk.io +category: Control +build-type: Simple + +-- These should probably be added at some point. +extra-source-files: ChangeLog.md, README.md + +cabal-version: >=1.10 + +library + exposed-modules: Network.TypedProtocol.Stateful.Codec.CBOR + + build-depends: base >=4.12 && <4.21, + bytestring >=0.10 && <0.13, + cborg >=0.2.1 && <0.3, + singletons, + + io-classes, + typed-protocols, + typed-protocols-cborg, + typed-protocols-stateful + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints diff --git a/typed-protocols-stateful/LICENSE b/typed-protocols-stateful/LICENSE new file mode 100644 index 00000000..f433b1a5 --- /dev/null +++ b/typed-protocols-stateful/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/typed-protocols-stateful/NOTICE b/typed-protocols-stateful/NOTICE new file mode 100644 index 00000000..d027fe3c --- /dev/null +++ b/typed-protocols-stateful/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022-2024 Input Output Global Inc (IOG) + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/typed-protocols-stateful/README.md b/typed-protocols-stateful/README.md new file mode 100644 index 00000000..4a9b66e8 --- /dev/null +++ b/typed-protocols-stateful/README.md @@ -0,0 +1,6 @@ +typed-protocols-stateful +======================== + +A stateful `typed-protocols` version which allows to track state changes along +side protocol transtions. It allows to build codes depends on the current +state. diff --git a/typed-protocols-stateful/src/Network/TypedProtocol.hs b/typed-protocols-stateful/src/Network/TypedProtocol.hs new file mode 100644 index 00000000..b79a0aec --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol.hs @@ -0,0 +1,134 @@ + +-- | This package defines the typed protocol framework. This module re-exports +-- the public API. +-- +module Network.TypedProtocol + ( -- * Introduction + -- $intro + -- * Defining and implementing protocols + -- $defining + module Network.TypedProtocol.Core + -- ** Protocol proofs and tests + -- $tests + , module Network.TypedProtocol.Proofs + -- * Running protocols + -- $running + , module Network.TypedProtocol.Driver + ) where + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Driver +import Network.TypedProtocol.Proofs + + +-- $intro +-- +-- The typed protocol framework is used to define, test and execute protocols. +-- +-- It guarantees: +-- +-- * agreement on which messages can be sent and received; +-- * the absence of race conditions; and +-- * the absence of deadlock. +-- +-- The trade-off to achieve these guarantees is that it places constraints on +-- the kinds of protocol that can be expressed. In particular it requires that +-- protocols be defined as a state transition system. It requires for each +-- protocol state that exactly one of the two peers be able to send and the +-- other must be ready to receive. +-- +-- This means it is not possible to express protocols such as TCP where there +-- are protocol states where a single peer can both send and receive, however +-- it is suitable for most application-level protocols. In particular many +-- application-level protocols are completely in-order and synchronous. That +-- said, in many (but not all) cases it is possible to pipeline these protocols +-- so that network latency can be hidden and full use made of the available +-- bandwidth. Special support is provided to run protocols in a pipelined way, +-- without having to change the protocol definition. +-- +-- The protocols in this framework assume an underlying \"reliable ordered\" +-- connection. A \"reliable ordered\" connection is a term of art meaning one +-- where the receiving end receives any prefix of the messages sent by the +-- sending end. It is not reliable in the colloquial sense as it does not +-- ensure that anything actually arrives, only that /if/ any message arrives, +-- all the previous messages did too, and that they arrive in the order in +-- which they were sent. +-- +-- The framework also provides: +-- +-- * an abstraction for untyped channels; +-- * a codec abstraction for encoding and decoding protocol messages; and +-- * drivers for running protocol peers with a channel and a codec. + + +-- $defining +-- +-- The "Network.TypedProtocol.Core" module defines the core of the system. +-- +-- Start reading here to understand: +-- +-- * how to define new protocols; or +-- * to write peers that engage in a protocol. +-- +-- Typed protocol messages need to be converted to and from untyped +-- serialised forms to send over a transport channel. So part of defining a new +-- protocol is to define the message encoding and the codec for doing the +-- encoding and decoding. This is somewhat (but not significantly) more complex +-- than defining normal data type serialisation because of the need to decode +-- typed protocol messages. The "Network.TypedProtocol.Codec" module provides +-- the codec abstraction to capture this. + + +-- $tests +-- +-- There are a few proofs about the framework that we can state and implement +-- as Haskell functions (using GADTs and evaluation). A couple of these proofs +-- rely on a few lemmas that should be proved for each protocol. The +-- "Network.TypedProtocol.Proofs" module describes these proof and provides +-- the infrastructure for the simple lemmas that need to be implemented for +-- each protocol. +-- +-- This module also provides utilities helpful for testing protocols. + + +-- $running +-- +-- Typed protocols need to be able to send messages over untyped transport +-- channels. The "Network.TypedProtocol.Channel" module provides such an +-- abstraction. You can use existing example implementations of this interface +-- or define your own to run over other transports. +-- +-- Given a protocol peer, and a channel and a codec we can run the protocol +-- peer so that it engages in the protocol sending and receiving messages +-- over the channel. The "Network.TypedProtocol.Driver" module provides drivers +-- for normal and pipelined peers. + + +-- $pipelining +-- Protocol pipelining is a technique to make effective use of network +-- resources. +-- +-- <> +-- +-- As in the above diagram, instead of sending a request and waiting for the +-- response before sending the next request, pipelining involves sending all +-- three requests back-to-back and waiting for the three replies. The server +-- still simply processes the requests in order and the replies come back in +-- the same order as the requests were made. +-- +-- Not only does this save network latency, one round trip versus three in +-- the diagram above, but it also makes effective use of the bandwidth by +-- sending requests and replies back-to-back. +-- +-- In the example in the diagram it stops after three requests, but such a +-- pattern can go on indefinately with messages going in both directions, +-- which can saturate the available bandwidth. +-- +-- For many (but not all) protocols that can be defined in the @typed-protocol@ +-- framework it is possible to take the protocol, without changing the +-- protocol's state machine, and to engage in the protocol in a pipelined way. +-- Only the pipelined client has to be written specially. The server side can +-- be used unaltered and can be used with either pipelined or non-pipelined +-- clients. + + diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs new file mode 100644 index 00000000..7b5478a7 --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- @UndecidableInstances@ extension is required for defining @Show@ instance of +-- @'AnyMessage'@ and @'AnyMessage'@. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + +-- | Stateful codec. This module is intended to be imported qualified. +-- +module Network.TypedProtocol.Stateful.Codec + ( -- * Defining and using Codecs + Codec (..) + , hoistCodec + , isoCodec + , mapFailureCodec + , liftCodec + -- ** Related types + , ActiveState + , PeerRole (..) + , SomeMessage (..) + , CodecFailure (..) + -- ** Incremental decoding + , DecodeStep (..) + , runDecoder + , runDecoderPure + -- ** Codec properties + , AnyMessage (..) + , pattern AnyMessageAndAgency + , prop_codecM + , prop_codec + , prop_codec_splitsM + , prop_codec_splits + , prop_codecs_compatM + , prop_codecs_compat + -- ** StateToken + , StateToken + , StateTokenI (..) + ) where + +import Data.Kind (Type) +import Data.Monoid (All (..)) + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (CodecFailure (..), + DecodeStep (..), SomeMessage (..), hoistDecodeStep, + isoDecodeStep, mapFailureDecodeStep, runDecoder, + runDecoderPure) +import qualified Network.TypedProtocol.Codec as TP + + +-- | A stateful codec. +-- +data Codec ps failure (f :: ps -> Type) m bytes = Codec { + encode :: forall (st :: ps) (st' :: ps). + StateTokenI st + => ActiveState st + => f st' + -> Message ps st st' + -> bytes, + + decode :: forall (st :: ps). + ActiveState st + => StateToken st + -> f st + -> m (DecodeStep bytes failure m (SomeMessage st)) + } + +liftCodec :: TP.Codec ps failure m bytes -> Codec ps failure f m bytes +liftCodec codec = Codec { encode = \_ msg -> TP.encode codec msg + , decode = \stok _ -> TP.decode codec stok + } + +hoistCodec + :: ( Functor n ) + => (forall x . m x -> n x) + -> Codec ps failure f m bytes + -> Codec ps failure f n bytes +hoistCodec nat codec = codec + { decode = \stok f -> fmap (hoistDecodeStep nat) . nat $ decode codec stok f + } + +isoCodec :: Functor m + => (bytes -> bytes') + -> (bytes' -> bytes) + -> Codec ps failure f m bytes + -> Codec ps failure f m bytes' +isoCodec g finv Codec {encode, decode} = Codec { + encode = \f msg -> g $ encode f msg, + decode = \stok f -> isoDecodeStep g finv <$> decode stok f + } + +mapFailureCodec + :: Functor m + => (failure -> failure') + -> Codec ps failure f m bytes + -> Codec ps failure' f m bytes +mapFailureCodec g Codec {encode, decode} = Codec { + encode = encode, + decode = \stok f -> mapFailureDecodeStep g <$> decode stok f + } + + +-- +-- Codec properties +-- + +-- | Any message for a protocol, with a 'StateTokenI' constraint which gives access +-- to protocol state. +-- +-- Used where we don't know statically what the state type is, but need the +-- agency and message to match each other. +-- +data AnyMessage ps (f :: ps -> Type) where + AnyMessage :: forall ps f (st :: ps) (st' :: ps). + ( StateTokenI st + , ActiveState st + ) + => f st + -> f st' + -> Message ps (st :: ps) (st' :: ps) + -> AnyMessage ps f + +instance ( forall (st :: ps) (st' :: ps). Show (Message ps st st') + , forall (st :: ps). Show (f st) + ) + => Show (AnyMessage ps f) where + show (AnyMessage st st' msg) = concat [ "AnyMessage " + , show st + , " " + , show st' + , " " + , show msg + ] + + + +-- | A convenient pattern synonym which unwrap 'AnyMessage' giving both the +-- singleton for the state and the message. +-- +pattern AnyMessageAndAgency :: forall ps f. () + => forall (st :: ps) (st' :: ps). + (StateTokenI st, ActiveState st) + => StateToken st + -> f st + -> f st' + -> Message ps st st' + -> AnyMessage ps f +pattern AnyMessageAndAgency stateToken f f' msg <- AnyMessage f f' (getAgency -> (msg, stateToken)) + where + AnyMessageAndAgency _ msg = AnyMessage msg +{-# COMPLETE AnyMessageAndAgency #-} + +-- | Internal view pattern for 'AnyMessageAndAgency' +-- +getAgency :: StateTokenI st => Message ps st st' -> (Message ps st st', StateToken st) +getAgency msg = (msg, stateToken) + +-- | The 'Codec' round-trip property: decode after encode gives the same +-- message. Every codec must satisfy this property. +-- +prop_codecM + :: forall ps failure f m bytes. + ( Monad m + , Eq (TP.AnyMessage ps) + ) + => Codec ps failure f m bytes + -> AnyMessage ps f + -> m Bool +prop_codecM Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do + r <- decode (stateToken :: StateToken st) f >>= runDecoder [encode f' msg] + case r :: Either failure (SomeMessage st) of + Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg + Left _ -> return False + +-- | The 'Codec' round-trip property in a pure monad. +-- +prop_codec + :: forall ps failure f m bytes. + (Monad m, Eq (TP.AnyMessage ps)) + => (forall a. m a -> a) + -> Codec ps failure f m bytes + -> AnyMessage ps f + -> Bool +prop_codec runM codec msg = + runM (prop_codecM codec msg) + + +-- | A variant on the codec round-trip property: given the encoding of a +-- message, check that decode always gives the same result irrespective +-- of how the chunks of input are fed to the incremental decoder. +-- +-- This property guards against boundary errors in incremental decoders. +-- It is not necessary to check this for every message type, just for each +-- generic codec construction. For example given some binary serialisation +-- library one would write a generic adaptor to the codec interface. This +-- adaptor has to deal with the incremental decoding and this is what needs +-- to be checked. +-- +prop_codec_splitsM + :: forall ps failure f m bytes. + (Monad m, Eq (TP.AnyMessage ps)) + => (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form + -> Codec ps failure f m bytes + -> AnyMessage ps f + -> m Bool +prop_codec_splitsM splits + Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do + and <$> sequence + [ do r <- decode (stateToken :: StateToken st) f >>= runDecoder bytes' + case r :: Either failure (SomeMessage st) of + Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg + Left _ -> return False + + | let bytes = encode f' msg + , bytes' <- splits bytes ] + + +-- | Like @'prop_codec_splitsM'@ but run in a pure monad @m@, e.g. @Identity@. +-- +prop_codec_splits + :: forall ps failure f m bytes. + (Monad m, Eq (TP.AnyMessage ps)) + => (bytes -> [[bytes]]) + -> (forall a. m a -> a) + -> Codec ps failure f m bytes + -> AnyMessage ps f + -> Bool +prop_codec_splits splits runM codec msg = + runM $ prop_codec_splitsM splits codec msg + + +-- | Compatibility between two codecs of the same protocol. Encode a message +-- with one codec and decode it with the other one, then compare if the result +-- is the same as initial message. +-- +prop_codecs_compatM + :: forall ps failure f m bytes. + ( Monad m + , Eq (TP.AnyMessage ps) + , forall a. Monoid a => Monoid (m a) + ) + => Codec ps failure f m bytes + -> Codec ps failure f m bytes + -> AnyMessage ps f + -> m Bool +prop_codecs_compatM codecA codecB + (AnyMessage f f' (msg :: Message ps st st')) = + getAll <$> do r <- decode codecB (stateToken :: StateToken st) f >>= runDecoder [encode codecA f' msg] + case r :: Either failure (SomeMessage st) of + Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg + Left _ -> return $ All False + <> do r <- decode codecA (stateToken :: StateToken st) f >>= runDecoder [encode codecB f' msg] + case r :: Either failure (SomeMessage st) of + Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg + Left _ -> return $ All False + +-- | Like @'prop_codecs_compatM'@ but run in a pure monad @m@, e.g. @Identity@. +-- +prop_codecs_compat + :: forall ps failure f m bytes. + ( Monad m + , Eq (TP.AnyMessage ps) + , forall a. Monoid a => Monoid (m a) + ) + => (forall a. m a -> a) + -> Codec ps failure f m bytes + -> Codec ps failure f m bytes + -> AnyMessage ps f + -> Bool +prop_codecs_compat run codecA codecB msg = + run $ prop_codecs_compatM codecA codecB msg diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs new file mode 100644 index 00000000..e51994aa --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | Actions for running 'Peer's with a 'Driver'. This module should be +-- imported qualified. +-- +module Network.TypedProtocol.Stateful.Driver + ( -- * Running a peer + runPeerWithDriver + -- * Re-exports + , DecodeStep (..) + , Driver (..) + , SomeMessage (..) + ) where + +import Control.Monad.Class.MonadSTM + +import Data.Kind (Type) + +import Network.TypedProtocol.Codec (DecodeStep (..), SomeMessage (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Stateful.Peer + +data Driver ps (pr :: PeerRole) bytes failure dstate f m = + Driver { + -- | Send a message. + -- + sendMessage :: forall (st :: ps) (st' :: ps). + StateTokenI st + => StateTokenI st' + => ActiveState st + => ReflRelativeAgency (StateAgency st) + WeHaveAgency + (Relative pr (StateAgency st)) + -> f st' + -> Message ps st st' + -> m () + + , -- | Receive a message, a blocking action which reads from the network + -- and runs the incremental decoder until a full message is decoded. + -- As an input it might receive a 'DecodeStep' previously started with + -- 'tryRecvMessage'. + -- + -- It could be implemented in terms of 'recvMessageSTM', but in some + -- cases it can be easier (or more performant) to have a different + -- implementation. + -- + recvMessage :: forall (st :: ps). + StateTokenI st + => ActiveState st + => ReflRelativeAgency (StateAgency st) + TheyHaveAgency + (Relative pr (StateAgency st)) + -> f st + -> dstate + -> m (SomeMessage st, dstate) + + , initialDState :: dstate + } + + +-- +-- Running peers +-- + +-- | Run a peer with the given driver. +-- +-- This runs the peer to completion (if the protocol allows for termination). +-- +runPeerWithDriver + :: forall ps (st :: ps) pr bytes failure dstate (f :: ps -> Type) m a. + MonadSTM m + => Driver ps pr bytes failure dstate f m + -> f st + -> Peer ps pr st f m a + -> m (a, dstate) +runPeerWithDriver Driver{ sendMessage + , recvMessage + , initialDState + } = + go initialDState + where + go :: forall st'. + dstate + -> f st' + -> Peer ps pr st' f m a + -> m (a, dstate) + go !dstate !f (Effect k) = k >>= go dstate f + + go !dstate _ (Done _ x) = return (x, dstate) + + go !dstate _ (Yield refl !f msg k) = do + sendMessage refl f msg + go dstate f k + + go !dstate !f (Await refl k) = do + (SomeMessage msg, dstate') <- recvMessage refl f dstate + case k f msg of + (k', f') -> go dstate' f' k' diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs new file mode 100644 index 00000000..30f92e53 --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +-- TODO: the 'Functor' instance of 'Peer' is undecidable +{-# LANGUAGE UndecidableInstances #-} + +-- | Protocol stateful EDSL. +-- +-- __Note__: 'Network.TypedProtocol.Peer.Client.Client' and +-- 'Network.TypedProtocol.Peer.Server.Server' patterns are easier to use. +-- +module Network.TypedProtocol.Stateful.Peer + ( Peer (..) + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.Core as Core + + +-- | A description of a peer that engages in a protocol. +-- +-- The protocol describes what messages peers /may/ send or /must/ accept. +-- A particular peer implementation decides what to actually do within the +-- constraints of the protocol. +-- +-- Peers engage in a protocol in either the client or server role. Of course +-- the client role can only interact with the serve role for the same protocol +-- and vice versa. +-- +-- 'Peer' has several type arguments: +-- +-- * the protocol itself; +-- * the client\/server role; +-- *.the current protocol state; +-- * the monad in which the peer operates; and +-- * the type of any final result once the peer terminates. +-- +-- For example: +-- +-- > pingPongClientExample :: Int -> Peer PingPong AsClient StIdle m () +-- > pingPongServerExample :: Peer PingPong AsServer StIdle m Int +-- +-- The actions that a peer can take are: +-- +-- * to perform local monadic effects +-- * to terminate with a result (but only in a terminal protocol state) +-- * to send a message (but only in a protocol state in which we have agency) +-- * to wait to receive a message (but only in a protocol state in which the +-- other peer has agency) +-- +-- The 'Yield', 'Await' and 'Done' constructors require to provide an evidence +-- that the appropriate peer has agency. This information is supplied using +-- one of the constructors of 'ReflRelativeAgency'. +-- +-- While this evidence must be provided, the types guarantee that it is not +-- possible to supply incorrect evidence. The +-- 'Network.TypedProtocol.Peer.Client' or 'Network.TypedProtocol.Peer.Server' +-- pattern synonyms provide this evidence automatically. +-- +-- TODO: +-- We are not exposing pipelined version, since it is not possible to write +-- a driver & proofs in a type safe which take into account the state when the +-- peer type only tracks depth of pipelining rather than pipelined transitions. +-- +type Peer :: forall ps + -> PeerRole + -> ps + -> (ps -> Type) + -- ^ protocol state + -> (Type -> Type) + -- ^ monad's kind + -> Type + -> Type +data Peer ps pr st f m a where + + -- | Perform a local monadic effect and then continue. + -- + -- Example: + -- + -- > Effect $ do + -- > ... -- actions in the monad + -- > return $ ... -- another Peer value + -- + Effect + :: forall ps pr st f m a. + m (Peer ps pr st f m a) + -- ^ monadic continuation + -> Peer ps pr st f m a + + -- | Send a message to the other peer and then continue. This takes the + -- message and the continuation. It also requires evidence that we have + -- agency for this protocol state and thus are allowed to send messages. + -- + -- Example: + -- + -- > Yield ReflClientAgency MsgPing $ ... + -- + Yield + :: forall ps pr (st :: ps) (st' :: ps) f m a. + ( StateTokenI st + , StateTokenI st' + , ActiveState st + ) + => WeHaveAgencyProof pr st + -- ^ agency singleton + -> f st' + -- ^ protocol state + -> Message ps st st' + -- ^ protocol message + -> Peer ps pr st' f m a + -- ^ continuation + -> Peer ps pr st f m a + + -- | Waits to receive a message from the other peer and then continues. + -- This takes the continuation that is supplied with the received message. It + -- also requires evidence that the other peer has agency for this protocol + -- state and thus we are expected to wait to receive messages. + -- + -- Note that the continuation that gets supplied with the message must be + -- prepared to deal with /any/ message that is allowed in /this/ protocol + -- state. This is why the continuation /must/ be polymorphic in the target + -- state of the message (the third type argument of 'Message'). + -- + -- Example: + -- + -- > Await ReflClientAgency $ \msg -> + -- > case msg of + -- > MsgDone -> ... + -- > MsgPing -> ... + -- + Await + :: forall ps pr (st :: ps) f m a. + ( StateTokenI st + , ActiveState st + ) + => TheyHaveAgencyProof pr st + -- ^ agency singleton + -> (forall (st' :: ps). + f st + -> Message ps st st' + -> ( Peer ps pr st' f m a + , f st' + ) + ) + -- ^ continuation + -> Peer ps pr st f m a + + -- | Terminate with a result. A state token must be provided from the + -- 'NobodyHasAgency' states, to show that this is a state in which we can + -- terminate. + -- + -- Example: + -- + -- > Yield ReflClientAgency + -- > MsgDone + -- > (Done ReflNobodyAgency TokDone result) + -- + Done + :: forall ps pr (st :: ps) f m a. + ( StateTokenI st + , StateAgency st ~ NobodyAgency + ) + => NobodyHasAgencyProof pr st + -- ^ (no) agency proof + -> a + -- ^ returned value + -> Peer ps pr st f m a + +deriving instance Functor m => Functor (Peer ps pr st f m) diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs new file mode 100644 index 00000000..c61361f5 --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | Bidirectional patterns for @'Peer' ps 'AsClient'@. The advantage of +-- these patterns is that they automatically provide the 'RelativeAgencyEq' +-- singleton. +-- +module Network.TypedProtocol.Stateful.Peer.Client + ( Client + , pattern Effect + , pattern Yield + , pattern Await + , pattern Done + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Stateful.Peer (Peer) +import qualified Network.TypedProtocol.Stateful.Peer as TP + + +type Client :: forall ps + -> ps + -> (ps -> Type) + -> (Type -> Type) + -> Type + -> Type +type Client ps st f m a = Peer ps AsClient st f m a + + +-- | Client role pattern for 'TP.Effect'. +-- +pattern Effect :: forall ps st f m a. + m (Client ps st f m a) + -- ^ monadic continuation + -> Client ps st f m a +pattern Effect mclient = TP.Effect mclient + + +-- | Client role pattern for 'TP.Yield' +-- +pattern Yield :: forall ps st f m a. + () + => forall st'. + ( StateTokenI st + , StateTokenI st' + , StateAgency st ~ ClientAgency + ) + => f st' + -> Message ps st st' + -- ^ protocol message + -> Client ps st' f m a + -- ^ continuation + -> Client ps st f m a +pattern Yield f msg k = TP.Yield ReflClientAgency f msg k + + +-- | Client role pattern for 'TP.Await' +-- +pattern Await :: forall ps st f m a. + () + => ( StateTokenI st + , StateAgency st ~ ServerAgency + ) + => (forall st'. + f st + -> Message ps st st' + -> ( Client ps st' f m a + , f st' + ) + ) + -- ^ continuation + -> Client ps st f m a +pattern Await k = TP.Await ReflServerAgency k + + +-- | Client role pattern for 'TP.Done' +-- +pattern Done :: forall ps st f m a. + () + => ( StateTokenI st + , StateAgency st ~ NobodyAgency + ) + => a + -- ^ protocol return value + -> Client ps st f m a +pattern Done a = TP.Done ReflNobodyAgency a + + +{-# COMPLETE Effect, Yield, Await, Done #-} diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs new file mode 100644 index 00000000..40a046c1 --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | Bidirectional patterns for @'Peer' ps 'AsServer'@. The advantage of +-- these patterns is that they automatically provide the 'RelativeAgencyEq' +-- singleton. +-- +module Network.TypedProtocol.Stateful.Peer.Server + ( Server + , pattern Effect + , pattern Yield + , pattern Await + , pattern Done + ) where + +import Data.Kind (Type) + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Stateful.Peer (Peer) +import qualified Network.TypedProtocol.Stateful.Peer as TP + + +type Server :: forall ps + -> ps + -> (ps -> Type) + -> (Type -> Type) + -> Type + -> Type +type Server ps st f m a = Peer ps AsServer st f m a + + +-- | Server role pattern for 'TP.Effect'. +-- +pattern Effect :: forall ps st f m a. + m (Server ps st f m a) + -- ^ monadic continuation + -> Server ps st f m a +pattern Effect mclient = TP.Effect mclient + + +-- | Server role pattern for 'TP.Yield' +-- +pattern Yield :: forall ps st f m a. + () + => forall st'. + ( StateTokenI st + , StateTokenI st' + , StateAgency st ~ ServerAgency + ) + => f st' + -> Message ps st st' + -- ^ protocol message + -> Server ps st' f m a + -- ^ continuation + -> Server ps st f m a +pattern Yield f msg k = TP.Yield ReflServerAgency f msg k + + +-- | Server role pattern for 'TP.Await' +-- +pattern Await :: forall ps st f m a. + () + => ( StateTokenI st + , StateAgency st ~ ClientAgency + ) + => (forall st'. + f st + -> Message ps st st' + -> ( Server ps st' f m a + , f st' + ) + ) + -- ^ continuation + -> Server ps st f m a +pattern Await k = TP.Await ReflClientAgency k + + +-- | Server role pattern for 'TP.Done' +-- +pattern Done :: forall ps st f m a. + () + => ( StateTokenI st + , StateAgency st ~ NobodyAgency + ) + => a + -- ^ protocol return value + -> Server ps st f m a +pattern Done a = TP.Done ReflNobodyAgency a + +{-# COMPLETE Effect, Yield, Await, Done #-} diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Proofs.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Proofs.hs new file mode 100644 index 00000000..e91b399e --- /dev/null +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Proofs.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + + +-- This is already implied by the -Wall in the .cabal file, but lets just be +-- completely explicit about it too, since we rely on the completeness +-- checking in the cases below for the completeness of our proofs. +{-# OPTIONS_GHC -Wincomplete-patterns #-} + +-- | Proofs about the typed protocol framework. +-- +-- It also provides helpful testing utilities. +-- +module Network.TypedProtocol.Stateful.Proofs + ( connect + , TerminalStates (..) + , removeState + ) where + +import Control.Monad.Class.MonadSTM + +import Data.Kind (Type) +import Data.Singletons + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Stateful.Peer qualified as ST +import Network.TypedProtocol.Peer +import Network.TypedProtocol.Proofs (TerminalStates (..)) +import Network.TypedProtocol.Proofs qualified as TP + + + +-- | Remove state for non-pipelined peers. +-- +-- TODO: There's a difficulty to write `removeState` for pipelined peers which +-- is type safe. The `Peer` doesn't track all pipelined transitions, just the +-- depth of pipelining, so we cannot push `f st` to a queue which type is +-- linked to `Peer`. For a similar reason there's no way to write +-- `forgetPipelined` function. +-- +-- However, this is possible if `Peer` tracks all transitions. +-- +removeState + :: Functor m + => f st + -> ST.Peer ps pr st f m a + -> Peer ps pr NonPipelined st m a +removeState = go + where + go + :: forall ps (pr :: PeerRole) + (st :: ps) + (f :: ps -> Type) + m a. + Functor m + => f st + -> ST.Peer ps pr st f m a + -> Peer ps pr NonPipelined st m a + go f (ST.Effect k) = Effect (go f <$> k) + go _ (ST.Yield refl f msg k) = Yield refl msg (go f k) + go f (ST.Await refl k) = Await refl $ \msg -> + case k f msg of + (k', f') -> go f' k' + go _ (ST.Done refl a) = Done refl a + + +connect + :: forall ps (pr :: PeerRole) + (st :: ps) + (f :: ps -> Type) + m a b. + (MonadSTM m, SingI pr) + => f st + -> ST.Peer ps pr st f m a + -> ST.Peer ps (FlipAgency pr) st f m b + -> m (a, b, TerminalStates ps) +connect f a b = TP.connect (removeState f a) (removeState f b) diff --git a/typed-protocols-stateful/typed-protocols-stateful.cabal b/typed-protocols-stateful/typed-protocols-stateful.cabal new file mode 100644 index 00000000..1edcc1d4 --- /dev/null +++ b/typed-protocols-stateful/typed-protocols-stateful.cabal @@ -0,0 +1,52 @@ +name: typed-protocols-stateful +version: 0.2.0.0 +synopsis: A framework for strongly typed protocols +-- description: +license: Apache-2.0 +license-files: + LICENSE + NOTICE +copyright: 2022-2024 Input Output Global Inc (IOG) +author: Marcin Szamotulski +maintainer: marcin.szamotulski@iohk.io +category: Control +build-type: Simple + +-- These should probably be added at some point. +-- extra-source-files: ChangeLog.md, README.md + +cabal-version: >=1.10 + +library + exposed-modules: Network.TypedProtocol.Stateful.Peer + , Network.TypedProtocol.Stateful.Peer.Client + , Network.TypedProtocol.Stateful.Peer.Server + , Network.TypedProtocol.Stateful.Driver + , Network.TypedProtocol.Stateful.Proofs + , Network.TypedProtocol.Stateful.Codec + + other-extensions: GADTs + , RankNTypes + , PolyKinds + , DataKinds + , ScopedTypeVariables + , TypeFamilies + , TypeOperators + , BangPatterns + default-extensions: ImportQualifiedPost + build-depends: base, + contra-tracer, + singletons >= 3.0, + io-classes, + typed-protocols + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 246cd5e7..40e8f3ff 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -36,6 +36,9 @@ module Network.TypedProtocol.Codec , DecodeStep (..) , runDecoder , runDecoderPure + , hoistDecodeStep + , isoDecodeStep + , mapFailureDecodeStep -- ** Codec properties , AnyMessage (..) , pattern AnyMessageAndAgency From 0d9cb7775e5cbc605ff258f43740a6a348fa26a5 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 24 Jul 2024 13:37:44 +0200 Subject: [PATCH 27/39] typed-protocols: moved types to `Core` module --- .../src/Network/TypedProtocol/Core.hs | 43 ++++++++++++++++++- .../src/Network/TypedProtocol/Peer.hs | 37 ---------------- .../src/Network/TypedProtocol/Peer/Client.hs | 2 +- .../src/Network/TypedProtocol/Peer/Server.hs | 2 +- 4 files changed, 43 insertions(+), 41 deletions(-) diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index 1cf97f24..f9ba031f 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} -- need for 'Show' instance of 'ProtocolState' {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | This module defines the core of the typed protocol framework. -- @@ -43,6 +44,9 @@ module Network.TypedProtocol.Core , IsPipelined (..) , Outstanding , N (..) + , Nat (Succ, Zero) + , natToInt + , unsafeIntToNat , ActiveAgency , ActiveAgency' (..) , IsActiveState (..) @@ -51,6 +55,7 @@ module Network.TypedProtocol.Core ) where import Data.Kind (Constraint, Type) +import Unsafe.Coerce (unsafeCoerce) import Data.Singletons @@ -504,3 +509,37 @@ type Outstanding :: IsPipelined -> N type family Outstanding pl where Outstanding 'NonPipelined = Z Outstanding ('Pipelined n _) = n + +-- | A value level inductive natural number, indexed by the corresponding type +-- level natural number 'N'. +-- +-- This is often needed when writing pipelined peers to be able to count the +-- number of outstanding pipelined yields, and show to the type checker that +-- 'SenderCollect' and 'SenderDone' are being used correctly. +-- +newtype Nat (n :: N) = UnsafeInt Int + deriving Show via Int + +data IsNat (n :: N) where + IsZero :: IsNat Z + IsSucc :: Nat n -> IsNat (S n) + +toIsNat :: Nat n -> IsNat n +toIsNat (UnsafeInt 0) = unsafeCoerce IsZero +toIsNat (UnsafeInt n) = unsafeCoerce (IsSucc (UnsafeInt (pred n))) + +pattern Zero :: () => Z ~ n => Nat n +pattern Zero <- (toIsNat -> IsZero) where + Zero = UnsafeInt 0 + +pattern Succ :: () => (m ~ S n) => Nat n -> Nat m +pattern Succ n <- (toIsNat -> IsSucc n) where + Succ (UnsafeInt n) = UnsafeInt (succ n) + +{-# COMPLETE Zero, Succ #-} + +natToInt :: Nat n -> Int +natToInt (UnsafeInt n) = n + +unsafeIntToNat :: Int -> Nat n +unsafeIntToNat = UnsafeInt diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 0a02af49..69ce43e5 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -3,13 +3,11 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -- | Protocol EDSL. -- @@ -28,7 +26,6 @@ module Network.TypedProtocol.Peer ) where import Data.Kind (Type) -import Unsafe.Coerce (unsafeCoerce) import Network.TypedProtocol.Core as Core @@ -257,37 +254,3 @@ data Receiver ps pr st stdone m c where -> Receiver ps pr st stdone m c deriving instance Functor m => Functor (Receiver ps pr st stdone m) - --- | A value level inductive natural number, indexed by the corresponding type --- level natural number 'N'. --- --- This is often needed when writing pipelined peers to be able to count the --- number of outstanding pipelined yields, and show to the type checker that --- 'SenderCollect' and 'SenderDone' are being used correctly. --- -newtype Nat (n :: N) = UnsafeInt Int - deriving Show via Int - -data IsNat (n :: N) where - IsZero :: IsNat Z - IsSucc :: Nat n -> IsNat (S n) - -toIsNat :: Nat n -> IsNat n -toIsNat (UnsafeInt 0) = unsafeCoerce IsZero -toIsNat (UnsafeInt n) = unsafeCoerce (IsSucc (UnsafeInt (pred n))) - -pattern Zero :: () => Z ~ n => Nat n -pattern Zero <- (toIsNat -> IsZero) where - Zero = UnsafeInt 0 - -pattern Succ :: () => (m ~ S n) => Nat n -> Nat m -pattern Succ n <- (toIsNat -> IsSucc n) where - Succ (UnsafeInt n) = UnsafeInt (succ n) - -{-# COMPLETE Zero, Succ #-} - -natToInt :: Nat n -> Int -natToInt (UnsafeInt n) = n - -unsafeIntToNat :: Int -> Nat n -unsafeIntToNat = UnsafeInt diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index 6daf6760..51879241 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -33,7 +33,7 @@ module Network.TypedProtocol.Peer.Client import Data.Kind (Type) import Network.TypedProtocol.Core -import Network.TypedProtocol.Peer (Peer, Nat (..)) +import Network.TypedProtocol.Peer (Peer) import qualified Network.TypedProtocol.Peer as TP diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 47746329..be528302 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -33,7 +33,7 @@ module Network.TypedProtocol.Peer.Server import Data.Kind (Type) import Network.TypedProtocol.Core -import Network.TypedProtocol.Peer (Peer, Nat (..)) +import Network.TypedProtocol.Peer (Peer) import qualified Network.TypedProtocol.Peer as TP From 5ec9a8c37234561b7a4fea9c1625c509bb856251 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 24 Jul 2024 15:02:05 +0200 Subject: [PATCH 28/39] typed-protocols: connectPipelined type signature --- .../test/Network/TypedProtocol/PingPong/Tests.hs | 4 ++-- .../test/Network/TypedProtocol/ReqResp/Tests.hs | 4 ++-- typed-protocols/src/Network/TypedProtocol/Proofs.hs | 12 +++++------- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 763bcc49..015bb340 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -211,9 +211,9 @@ connect_pipelined :: PingPongClientPipelined Int Identity [Either Int Int] -> (Int, [Either Int Int]) connect_pipelined client cs = case runIdentity - (connectPipelined cs [] + (connectPipelined cs (pingPongClientPeerPipelined client) - (promoteToPipelined $ pingPongServerPeer pingPongServerCount)) + (pingPongServerPeer pingPongServerCount)) of (reqResps, n, TerminalStates SingDone SingDone) -> (n, reqResps) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 63c8caa9..5a07ef03 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -165,9 +165,9 @@ prop_connect f xs = prop_connectPipelined :: [Bool] -> (Int -> Int -> (Int, Int)) -> [Int] -> Bool prop_connectPipelined cs f xs = case runIdentity - (connectPipelined cs [] + (connectPipelined cs (reqRespClientPeerPipelined (reqRespClientMapPipelined xs)) - (promoteToPipelined $ reqRespServerPeer + (reqRespServerPeer (reqRespServerMapAccumL (\a -> pure . f a) 0))) of (c, s, TerminalStates SingDone SingDone) -> diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index d531ece5..ba3e2a43 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -243,16 +243,14 @@ promoteToPipelined (Done refl k) = Done refl k -- connectPipelined :: forall ps (pr :: PeerRole) - (st :: ps) c c' m a b. + (st :: ps) c m a b. (Monad m, SingI pr) => [Bool] - -> [Bool] - -> Peer ps pr ('Pipelined Z c) st m a - -> Peer ps (FlipAgency pr) ('Pipelined Z c') st m b + -> Peer ps pr ('Pipelined Z c) st m a + -> Peer ps (FlipAgency pr) NonPipelined st m b -> m (a, b, TerminalStates ps) -connectPipelined csA csB a b = - connect (forgetPipelined csA a) - (forgetPipelined csB b) +connectPipelined csA a b = + connect (forgetPipelined csA a) b -- | A reference specification for interleaving of requests and responses -- with pipelining, where the environment can choose whether a response is From 8d318143a9cee9e51bd6f6da3815b94ec11e41f8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 24 Jul 2024 11:57:46 +0200 Subject: [PATCH 29/39] typed-protocols: added PeerPipelined newtype wrapper --- .../Network/TypedProtocol/Driver/Simple.hs | 12 +++--- .../Network/TypedProtocol/PingPong/Client.hs | 4 +- .../Network/TypedProtocol/ReqResp/Client.hs | 10 ++--- .../Network/TypedProtocol/ReqResp/Examples.hs | 2 +- .../Network/TypedProtocol/ReqResp/Tests.hs | 10 ++--- .../src/Network/TypedProtocol/Driver.hs | 6 +-- .../src/Network/TypedProtocol/Peer.hs | 9 +++++ .../src/Network/TypedProtocol/Peer/Client.hs | 16 ++++++++ .../src/Network/TypedProtocol/Peer/Server.hs | 17 +++++++++ .../src/Network/TypedProtocol/Proofs.hs | 38 ++++++++++--------- 10 files changed, 84 insertions(+), 40 deletions(-) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs index a76f3924..04a4dcfe 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Driver/Simple.hs @@ -147,12 +147,12 @@ runPeer tracer codec channel peer = -- 'MonadSTM' constraint. -- runPipelinedPeer - :: forall ps (st :: ps) pr failure bytes c m a. + :: forall ps (st :: ps) pr failure bytes m a. (MonadAsync m, MonadThrow m, Exception failure) => Tracer m (TraceSendRecv ps) -> Codec ps failure m bytes -> Channel m bytes - -> Peer ps pr ('Pipelined Z c) st m a + -> PeerPipelined ps pr st m a -> m (a, Maybe bytes) runPipelinedPeer tracer codec channel peer = runPipelinedPeerWithDriver driver peer @@ -214,8 +214,8 @@ runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m, => m (Channel m bytes, Channel m bytes) -> Tracer m (PeerRole, TraceSendRecv ps) -> Codec ps failure m bytes - -> Peer ps pr ('Pipelined Z c) st m a - -> Peer ps (FlipAgency pr) 'NonPipelined st m b + -> PeerPipelined ps pr st m a + -> Peer ps (FlipAgency pr) 'NonPipelined st m b -> m (a, b) runConnectedPeersPipelined createChannels tracer codec client server = createChannels >>= \(clientChannel, serverChannel) -> @@ -240,8 +240,8 @@ runConnectedPeersAsymmetric -> Tracer m (Role, TraceSendRecv ps) -> Codec ps failure m bytes -> Codec ps failure m bytes - -> Peer ps pr ('Pipelined Z c) st m a - -> Peer ps (FlipAgency pr) 'NonPipelined st m b + -> PeerPipelined ps pr st m a + -> Peer ps (FlipAgency pr) 'NonPipelined st m b -> m (a, b) runConnectedPeersAsymmetric createChannels tracer codec codec' client server = createChannels >>= \(clientChannel, serverChannel) -> diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs index 003e21dc..b6398428 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Client.hs @@ -139,9 +139,9 @@ data PingPongClientIdle (n :: N) c m a where pingPongClientPeerPipelined :: Functor m => PingPongClientPipelined c m a - -> Client PingPong (Pipelined Z c) StIdle m a + -> ClientPipelined PingPong StIdle m a pingPongClientPeerPipelined (PingPongClientPipelined peer) = - pingPongClientPeerIdle peer + ClientPipelined $ pingPongClientPeerIdle peer pingPongClientPeerIdle diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs index 495976a8..4bb1e6a4 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Client.hs @@ -84,12 +84,12 @@ requestOnce server req = (\(resp, _, _) -> resp) -- | A request-response client designed for running the 'ReqResp' protocol in -- a pipelined way. -- -data ReqRespClientPipelined req resp c m a where +data ReqRespClientPipelined req resp m a where -- | A 'PingPongSender', but starting with zero outstanding pipelined -- responses, and for any internal collect type @c@. ReqRespClientPipelined :: ReqRespIdle req resp Z c m a - -> ReqRespClientPipelined req resp c m a + -> ReqRespClientPipelined req resp m a data ReqRespIdle req resp n c m a where @@ -117,10 +117,10 @@ data ReqRespIdle req resp n c m a where -- reqRespClientPeerPipelined :: Functor m - => ReqRespClientPipelined req resp c m a - -> Client (ReqResp req resp) (Pipelined Z c) StIdle m a + => ReqRespClientPipelined req resp m a + -> ClientPipelined (ReqResp req resp) StIdle m a reqRespClientPeerPipelined (ReqRespClientPipelined peer) = - reqRespClientPeerIdle peer + ClientPipelined $ reqRespClientPeerIdle peer reqRespClientPeerIdle diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs index bbf6a24c..ecfb1932 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Examples.hs @@ -68,7 +68,7 @@ reqRespClientMap = go [] reqRespClientMapPipelined :: forall req resp m. Monad m => [req] - -> ReqRespClientPipelined req resp resp m [resp] + -> ReqRespClientPipelined req resp m [resp] reqRespClientMapPipelined reqs0 = ReqRespClientPipelined (go [] Zero reqs0) where diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index 5a07ef03..a0d080ac 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -103,15 +103,15 @@ direct (SendMsgReq req kResp) ReqRespServer{recvMsgReq} = do direct client' server' -directPipelined :: forall req resp c m a b. Monad m - => ReqRespClientPipelined req resp c m a - -> ReqRespServer req resp m b +directPipelined :: Monad m + => ReqRespClientPipelined req resp m a + -> ReqRespServer req resp m b -> m (a, b) directPipelined (ReqRespClientPipelined client0) server0 = go EmptyQ client0 server0 where - go :: forall n. - Queue n c + go :: Monad m + => Queue n c -> ReqRespIdle req resp n c m a -> ReqRespServer req resp m b -> m (a, b) diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index a9e7d73b..e79d92aa 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -156,12 +156,12 @@ runPeerWithDriver Driver{sendMessage, recvMessage, initialDState} = -- 'MonadAsync' constraint. -- runPipelinedPeerWithDriver - :: forall ps (st :: ps) pr dstate c m a. + :: forall ps (st :: ps) pr dstate m a. MonadAsync m => Driver ps pr dstate m - -> Peer ps pr ('Pipelined Z c) st m a + -> PeerPipelined ps pr st m a -> m (a, dstate) -runPipelinedPeerWithDriver driver@Driver{initialDState} peer = do +runPipelinedPeerWithDriver driver@Driver{initialDState} (PeerPipelined peer) = do receiveQueue <- atomically newTQueue collectQueue <- atomically newTQueue a <- runPipelinedPeerReceiverQueue receiveQueue collectQueue driver diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index 69ce43e5..aaf9257c 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -17,6 +17,7 @@ -- module Network.TypedProtocol.Peer ( Peer (..) + , PeerPipelined (..) , Receiver (..) , Outstanding , N (..) @@ -254,3 +255,11 @@ data Receiver ps pr st stdone m c where -> Receiver ps pr st stdone m c deriving instance Functor m => Functor (Receiver ps pr st stdone m) + +-- | A description of a peer that engages in a protocol in a pipelined fashion. +-- +data PeerPipelined ps pr (st :: ps) m a where + PeerPipelined :: { runPeerPipelined :: Peer ps pr (Pipelined Z c) st m a } + -> PeerPipelined ps pr st m a + +deriving instance Functor m => Functor (PeerPipelined ps pr st m) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index 51879241..afa210a9 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -13,6 +13,8 @@ -- module Network.TypedProtocol.Peer.Client ( Client + , ClientPipelined + , TP.PeerPipelined(ClientPipelined, runClientPipelined) , pattern Effect , pattern Yield , pattern Await @@ -46,6 +48,20 @@ type Client :: forall ps type Client ps pl st m a = Peer ps AsClient pl st m a +-- | A description of a peer that engages in a protocol in a pipelined fashion. +-- +type ClientPipelined ps st m a = TP.PeerPipelined ps AsClient st m a + +pattern ClientPipelined :: forall ps st m a. + () + => forall c. + () + => Client ps (Pipelined Z c) st m a + -> ClientPipelined ps st m a +pattern ClientPipelined { runClientPipelined } = TP.PeerPipelined runClientPipelined + +{-# COMPLETE ClientPipelined #-} + -- | Client role pattern for 'TP.Effect'. -- pattern Effect :: forall ps pl st m a. diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index be528302..391911f1 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -13,6 +13,8 @@ -- module Network.TypedProtocol.Peer.Server ( Server + , ServerPipelined + , TP.PeerPipelined(ServerPipelined, runServerPipelined) , pattern Effect , pattern Yield , pattern Await @@ -46,6 +48,21 @@ type Server :: forall ps type Server ps pl st m a = Peer ps AsServer pl st m a +-- | A description of a peer that engages in a protocol in a pipelined fashion. +-- +type ServerPipelined ps st m a = TP.PeerPipelined ps AsServer st m a + +pattern ServerPipelined :: forall ps st m a. + () + => forall c. + () + => Server ps (Pipelined Z c) st m a + -> ServerPipelined ps st m a +pattern ServerPipelined { runServerPipelined } = TP.PeerPipelined runServerPipelined + +{-# COMPLETE ServerPipelined #-} + + -- | Server role pattern for 'TP.Effect'. -- pattern Effect :: forall ps pl st m a. diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index ba3e2a43..67dbfd43 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -169,7 +169,7 @@ enqueue a (ConsQ b q) = ConsQ b (enqueue a q) -- us extra expressiveness or to break the protocol state machine. -- forgetPipelined - :: forall ps (pr :: PeerRole) (st :: ps) c m a. + :: forall ps (pr :: PeerRole) (st :: ps) m a. Functor m => [Bool] -- ^ interleaving choices for pipelining allowed by @@ -177,11 +177,11 @@ forgetPipelined -- pipelining. For the 'CollectSTM' primitive, the stm action must not -- block otherwise even if the choice is to pipeline more (a 'True' value), -- we'll actually collect a result. - -> Peer ps pr (Pipelined Z c) st m a + -> PeerPipelined ps pr st m a -> Peer ps pr NonPipelined st m a -forgetPipelined = goSender EmptyQ +forgetPipelined cs0 (PeerPipelined peer) = goSender EmptyQ cs0 peer where - goSender :: forall st' n. + goSender :: forall st' n c. Queue n c -> [Bool] -> Peer ps pr ('Pipelined n c) st' m a @@ -196,7 +196,7 @@ forgetPipelined = goSender EmptyQ goSender (ConsQ x q) (_:cs) (Collect _ k) = goSender q cs (k x) goSender (ConsQ x q) cs@[] (Collect _ k) = goSender q cs (k x) - goReceiver :: forall stCurrent stNext n. + goReceiver :: forall stCurrent stNext n c. Queue n c -> [Bool] -> Peer ps pr ('Pipelined (S n) c) stNext m a @@ -218,17 +218,19 @@ forgetPipelined = goSender EmptyQ -- using `connectPipelined` function. -- promoteToPipelined - :: forall ps (pr :: PeerRole) st c m a. + :: forall ps (pr :: PeerRole) st m a. Functor m - => Peer ps pr 'NonPipelined st m a - -> Peer ps pr ('Pipelined Z c) st m a -promoteToPipelined (Effect k) = Effect - $ promoteToPipelined <$> k -promoteToPipelined (Yield refl msg k) = Yield refl msg - $ promoteToPipelined k -promoteToPipelined (Await refl k) = Await refl - $ promoteToPipelined . k -promoteToPipelined (Done refl k) = Done refl k + => Peer ps pr NonPipelined st m a + -> PeerPipelined ps pr st m a +promoteToPipelined p = PeerPipelined (go p) + where + go :: forall st' c. + Peer ps pr NonPipelined st' m a + -> Peer ps pr (Pipelined Z c) st' m a + go (Effect k) = Effect $ go <$> k + go (Yield refl msg k) = Yield refl msg (go k) + go (Await refl k) = Await refl (go . k) + go (Done refl k) = Done refl k -- | Analogous to 'connect' but also for pipelined peers. @@ -243,11 +245,11 @@ promoteToPipelined (Done refl k) = Done refl k -- connectPipelined :: forall ps (pr :: PeerRole) - (st :: ps) c m a b. + (st :: ps) m a b. (Monad m, SingI pr) => [Bool] - -> Peer ps pr ('Pipelined Z c) st m a - -> Peer ps (FlipAgency pr) NonPipelined st m b + -> PeerPipelined ps pr st m a + -> Peer ps (FlipAgency pr) NonPipelined st m b -> m (a, b, TerminalStates ps) connectPipelined csA a b = connect (forgetPipelined csA a) b From b3ba7798545c4daf7b85456b3d06d55197fe3300 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 26 Jul 2024 12:50:54 +0200 Subject: [PATCH 30/39] Support io-classes-1.7 --- cabal.project | 2 +- .../src/Network/TypedProtocol/Stateful/Codec/CBOR.hs | 4 ++-- .../typed-protocols-stateful-cborg.cabal | 3 +-- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/cabal.project b/cabal.project index 5c05c7e9..08b51055 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ repository cardano-haskell-packages index-state: hackage.haskell.org 2024-08-27T18:06:30Z - , cardano-haskell-packages 2024-06-27T10:53:24Z + , cardano-haskell-packages 2024-07-24T14:16:32Z packages: ./typed-protocols ./typed-protocols-cborg diff --git a/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs index 254a8a72..400d8367 100644 --- a/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs +++ b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs @@ -72,7 +72,7 @@ mkCodecCborStrictBS cborMsgEncode cborMsgDecode = :: (forall s. CBOR.Decoder s a) -> m (DecodeStep BS.ByteString DeserialiseFailure m a) convertCborDecoder cborDecode = - withLiftST (convertCborDecoderBS cborDecode) + convertCborDecoderBS cborDecode stToIO -- | Construct a 'Codec' for a CBOR based serialisation format, using lazy -- 'BS.ByteString's. @@ -114,7 +114,7 @@ mkCodecCborLazyBS cborMsgEncode cborMsgDecode = :: (forall s. CBOR.Decoder s a) -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) convertCborDecoder cborDecode = - withLiftST (convertCborDecoderLBS cborDecode) + convertCborDecoderLBS cborDecode stToIO {-# NOINLINE toLazyByteString #-} toLazyByteString :: BS.Builder -> LBS.ByteString diff --git a/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal b/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal index 5d41dfc9..8894854d 100644 --- a/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal +++ b/typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal @@ -1,3 +1,4 @@ +cabal-version: 3.0 name: typed-protocols-stateful-cborg version: 0.2.0.0 synopsis: CBOR codecs for typed-protocols @@ -15,8 +16,6 @@ build-type: Simple -- These should probably be added at some point. extra-source-files: ChangeLog.md, README.md -cabal-version: >=1.10 - library exposed-modules: Network.TypedProtocol.Stateful.Codec.CBOR From b23f32724b01ad9c1ad837e2d8f6ea4e1c2f15d9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 19 Aug 2024 15:24:07 +0200 Subject: [PATCH 31/39] typed-protocols: added haddocks --- typed-protocols/src/Network/TypedProtocol/Peer.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index aaf9257c..fce1ca78 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -227,7 +227,14 @@ data Peer ps pr pl st m a where deriving instance Functor m => Functor (Peer ps pr pl st m) --- | Receiver +-- | Receiver. It is limited to only awaiting for messages and running monadic +-- computations. This means that on can only pipeline messages if they can be +-- connected by state transitions which all have remote agency. +-- +-- The receiver runs in parallel, see `runPipelinedPeerWithDriver`. This makes +-- pipelining quite effective, since the receiver callbacks are called in +-- a separate thread which can effectively use CPU cache. +-- type Receiver :: forall ps -> PeerRole -> ps @@ -241,11 +248,17 @@ type Receiver :: forall ps -> Type data Receiver ps pr st stdone m c where + -- | Execute a monadic computation. + -- ReceiverEffect :: m (Receiver ps pr st stdone m c) -> Receiver ps pr st stdone m c + -- | Return value. + -- ReceiverDone :: c -> Receiver ps pr stdone stdone m c + -- | Await for for a remote transition. + -- ReceiverAwait :: ( StateTokenI st , ActiveState st ) From 72a799c97178cb9a2473d730225a4c5a5de9af23 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 22 Aug 2024 17:45:51 +0200 Subject: [PATCH 32/39] disabled `typed-protocols-doc` in GHA --- .github/workflows/haskell.yml | 4 ++-- cabal.project | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 5d0cfc73..7d43e42f 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -93,8 +93,8 @@ jobs: - name: typed-protocols-examples [test] run: cabal run typed-protocols-examples:test - - name: typed-protocols-doc [test] - run: cabal test typed-protocols-doc + # - name: typed-protocols-doc [test] + # run: cabal test typed-protocols-doc stylish-haskell: runs-on: ubuntu-22.04 diff --git a/cabal.project b/cabal.project index 08b51055..aec676d4 100644 --- a/cabal.project +++ b/cabal.project @@ -19,6 +19,6 @@ packages: ./typed-protocols ./typed-protocols-stateful ./typed-protocols-stateful-cborg ./typed-protocols-examples - ./typed-protocols-doc + -- ./typed-protocols-doc test-show-details: direct From 5cf79f3fe83afaa790de61bf8f6f0ce67e20f7b9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 22 Aug 2024 18:16:04 +0200 Subject: [PATCH 33/39] stylish-haskell: fixes --- .../test/Network/TypedProtocol/PingPong/Tests.hs | 10 +++++----- .../test/Network/TypedProtocol/ReqResp/Tests.hs | 16 ++++++++-------- typed-protocols/src/Network/TypedProtocol.hs | 2 +- .../src/Network/TypedProtocol/Codec.hs | 2 +- .../src/Network/TypedProtocol/Driver.hs | 2 +- .../src/Network/TypedProtocol/Peer/Client.hs | 2 +- .../src/Network/TypedProtocol/Peer/Server.hs | 2 +- 7 files changed, 18 insertions(+), 18 deletions(-) diff --git a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs index 015bb340..65dfabaf 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/PingPong/Tests.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} -- orphaned arbitrary instances {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs index a0d080ac..a58c21e0 100644 --- a/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs +++ b/typed-protocols-examples/test/Network/TypedProtocol/ReqResp/Tests.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- orphaned arbitrary instances {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/typed-protocols/src/Network/TypedProtocol.hs b/typed-protocols/src/Network/TypedProtocol.hs index 779c622c..6a6aa88e 100644 --- a/typed-protocols/src/Network/TypedProtocol.hs +++ b/typed-protocols/src/Network/TypedProtocol.hs @@ -18,8 +18,8 @@ module Network.TypedProtocol ) where import Network.TypedProtocol.Core -import Network.TypedProtocol.Peer import Network.TypedProtocol.Driver +import Network.TypedProtocol.Peer import Network.TypedProtocol.Proofs diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 40e8f3ff..761f3f05 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -51,7 +51,7 @@ module Network.TypedProtocol.Codec , prop_codecs_compatM , prop_codecs_compat , SomeState (..) - -- ** StateToken + -- ** StateToken , StateToken , StateTokenI (..) ) where diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index e79d92aa..c94dbb2f 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index afa210a9..1876a530 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -14,7 +14,7 @@ module Network.TypedProtocol.Peer.Client ( Client , ClientPipelined - , TP.PeerPipelined(ClientPipelined, runClientPipelined) + , TP.PeerPipelined (ClientPipelined, runClientPipelined) , pattern Effect , pattern Yield , pattern Await diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 391911f1..468dae3c 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -14,7 +14,7 @@ module Network.TypedProtocol.Peer.Server ( Server , ServerPipelined - , TP.PeerPipelined(ServerPipelined, runServerPipelined) + , TP.PeerPipelined (ServerPipelined, runServerPipelined) , pattern Effect , pattern Yield , pattern Await From b9e71bb4837fee187e62b4b316d425e620295a43 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 23 Aug 2024 08:08:01 +0200 Subject: [PATCH 34/39] typed-protocols: removed unused extensions --- typed-protocols/src/Network/TypedProtocol/Codec.hs | 3 --- typed-protocols/src/Network/TypedProtocol/Lemmas.hs | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 761f3f05..22e78ffa 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -8,9 +8,6 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- @UndecidableInstances@ extension is required for defining @Show@ instance of -- @'AnyMessage'@ and @'AnyMessage'@. diff --git a/typed-protocols/src/Network/TypedProtocol/Lemmas.hs b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs index 00bb6e57..a17fe88e 100644 --- a/typed-protocols/src/Network/TypedProtocol/Lemmas.hs +++ b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs @@ -4,8 +4,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use camelCase" #-} -- | The module contains exclusion lemmas which are proven using ad absurdum: From 20aa2fe25efcaaebb6a14e8e91baadf73ff07259 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 23 Aug 2024 13:54:18 +0200 Subject: [PATCH 35/39] Improved haddocks, removed unused pragmas (extensions) --- .../src/Network/TypedProtocol/Codec/CBOR.hs | 28 ++- .../Network/TypedProtocol/PingPong/Type.hs | 9 +- .../TypedProtocol/Stateful/Codec/CBOR.hs | 4 + .../Network/TypedProtocol/Stateful/Codec.hs | 22 ++- .../Network/TypedProtocol/Stateful/Driver.hs | 15 +- .../Network/TypedProtocol/Stateful/Peer.hs | 4 +- .../TypedProtocol/Stateful/Peer/Client.hs | 3 +- .../TypedProtocol/Stateful/Peer/Server.hs | 3 +- typed-protocols/src/Network/TypedProtocol.hs | 2 - .../src/Network/TypedProtocol/Codec.hs | 149 +++++++++------ .../src/Network/TypedProtocol/Core.hs | 173 ++++++++++-------- .../src/Network/TypedProtocol/Driver.hs | 47 +++-- .../src/Network/TypedProtocol/Lemmas.hs | 23 +++ .../src/Network/TypedProtocol/Peer.hs | 65 ++++--- .../src/Network/TypedProtocol/Peer/Client.hs | 13 +- .../src/Network/TypedProtocol/Peer/Server.hs | 13 +- .../src/Network/TypedProtocol/Proofs.hs | 61 ++---- 17 files changed, 356 insertions(+), 278 deletions(-) diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index 814d30b3..990960e2 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -7,11 +8,12 @@ module Network.TypedProtocol.Codec.CBOR ( module Network.TypedProtocol.Codec - , DeserialiseFailure , mkCodecCborLazyBS , mkCodecCborStrictBS , convertCborDecoderBS , convertCborDecoderLBS + -- * Re-exports + , CBOR.DeserialiseFailure (..) ) where import Control.Monad.Class.MonadST (MonadST (..)) @@ -31,8 +33,6 @@ import Network.TypedProtocol.Codec import Network.TypedProtocol.Core -type DeserialiseFailure = CBOR.DeserialiseFailure - -- | Construct a 'Codec' for a CBOR based serialisation format, using strict -- 'BS.ByteString's. -- @@ -52,13 +52,15 @@ mkCodecCborStrictBS StateTokenI st => ActiveState st => Message ps st st' -> CBOR.Encoding) + -- ^ cbor encoder -> (forall (st :: ps) s. ActiveState st => StateToken st -> CBOR.Decoder s (SomeMessage st)) + -- ^ cbor decoder - -> Codec ps DeserialiseFailure m BS.ByteString + -> Codec ps CBOR.DeserialiseFailure m BS.ByteString mkCodecCborStrictBS cborMsgEncode cborMsgDecode = Codec { encode = \msg -> convertCborEncoder cborMsgEncode msg, @@ -72,20 +74,22 @@ mkCodecCborStrictBS cborMsgEncode cborMsgDecode = convertCborDecoder :: (forall s. CBOR.Decoder s a) - -> m (DecodeStep BS.ByteString DeserialiseFailure m a) + -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m a) convertCborDecoder cborDecode = convertCborDecoderBS cborDecode stToIO convertCborDecoderBS :: forall s m a. Functor m - => (CBOR.Decoder s a) + => CBOR.Decoder s a + -- ^ cbor decoder -> (forall b. ST s b -> m b) - -> m (DecodeStep BS.ByteString DeserialiseFailure m a) + -- ^ lift ST computation (e.g. 'Control.Monad.ST.stToIO', 'stToPrim', etc) + -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m a) convertCborDecoderBS cborDecode liftST = go <$> liftST (CBOR.deserialiseIncremental cborDecode) where go :: CBOR.IDecode s a - -> DecodeStep BS.ByteString DeserialiseFailure m a + -> DecodeStep BS.ByteString CBOR.DeserialiseFailure m a go (CBOR.Done trailing _ x) | BS.null trailing = DecodeDone x Nothing | otherwise = DecodeDone x (Just trailing) @@ -108,11 +112,13 @@ mkCodecCborLazyBS StateTokenI st => ActiveState st => Message ps st st' -> CBOR.Encoding) + -- ^ cbor encoder -> (forall (st :: ps) s. ActiveState st => StateToken st -> CBOR.Decoder s (SomeMessage st)) + -- ^ cbor decoder -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString mkCodecCborLazyBS cborMsgEncode cborMsgDecode = @@ -135,8 +141,10 @@ mkCodecCborLazyBS cborMsgEncode cborMsgDecode = convertCborDecoderLBS :: forall s m a. Monad m - => (CBOR.Decoder s a) + => CBOR.Decoder s a + -- ^ cbor decoder -> (forall b. ST s b -> m b) + -- ^ lift ST computation (e.g. 'Control.Monad.ST.stToIO', 'stToPrim', etc) -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) convertCborDecoderLBS cborDecode liftST = go [] =<< liftST (CBOR.deserialiseIncremental cborDecode) @@ -156,7 +164,7 @@ convertCborDecoderLBS cborDecode liftST = -- We keep a bunch of chunks and supply the CBOR decoder with them -- until we run out, when we go get another bunch. go (c:cs) (CBOR.Partial k) = go cs =<< liftST (k (Just c)) - go [] (CBOR.Partial k) = return $ DecodePartial $ \mbs -> case mbs of + go [] (CBOR.Partial k) = return $ DecodePartial $ \case Nothing -> go [] =<< liftST (k Nothing) Just bs -> go cs (CBOR.Partial k) where cs = LBS.toChunks bs diff --git a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs index 98ac0f73..5c8c5534 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/PingPong/Type.hs @@ -42,12 +42,9 @@ data SPingPong (st :: PingPong) where deriving instance Show (SPingPong st) -instance StateTokenI StIdle where - stateToken = SingIdle -instance StateTokenI StBusy where - stateToken = SingBusy -instance StateTokenI StDone where - stateToken = SingDone +instance StateTokenI StIdle where stateToken = SingIdle +instance StateTokenI StBusy where stateToken = SingBusy +instance StateTokenI StDone where stateToken = SingDone instance Protocol PingPong where diff --git a/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs index 400d8367..6b159ced 100644 --- a/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs +++ b/typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs @@ -49,12 +49,14 @@ mkCodecCborStrictBS StateTokenI st =>ActiveState st => f st' -> Message ps st st' -> CBOR.Encoding) + -- ^ cbor encoder -> (forall (st :: ps) s. ActiveState st => StateToken st -> f st -> CBOR.Decoder s (SomeMessage st)) + -- ^ cbor decoder -> Codec ps DeserialiseFailure f m BS.ByteString mkCodecCborStrictBS cborMsgEncode cborMsgDecode = @@ -90,12 +92,14 @@ mkCodecCborLazyBS => ActiveState st => f st' -> Message ps st st' -> CBOR.Encoding) + -- ^ cbor encoder -> (forall (st :: ps) s. ActiveState st => StateToken st -> f st -> CBOR.Decoder s (SomeMessage st)) + -- ^ cbor decoder -> Codec ps CBOR.DeserialiseFailure f m LBS.ByteString mkCodecCborLazyBS cborMsgEncode cborMsgDecode = diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs index 7b5478a7..27f47e6a 100644 --- a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs @@ -24,16 +24,23 @@ module Network.TypedProtocol.Stateful.Codec , isoCodec , mapFailureCodec , liftCodec - -- ** Related types - , ActiveState - , PeerRole (..) - , SomeMessage (..) - , CodecFailure (..) -- ** Incremental decoding , DecodeStep (..) , runDecoder , runDecoderPure - -- ** Codec properties + -- ** Related types + -- *** SomeMessage + , SomeMessage (..) + -- *** StateToken + , StateToken + , StateTokenI (..) + -- *** ActiveState + , ActiveState + -- *** PeerRole + , PeerRole (..) + -- * CodecFailure + , CodecFailure (..) + -- * Testing codec properties , AnyMessage (..) , pattern AnyMessageAndAgency , prop_codecM @@ -42,9 +49,6 @@ module Network.TypedProtocol.Stateful.Codec , prop_codec_splits , prop_codecs_compatM , prop_codecs_compat - -- ** StateToken - , StateToken - , StateTokenI (..) ) where import Data.Kind (Type) diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs index e51994aa..8719e412 100644 --- a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Driver.hs @@ -13,12 +13,13 @@ -- imported qualified. -- module Network.TypedProtocol.Stateful.Driver - ( -- * Running a peer - runPeerWithDriver + ( -- * DriverIngerface + Driver (..) + -- * Running a peer + , runPeerWithDriver -- * Re-exports - , DecodeStep (..) - , Driver (..) , SomeMessage (..) + , DecodeStep (..) ) where import Control.Monad.Class.MonadSTM @@ -46,12 +47,6 @@ data Driver ps (pr :: PeerRole) bytes failure dstate f m = , -- | Receive a message, a blocking action which reads from the network -- and runs the incremental decoder until a full message is decoded. - -- As an input it might receive a 'DecodeStep' previously started with - -- 'tryRecvMessage'. - -- - -- It could be implemented in terms of 'recvMessageSTM', but in some - -- cases it can be easier (or more performant) to have a different - -- implementation. -- recvMessage :: forall (st :: ps). StateTokenI st diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs index 30f92e53..e228910c 100644 --- a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer.hs @@ -46,8 +46,8 @@ import Network.TypedProtocol.Core as Core -- -- For example: -- --- > pingPongClientExample :: Int -> Peer PingPong AsClient StIdle m () --- > pingPongServerExample :: Peer PingPong AsServer StIdle m Int +-- > pingPongClientExample :: Peer PingPong AsClient StIdle m () +-- > pingPongServerExample :: Peer PingPong AsServer StIdle m Int -- -- The actions that a peer can take are: -- diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs index c61361f5..5140c16e 100644 --- a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Client.hs @@ -12,7 +12,8 @@ -- singleton. -- module Network.TypedProtocol.Stateful.Peer.Client - ( Client + ( -- * Client type alias and its pattern synonyms + Client , pattern Effect , pattern Yield , pattern Await diff --git a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs index 40a046c1..a1fbc9c8 100644 --- a/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs +++ b/typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Peer/Server.hs @@ -12,7 +12,8 @@ -- singleton. -- module Network.TypedProtocol.Stateful.Peer.Server - ( Server + ( -- * Server type alias and its pattern synonyms + Server , pattern Effect , pattern Yield , pattern Await diff --git a/typed-protocols/src/Network/TypedProtocol.hs b/typed-protocols/src/Network/TypedProtocol.hs index 6a6aa88e..b79a0aec 100644 --- a/typed-protocols/src/Network/TypedProtocol.hs +++ b/typed-protocols/src/Network/TypedProtocol.hs @@ -8,7 +8,6 @@ module Network.TypedProtocol -- * Defining and implementing protocols -- $defining module Network.TypedProtocol.Core - , module Network.TypedProtocol.Peer -- ** Protocol proofs and tests -- $tests , module Network.TypedProtocol.Proofs @@ -19,7 +18,6 @@ module Network.TypedProtocol import Network.TypedProtocol.Core import Network.TypedProtocol.Driver -import Network.TypedProtocol.Peer import Network.TypedProtocol.Proofs diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 22e78ffa..50be7f41 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -1,42 +1,50 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- @UndecidableInstances@ extension is required for defining @Show@ instance of -- @'AnyMessage'@ and @'AnyMessage'@. -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module Network.TypedProtocol.Codec ( -- * Defining and using Codecs + -- ** Codec type Codec (..) , hoistCodec , isoCodec , mapFailureCodec + -- ** Incremental decoding + , DecodeStep (..) + , runDecoder + , runDecoderPure + , hoistDecodeStep + , isoDecodeStep + , mapFailureDecodeStep -- ** Related types + -- *** SomeMessage + , SomeMessage (..) + -- *** StateToken + , StateToken + , StateTokenI (..) + -- *** ActiveState , IsActiveState (..) , ActiveState , ActiveAgency , ActiveAgency' (..) , notActiveState + -- *** PeerRole , PeerRole (..) - , SomeMessage (..) + -- * CodecFailure , CodecFailure (..) - -- ** Incremental decoding - , DecodeStep (..) - , runDecoder - , runDecoderPure - , hoistDecodeStep - , isoDecodeStep - , mapFailureDecodeStep - -- ** Codec properties + -- * Testing codec properties , AnyMessage (..) , pattern AnyMessageAndAgency , prop_codecM @@ -48,9 +56,6 @@ module Network.TypedProtocol.Codec , prop_codecs_compatM , prop_codecs_compat , SomeState (..) - -- ** StateToken - , StateToken - , StateTokenI (..) ) where import Control.Exception (Exception) @@ -69,17 +74,10 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- The codec is parametrised by: -- -- * The protocol --- * The peer role (client\/server) -- * the type of decoding failures -- * the monad in which the decoder runs -- * the type of the encoded data (typically strings or bytes) -- --- It is expected that typical codec implementations will be polymorphic in --- the peer role. For example a codec for the ping\/pong protocol might have --- type: --- --- > codecPingPong :: forall m. Monad m => Codec PingPong String m String --- -- A codec consists of a message encoder and a decoder. -- -- The encoder is supplied both with the message to encode and the current @@ -93,9 +91,9 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- > encode :: SingI st -- > => Message PingPong st st' -- > -> String --- > encode MsgPing = "ping\n" --- > encode MsgDone = "done\n" --- > encode MsgPong = "pong\n" +-- > encode MsgPing = "ping\n" +-- > encode MsgDone = "done\n" +-- > encode MsgPong = "pong\n" -- -- The decoder is also given the current protocol state and it is expected to -- be able to decode /any/ message that is valid in that state, but /only/ @@ -113,22 +111,24 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- decoder input matches exactly with the message boundaries. -- -- > decode :: forall st m. SingI st --- > => m (DecodeStep String String m (SomeMessage st)) --- > decode = +-- > => StateToken st +-- > -> m (DecodeStep String String m (SomeMessage st)) +-- > decode stok = -- > decodeTerminatedFrame '\n' $ \str trailing -> --- > case (stateToken :: StateToken st, str) of --- > (TokBusy, "pong") -> +-- > case (stok, str) of +-- > (SingBusy, "pong") -> -- > DecodeDone (SomeMessage MsgPong) trailing --- > (TokIdle, "ping") -> +-- > (SingIdle, "ping") -> -- > DecodeDone (SomeMessage MsgPing) trailing --- > (TokIdle, "done") -> +-- > (SingIdle, "done") -> -- > DecodeDone (SomeMessage MsgDone) trailing -- > _ -> DecodeFail ("unexpected message: " ++ str) -- --- The main thing to note is the pattern matching on the combination of the --- message string and the protocol state. This neatly fulfils the requirement --- that we only return messages that are of the correct type for the given --- protocol state. +-- See "typed-protocols-examples" for the full example. +-- +-- Note that the pattern matching on the combination of the message string and +-- the protocol state. This neatly fulfils the requirement that we only return +-- messages that are of the correct type for the given protocol state. -- -- This toy example format uses newlines @\n@ as a framing format. See -- 'DecodeStep' for suggestions on how to use it for more realistic formats. @@ -137,37 +137,52 @@ data Codec ps failure m bytes = Codec { encode :: forall (st :: ps) (st' :: ps). StateTokenI st => ActiveState st + -- evidence that the state 'st' is active => Message ps st st' + -- message to encode -> bytes, decode :: forall (st :: ps). ActiveState st => StateToken st + -- evidence for an active state -> m (DecodeStep bytes failure m (SomeMessage st)) } +-- TODO: input-output-hk/typed-protocols#57 +-- | Change functor in which the codec is running. +-- hoistCodec :: ( Functor n ) => (forall x . m x -> n x) + -- ^ a natural transformation -> Codec ps failure m bytes -> Codec ps failure n bytes hoistCodec nat codec = codec { decode = fmap (hoistDecodeStep nat) . nat . decode codec } +-- | Change bytes of a codec. +-- isoCodec :: Functor m - => (bytes -> bytes') + => (bytes -> bytes') + -- ^ map from 'bytes' to `bytes'` -> (bytes' -> bytes) + -- ^ its inverse -> Codec ps failure m bytes + -- ^ codec -> Codec ps failure m bytes' isoCodec f finv Codec {encode, decode} = Codec { encode = \msg -> f $ encode msg, decode = \tok -> isoDecodeStep f finv <$> decode tok } +-- | Modify failure type. +-- mapFailureCodec :: Functor m => (failure -> failure') + -- ^ a function to apply to failure -> Codec ps failure m bytes -> Codec ps failure' m bytes mapFailureCodec f Codec {encode, decode} = Codec { @@ -175,16 +190,6 @@ mapFailureCodec f Codec {encode, decode} = Codec { decode = \tok -> mapFailureDecodeStep f <$> decode tok } --- The types here are pretty fancy. The decode is polymorphic in the protocol --- state, but only for kinds that are the same kind as the protocol state. --- The TheyHaveAgency is a type family that resolves to a singleton, and the --- result uses existential types to hide the unknown type of the state we're --- transitioning to. --- --- Both the Message and TheyHaveAgency data families are indexed on the kind ps --- which is why it has to be a parameter here, otherwise these type functions --- are unusable. - -- | An incremental decoder with return a value of type @a@. -- @@ -212,19 +217,28 @@ data DecodeStep bytes failure m a = -- @'fail'@ or was not provided enough input. | DecodeFail failure + +-- | Change bytes of 'DecodeStep'. +-- isoDecodeStep :: Functor m => (bytes -> bytes') + -- ^ map from 'bytes' to `bytes'` -> (bytes' -> bytes) + -- its inverse -> DecodeStep bytes failure m a -> DecodeStep bytes' failure m a isoDecodeStep f finv (DecodePartial g) = DecodePartial (fmap (isoDecodeStep f finv) . g . fmap finv) isoDecodeStep f _finv (DecodeDone a bytes) = DecodeDone a (fmap f bytes) isoDecodeStep _f _finv (DecodeFail failure) = DecodeFail failure + +-- | Change functor in which the codec is running. +-- hoistDecodeStep :: ( Functor n ) => (forall x . m x -> n x) + -- ^ a natural transformation -> DecodeStep bytes failure m a -> DecodeStep bytes failure n a hoistDecodeStep nat step = case step of @@ -232,9 +246,13 @@ hoistDecodeStep nat step = case step of DecodeFail fail_AvoidNameShadow -> DecodeFail fail_AvoidNameShadow DecodePartial k -> DecodePartial (fmap (hoistDecodeStep nat) . nat . k) + +-- | Modify failure type. +-- mapFailureDecodeStep :: Functor m => (failure -> failure') + -- ^ a function to apply to failure -> DecodeStep bytes failure m a -> DecodeStep bytes failure' m a mapFailureDecodeStep f step = case step of @@ -268,7 +286,9 @@ instance Exception CodecFailure -- runDecoder :: Monad m => [bytes] + -- ^ bytes to be fed into the incremental 'DecodeStep' -> DecodeStep bytes failure m a + -- ^ decoder -> m (Either failure a) runDecoder _ (DecodeDone x _trailing) = return (Right x) runDecoder _ (DecodeFail failure) = return (Left failure) @@ -281,8 +301,10 @@ runDecoder (b:bs) (DecodePartial k) = k (Just b) >>= runDecoder bs -- runDecoderPure :: Monad m => (forall b. m b -> b) + -- ^ run monad 'm' in a pure way, e.g. 'runIdentity' -> m (DecodeStep bytes failure m a) -> [bytes] + -- ^ input bytes -> Either failure a runDecoderPure runM decoder bs = runM (runDecoder bs =<< decoder) @@ -303,6 +325,7 @@ data AnyMessage ps where , ActiveState st ) => Message ps (st :: ps) (st' :: ps) + -- ^ 'Message' between some states -> AnyMessage ps @@ -342,8 +365,11 @@ prop_codecM , Eq (AnyMessage ps) ) => Codec ps failure m bytes + -- ^ codec -> AnyMessage ps + -- ^ some message -> m Bool + -- ^ returns 'True' iff round trip returns the exact same message prop_codecM Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do r <- decode stateToken >>= runDecoder [encode msg] case r :: Either failure (SomeMessage st) of @@ -377,7 +403,8 @@ prop_codec runM codec msg = prop_codec_splitsM :: forall ps failure m bytes. (Monad m, Eq (AnyMessage ps)) - => (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form + => (bytes -> [[bytes]]) + -- ^ alternative re-chunkings of serialised form -> Codec ps failure m bytes -> AnyMessage ps -> m Bool @@ -399,6 +426,7 @@ prop_codec_splits :: forall ps failure m bytes. (Monad m, Eq (AnyMessage ps)) => (bytes -> [[bytes]]) + -- ^ alternative re-chunkings of serialised form -> (forall a. m a -> a) -> Codec ps failure m bytes -> AnyMessage ps @@ -417,6 +445,7 @@ data SomeState (ps :: Type) where :: forall ps (st :: ps). ActiveState st => StateToken st + -- ^ state token for some active state 'st' -> SomeState ps -- | Binary compatibility of two protocols @@ -440,7 +469,7 @@ prop_codec_binary_compatM => Codec psA failure m bytes -> Codec psB failure m bytes -> (forall (stA :: psA). ActiveState stA => StateToken stA -> SomeState psB) - -- ^ The states of A map directly of states of B. + -- ^ the states of A map directly to states of B. -> AnyMessage psA -> m Bool prop_codec_binary_compatM @@ -475,6 +504,7 @@ prop_codec_binary_compat -> Codec psA failure m bytes -> Codec psB failure m bytes -> (forall (stA :: psA). StateToken stA -> SomeState psB) + -- ^ the states of A map directly to states of B. -> AnyMessage psA -> Bool prop_codec_binary_compat runM codecA codecB stokEq msgA = @@ -492,8 +522,11 @@ prop_codecs_compatM , forall a. Monoid a => Monoid (m a) ) => Codec ps failure m bytes + -- ^ first codec -> Codec ps failure m bytes + -- ^ second codec -> AnyMessage ps + -- ^ some message -> m Bool prop_codecs_compatM codecA codecB (AnyMessage (msg :: Message ps st st')) = diff --git a/typed-protocols/src/Network/TypedProtocol/Core.hs b/typed-protocols/src/Network/TypedProtocol/Core.hs index f9ba031f..e8314979 100644 --- a/typed-protocols/src/Network/TypedProtocol/Core.hs +++ b/typed-protocols/src/Network/TypedProtocol/Core.hs @@ -8,30 +8,34 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} --- need for 'Show' instance of 'ProtocolState' -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} + -- | This module defines the core of the typed protocol framework. -- module Network.TypedProtocol.Core ( -- * Introduction -- $intro + -- * Defining protocols -- $defining Protocol (..) , StateTokenI (..) -- $lemmas + -- * Engaging in protocols + -- ** PeerRole , PeerRole (..) , SingPeerRole (..) + -- ** Agency and its evidence + -- $agency , Agency (..) , SingAgency (..) , RelativeAgency (..) @@ -40,18 +44,24 @@ module Network.TypedProtocol.Core , WeHaveAgencyProof , TheyHaveAgencyProof , NobodyHasAgencyProof + -- *** FlipAgency , FlipAgency + -- *** ActiveState + , IsActiveState (..) + , ActiveState + , notActiveState + , ActiveAgency + , ActiveAgency' (..) + -- ** Pipelining + -- *** IsPipelined , IsPipelined (..) + -- *** Outstanding , Outstanding + -- *** N and Nat , N (..) , Nat (Succ, Zero) , natToInt , unsafeIntToNat - , ActiveAgency - , ActiveAgency' (..) - , IsActiveState (..) - , ActiveState - , notActiveState ) where import Data.Kind (Constraint, Type) @@ -105,7 +115,7 @@ import Data.Singletons -- -- The type class itself is indexed on a protocol \"tag\" type. This type -- does double duty as the /kind/ of the /types/ of the protocol states. - +-- -- We will use as a running example a simple \"ping\/pong\" protocol. (You can -- see the example in full in "Network.TypedProtocol.PingPong.Type".) In this -- example protocol the client sends a ping message and the serve must respond @@ -175,34 +185,30 @@ import Data.Singletons -- general for non-trivial protocols there may be several protocol states in -- each category. -- +-- Finally we need to point which singletons to use for the protocol states +-- +-- > -- still within the instance Protocol PingPong, 'SPingPong' type is what we define next. +-- > type StateToken = SPingPong +-- -- Furthermore we use singletons to provide term level reflection of type level -- states. One is required to provide singletons for all types of kind --- 'PingPong'. This is as simple as providing a GADT: +-- 'PingPong'. These definitions are provided outside of the 'Protocol' type +-- class. This is as simple as providing a GADT: -- -- > data SingPingPong (st :: PingPong) where -- > SingIdle :: SingPingPong StIdle -- > SingBusy :: SingPingPong StBusy -- > SingDone :: SingPingPong StDone -- --- together with 'Sing' and 'SingI' instances: +-- together with 'StateTokenI' instance (similar to 'SingI' from the +-- "singletons" package): -- --- > type instance Sing = SingPingPong --- > instance SingI StIdle where sing = SingIdle --- > instance SingI StBusy where sing = SingBusy --- > instance SingI StDone where sing = SingDone - --- $tests --- The mechanism for labelling each protocol state with the agency does not --- automatically prevent mislabelling, ie giving conflicting labels to a --- single state. It does in fact prevent forgetting to label states in the --- sense that it would not be possible to write protocol peers that make --- progress having entered these unlabelled states. +-- > instance StateTokenI StIdle where stateToken = SingIdle +-- > instance StateTokenI StBusy where stateToken = SingBusy +-- > instance StateTokenI StDone where stateToken = SingDone -- --- This partition property is however crucial for the framework's guarantees. --- The "Network.TypedProtocol.Proofs" module provides a way to guarantee for --- each protocol that this property is not violated. It also provides utilities --- helpful for testing protocols. - +-- This and other example protocols are provided in "typed-protocols-examples" +-- package. -- | Types for client and server peer roles. As protocol can be viewed from -- either client or server side. @@ -230,6 +236,16 @@ instance SingI AsClient where instance SingI AsServer where sing = SingAsServer +-- $agency +-- The protocols we consider either give agency to one side (one side can send +-- a message) or the protocol terminated. Agency is a (type-level) function of +-- the protocol state, and thus uniquely determined by it. +-- +-- The following types define the necessary type-level machinery and its +-- term-level evidence to provide type-safe API for `typed-protocols`. +-- Required proofs are hidden in an (unexposed) module +-- @Network.TypedProtocol.Lemmas@. + -- | A promoted data type which denotes three possible agencies a protocol -- state might be assigned. -- @@ -260,12 +276,16 @@ instance SingI NobodyAgency where sing = SingNobodyAgency -- | A promoted data type which indicates the effective agency (which is --- relative to current role). +-- relative to current role). It is computed by `Relative` type family. -- data RelativeAgency where + -- evidence that we have agency WeHaveAgency :: RelativeAgency + -- evidence that proof the remote side has agency TheyHaveAgency :: RelativeAgency + -- evidence of protocol termination NobodyHasAgency :: RelativeAgency +-- TODO: input-output-hk/typed-protocols#57 -- | Compute effective agency with respect to the peer role, for client role, @@ -285,6 +305,10 @@ type family Relative pr a where -- agency. It is isomorphic to a product of 'Agency' singleton and -- @r :~: r'@, where both @r@ and @r'@ have kind 'RelativeAgency'. -- +-- This is a proper type with values used by the 'Peer', however they are +-- hidden by using "Network.TypedProtocol.Peer.Client" and +-- "Network.TypedProtocol.Peer.Server" APIs. +-- type ReflRelativeAgency :: Agency -> RelativeAgency -> RelativeAgency -> Type data ReflRelativeAgency a r r' where ReflClientAgency :: ReflRelativeAgency ClientAgency r r @@ -331,50 +355,27 @@ type NobodyHasAgencyProof pr st = ReflRelativeAgency (StateAgency st) -- $lemmas -- --- The 'connect' proof rely on lemmas about the protocol. Specifically they --- rely on the property that each protocol state is labelled with the agency of --- one peer or the other, or neither, but never both. This property is true by --- construction, since we use a type family 'StateAgency' which maps states to --- agencies, however we still need an evince that cases where both peer have --- the agency or neither of them has it can be eliminated. --- --- The provided lemmas are structured as proofs by contradiction, e.g. stating --- \"if the client and the server have agency for this state then it leads to --- contradiction\". Contradiction is represented as the 'Void' type that has --- no values except ⊥. +-- The 'Network.TypedProtocol.connect' proof rely on lemmas about the +-- protocol. Specifically they rely on the property that each protocol state is +-- labelled with the agency of one peer or the other, or neither, but never +-- both. This property is true by construction, since we use a type family +-- 'StateAgency' which maps states to agencies, however we still need an evince +-- that cases where both peer have the agency or neither of them has it can be +-- eliminated. -- --- For example for the ping\/pong protocol, it has three states, and if we set --- up the labelling correctly we have: +-- The packages defines lemmas (in a hidden module) which are structured as +-- proofs by contradiction, e.g. stating \"if the client and the server have +-- agency for this state then it leads to contradiction\". Contradiction is +-- represented as the 'Void' type that has no values except ⊥. -- --- > data PingPong where --- > StIdle :: PingPong --- > StBusy :: PingPong --- > StDone :: PingPong --- > --- > instance Protocol PingPong where --- > data Message PingPong st st' where --- > MsgPing :: Message PingPong StIdle StBusy --- > MsgPong :: Message PingPong StBusy StIdle --- > MsgDone :: Message PingPong StIdle StDone --- > --- > data TokState PingPong st where --- > TokIdle :: TokState PingPong StIdle --- > TokBusy :: TokState PingPong StBusy --- > TokDone :: TokState PingPong StDone --- > --- > type StateAgency StIdle = ClientAgency --- > type StateAgency StBusy = ServerAgency --- > type StateAgency StDone = NobodyAgency --- --- The framework provides proofs which excludes that the client and server have --- agency at the same time. +-- The framework defines protocol-agnostic proofs (in the hidden module +-- `Network.TypedProtocol.Lemmas`) which excludes that the client and server +-- have agency at the same time. -- -- * 'exclusionLemma_ClientAndServerHaveAgency', -- * 'terminationLemma_1', -- * 'terminationLemma_2'. -- --- These lemmas are proven for all protocols. --- -- | A type class which hides a state token / singleton inside a class -- dictionary. @@ -390,19 +391,20 @@ class StateTokenI st where -- -- Each protocol consists of four components: -- --- * The protocol itself, which is also expected to be the kind of the types +-- * the protocol itself, which is also expected to be the kind of the types -- of the protocol states. The class is indexed on the protocol itself; -- * the protocol messages; -- * a type level map from the protocol states to agency: in each state either -- client or server or nobody has the agency. --- * a singleton type for the protocol states (e.g. `Sing` type family --- instance), together with 'SingI' instances. +-- * a singleton type for the protocol states (e.g. `StateToken` type family +-- instance), together with 'StateTokenI' instances. -- --- It is required provide 'Sing' type family instance as well as 'SingI' --- instances for all protocol states. These singletons allow one to pattern --- match on the state, which is useful when defining codecs, or providing --- informative error messages, however they are not necessary for proving --- correctness of the protocol. +-- It is required provide 'StateToken' type family instance as well as +-- 'StateTokenI' instances for all protocol states. These singletons allow one +-- to pattern match on the state, which is useful when defining codecs, or +-- providing informative error messages, however they are not necessary for +-- proving correctness of the protocol. These type families are similar to +-- 'Sing' and 'SingI' in the "singletons" package. -- class Protocol ps where @@ -426,18 +428,26 @@ class Protocol ps where type StateToken :: ps -> Type +-- | Evidence that one side of the protocol has the agency, and thus that the +-- protocol hasn't yet terminated. +-- type ActiveAgency' :: ps -> Agency -> Type data ActiveAgency' st agency where + -- | Evidence that the client has the agency. ClientHasAgency :: StateAgency st ~ ClientAgency => ActiveAgency' st ClientAgency + -- | Evidence that the server has the agency. ServerHasAgency :: StateAgency st ~ ServerAgency => ActiveAgency' st ServerAgency deriving instance Show (ActiveAgency' st agency) +-- | Evidence that the protocol isn't in a terminal state. +-- type ActiveAgency :: ps -> Type type ActiveAgency st = ActiveAgency' st (StateAgency st) + -- | A type class which restricts states to ones that have `ClientAgency` or -- `ServerAgency`, excluding `NobodyAgency`. -- @@ -455,6 +465,9 @@ instance ServerAgency ~ StateAgency st => IsActiveState st ServerAgency where activeAgency = ServerHasAgency +-- | A constraint which provides an evidence that the protocol isn't in +-- a terminal state. +-- type ActiveState :: ps -> Constraint type ActiveState st = IsActiveState st (StateAgency st) @@ -493,17 +506,18 @@ data N = Z | S N -- data IsPipelined where -- | Pipelined peer which is using `c :: Type` for collecting responses - -- from a pipelined messages. + -- from a pipelined messages. 'N' indicates depth of pipelining. Pipelined :: N -> Type -> IsPipelined -- | Non-pipelined peer. NonPipelined :: IsPipelined -- | Type level count of the number of outstanding pipelined yields for which --- we have not yet collected a receiver result. Used in 'PeerSender' to ensure --- 'SenderCollect' is only used when there are outstanding results to collect, --- and to ensure 'SenderYield', 'SenderAwait' and 'SenderDone' are only used --- when there are none. +-- we have not yet collected a receiver result. Used to +-- ensure that 'Collect' is only used when there are outstanding results to +-- collect (e.g. after 'YieldPipeliend' was used); +-- and to ensure that the non-pipelined primitives 'Yield', 'Await' and 'Done' +-- are only used when there are none unsatisfied pipelined requests. -- type Outstanding :: IsPipelined -> N type family Outstanding pl where @@ -515,7 +529,8 @@ type family Outstanding pl where -- -- This is often needed when writing pipelined peers to be able to count the -- number of outstanding pipelined yields, and show to the type checker that --- 'SenderCollect' and 'SenderDone' are being used correctly. +-- 'Network.TypedProtocol.Peer.Collect' and 'Network.TypedProtocol.Peer.Done' +-- are being used correctly. -- newtype Nat (n :: N) = UnsafeInt Int deriving Show via Int diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index c94dbb2f..23c849fe 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -37,27 +37,30 @@ import Control.Monad.Class.MonadSTM -- $intro -- -- A 'Peer' is a particular implementation of an agent that engages in a --- typed protocol. To actually run one we need a source and sink for the typed --- protocol messages. These are provided by a 'Channel' and a 'Codec'. The --- 'Channel' represents one end of an untyped duplex message transport, and --- the 'Codec' handles conversion between the typed protocol messages and --- the untyped channel. +-- typed protocol. To actually run one we need an untyped channel representing +-- one end of an untyped duplex message transport, which allows to send and +-- receive bytes. One will also need a 'Codec' which handles conversion +-- between the typed protocol messages and the untyped channel. -- --- So given the 'Peer' and a compatible 'Codec' and 'Channel' we can run the --- peer in some appropriate monad. The peer and codec have to agree on --- the same protocol and role in that protocol. The codec and channel have to --- agree on the same untyped medium, e.g. text or bytes. All three have to --- agree on the same monad in which they will run. +-- Given the 'Peer', a compatible 'Network.TypedProtocol.Codec.Codec' and +-- an untyped channel we can run the peer in some appropriate monad (e.g. 'IO', +-- or a simulation monad for testing purposes). The peer and codec have to +-- agree on the same protocol. The codec and channel have to agree on the same +-- untyped medium, e.g. text or bytes. All three have to agree on the same +-- monad in which they will run. -- -- This module provides drivers for normal and pipelined peers. There is -- very little policy involved here so typically it should be possible to -- use these drivers, and customise things by adjusting the peer, or codec --- or channel. +-- or channel (together with an implementation of a 'Driver' based on it). -- --- It is of course possible to write custom drivers and the code for these ones --- may provide a useful starting point. The 'runDecoder' function may be a --- helpful utility for use in custom drives. +-- For implementing a 'Driver' based on some untyped channel, the +-- 'Network.TypedProtocol.Codec.runDecoder' function may be a helpful utility. -- +-- For a possible definition of an untyped channel and how to construct +-- a `Driver` from it see @typed-protocols-examples@ package. For production +-- grade examples see https://github.com/IntersectMBO/ouroboros-network +-- repository. -- @@ -66,23 +69,37 @@ import Control.Monad.Class.MonadSTM data Driver ps (pr :: PeerRole) dstate m = Driver { + -- | Send a message; the message must transition from an active state. + -- One needs to supply agency evidence. sendMessage :: forall (st :: ps) (st' :: ps). StateTokenI st => StateTokenI st' => ActiveState st => WeHaveAgencyProof pr st + -- agency evidence -> Message ps st st' + -- message to send -> m () + -- | Receive some message, since we don't know the final state of + -- the protocol it is wrapped in `SomeMessage` type; the message must + -- transition from an active state. One needs to supply agency + -- evidence. + -- , recvMessage :: forall (st :: ps). StateTokenI st => ActiveState st => TheyHaveAgencyProof pr st + -- agency evidence -> dstate + -- current driver state -> m (SomeMessage st, dstate) + -- received message together with new driver state - , initialDState :: dstate + , -- | Initial state of the driver + initialDState :: dstate } +-- TODO: input-output-hk/typed-protocols#57 -- | When decoding a 'Message' we only know the expected \"from\" state. We diff --git a/typed-protocols/src/Network/TypedProtocol/Lemmas.hs b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs index a17fe88e..20bc5f0a 100644 --- a/typed-protocols/src/Network/TypedProtocol/Lemmas.hs +++ b/typed-protocols/src/Network/TypedProtocol/Lemmas.hs @@ -20,6 +20,24 @@ import Data.Kind (Type) import Network.TypedProtocol.Core +-- $about +-- +-- Typed languages such as Haskell can embed proofs. In total languages this +-- is straightforward: a value inhabiting a type is a proof of the property +-- corresponding to the type. +-- +-- In languages like Haskell that have ⊥ as a value of every type, things +-- are slightly more complicated. We have to demonstrate that the value that +-- inhabits the type of interest is not ⊥ which we can do by evaluation. +-- +-- This idea crops up frequently in advanced type level programming in Haskell. +-- For example @Refl@ proofs that two types are equal have to have a runtime +-- representation that is evaluated to demonstrate it is not ⊥ before it +-- can be relied upon. +-- +-- The proofs here are about the nature of typed protocols in this framework. +-- The 'connect' and 'connectPipelined' proofs rely on a few internal lemmas. + -- | An evidence that both relative agencies are equal to 'NobodyHasAgency'. -- type ReflNobodyHasAgency :: RelativeAgency -> RelativeAgency -> Type @@ -38,9 +56,14 @@ exclusionLemma_ClientAndServerHaveAgency (ra :: RelativeAgency). SingPeerRole pr -> ReflRelativeAgency a ra (Relative pr a) + -- ^ evidence that `ra` is equal to `Relative pr a`, e.g. that client has + -- agency -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) + -- ^ evidence that `ra` is equal to `Relative (FlipAgency pr) a`, e.g. that + -- the server has agency -> ReflNobodyHasAgency (Relative pr a) (Relative (FlipAgency pr) a) + -- ^ derived evidence that nobody has agency in that case exclusionLemma_ClientAndServerHaveAgency SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency exclusionLemma_ClientAndServerHaveAgency diff --git a/typed-protocols/src/Network/TypedProtocol/Peer.hs b/typed-protocols/src/Network/TypedProtocol/Peer.hs index fce1ca78..1f1097c1 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer.hs @@ -11,10 +11,6 @@ -- | Protocol EDSL. -- --- __Note__: 'Network.TypedProtocol.Peer.Client.Client' and --- 'Network.TypedProtocol.Peer.Server.Server' patterns are easier to use, --- however this module provides in-depth documentation. --- module Network.TypedProtocol.Peer ( Peer (..) , PeerPipelined (..) @@ -32,6 +28,10 @@ import Network.TypedProtocol.Core as Core -- | A description of a peer that engages in a protocol. -- +-- __Note__: You should use pattern synonyms exposed in +-- "Network.TypedProtocol.Peer.Client" and "Network.TypedProtocol.Peer.Server", +-- however here we provide in-depth documentation. +-- -- The protocol describes what messages peers /may/ send or /must/ accept. -- A particular peer implementation decides what to actually do within the -- constraints of the protocol. @@ -44,21 +44,19 @@ import Network.TypedProtocol.Core as Core -- -- * the protocol itself; -- * the client\/server role; --- * whether the peer is using pipelining or not; --- * the type level queue of future transitions not yet performed due to --- pipelining; +-- * whether the peer is using pipelining or not, if pipelined it holds the +-- depth of pipelining and a type used to collect data from pipelined +-- transitions; -- * the current protocol state; -- * the monad in which the peer operates (e.g. 'IO'); --- * the stm monad, (e.g. 'STM' or it can be left abstract if 'CollectSTM' is --- not used); -- * the type of the final result once the peer terminates. -- -- For example: -- --- > pingPongClientExample :: Int -> Peer PingPong AsClient Pipelined Empty StIdle IO STM () --- > pingPongServerExample :: Peer PingPong AsServer NonPipeliend Empty StIdle IO stm Int +-- > pingPongClientExample :: Peer PingPong AsClient (Pipelined Z Int) StIdle IO () +-- > pingPongServerExample :: Peer PingPong AsServer NonPipeliend StIdle IO Int -- --- The actions that a non pipelining peer can take are: +-- The actions that a non-pipelining peer can take are: -- -- * to perform local monadic effects -- * to terminate with a result (but only in a terminal protocol state) @@ -69,25 +67,17 @@ import Network.TypedProtocol.Core as Core -- In addition a pipelining peer can: -- -- * pipeline a message, which requires upfront declaration at which state we --- are continue. This pushes the skipped transition to the back of the --- pipelining queue. --- * collect a response, which removes a transition from the front of the --- queue. It's worth to notice that this modifies the first element in the --- queue, in particular it does not changes the queue length. --- If there's no reply yet, collect allows to either block or continue, --- possibly pipelining more messages. --- * collect an identity transition (which removes the first element from the --- queue). --- * race between receiving a response and an stm transaction returning --- a continuation. +-- continue at and passing a receiver which will run in parallel. When +-- receiver terminates it pushes the result into the pipelining queue. +-- * collect a response from the pipelining queue. -- -- The 'Yield', 'Await', 'Done', 'YieldPipelined', 'Collect', -- constructors require to provide an evidence that the -- peer has agency in the current state. The types guarantee that it is not --- possible to supply incorrect evidence, however you should use --- 'Network.TypedProtocol.Peer.Client.Client' and --- 'Network.TypedProtocol.Peer.Client.Server' pattern synonyms which provide --- this evidence for you. +-- possible to supply incorrect evidence, however the +-- pattern synonyms exposed in "Network.TypedProtocol.Peer.Client" and +-- "Network.TypedProtocol.Peer.Client" supply this evidence for you, and hence +-- are easier to use and let you avoid some kinds of type errors. -- type Peer :: forall ps -> PeerRole @@ -192,9 +182,9 @@ data Peer ps pr pl st m a where -- Pipelining primitives -- - -- | Pipelined send which. Note that the continuation decides from which - -- state we pipeline next message, and the gap is pushed at the back of - -- the queue. + -- | Pipelined send. We statically decide from which state we continue (the + -- `st''` state here), the gap (between `st'` and `st''`) must be fulfilled + -- by 'Receiver' which runs will run in parallel. -- YieldPipelined :: forall ps pr (st :: ps) (st' :: ps) c n st'' m a. @@ -207,11 +197,13 @@ data Peer ps pr pl st m a where -> Message ps st st' -- ^ protocol message -> Receiver ps pr st' st'' m c + -- ^ receiver -> Peer ps pr (Pipelined (S n) c) st'' m a - -- ^ continuation + -- ^ continuation from state `st''` -> Peer ps pr (Pipelined n c) st m a - -- | Partially collect promised transition. + -- | Collect results returned by a `Receiver`. Results are collected in the + -- first-in-first-out way. -- Collect :: forall ps pr c n st m a. @@ -228,12 +220,13 @@ deriving instance Functor m => Functor (Peer ps pr pl st m) -- | Receiver. It is limited to only awaiting for messages and running monadic --- computations. This means that on can only pipeline messages if they can be +-- computations. This means that one can only pipeline messages if they can be -- connected by state transitions which all have remote agency. -- -- The receiver runs in parallel, see `runPipelinedPeerWithDriver`. This makes -- pipelining quite effective, since the receiver callbacks are called in --- a separate thread which can effectively use CPU cache. +-- a separate thread which can effectively use CPU cache and can avoids +-- unnecessary context switches. -- type Receiver :: forall ps -> PeerRole @@ -271,6 +264,10 @@ deriving instance Functor m => Functor (Receiver ps pr st stdone m) -- | A description of a peer that engages in a protocol in a pipelined fashion. -- +-- This type is useful for wrapping pipelined peers to hide information which +-- is only relevant in peer lift. It is expected by +-- `Network.TypedProtocol.Driver.runPeerPipelinedWithDriver`. +-- data PeerPipelined ps pr (st :: ps) m a where PeerPipelined :: { runPeerPipelined :: Peer ps pr (Pipelined Z c) st m a } -> PeerPipelined ps pr st m a diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs index 1876a530..60c355c4 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Client.hs @@ -8,23 +8,26 @@ {-# LANGUAGE TypeOperators #-} -- | Bidirectional patterns for @'Peer' ps 'AsClient'@. The advantage of --- these patterns is that they automatically provide the 'RelativeAgencyEq' --- singleton. +-- these patterns is that they automatically provide the 'ReflRelativeAgency' +-- evidence. -- module Network.TypedProtocol.Peer.Client - ( Client - , ClientPipelined - , TP.PeerPipelined (ClientPipelined, runClientPipelined) + ( -- * Client type alias and its pattern synonyms + Client , pattern Effect , pattern Yield , pattern Await , pattern Done , pattern YieldPipelined , pattern Collect + -- * Receiver type alias and its pattern synonyms , Receiver , pattern ReceiverEffect , pattern ReceiverAwait , pattern ReceiverDone + -- * ClientPipelined type alias and its pattern synonym + , ClientPipelined + , TP.PeerPipelined (ClientPipelined, runClientPipelined) -- * re-exports , IsPipelined (..) , Outstanding diff --git a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs index 468dae3c..025fbf3f 100644 --- a/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs +++ b/typed-protocols/src/Network/TypedProtocol/Peer/Server.hs @@ -8,23 +8,26 @@ {-# LANGUAGE TypeOperators #-} -- | Bidirectional patterns for @'Peer' ps 'AsServer'@. The advantage of --- these patterns is that they automatically provide the 'RelativeAgencyEq' --- singleton. +-- these patterns is that they automatically provide the 'ReflRelativeAgency' +-- evidence. -- module Network.TypedProtocol.Peer.Server - ( Server - , ServerPipelined - , TP.PeerPipelined (ServerPipelined, runServerPipelined) + ( -- * Server type alias and its pattern synonyms + Server , pattern Effect , pattern Yield , pattern Await , pattern Done , pattern YieldPipelined , pattern Collect + -- * Receiver type alias and its pattern synonyms , Receiver , pattern ReceiverEffect , pattern ReceiverAwait , pattern ReceiverDone + -- * ServerPipelined type alias and its pattern synonym + , ServerPipelined + , TP.PeerPipelined (ServerPipelined, runServerPipelined) -- * re-exports , IsPipelined (..) , Outstanding diff --git a/typed-protocols/src/Network/TypedProtocol/Proofs.hs b/typed-protocols/src/Network/TypedProtocol/Proofs.hs index 67dbfd43..69125573 100644 --- a/typed-protocols/src/Network/TypedProtocol/Proofs.hs +++ b/typed-protocols/src/Network/TypedProtocol/Proofs.hs @@ -9,20 +9,15 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} - -- This is already implied by the -Wall in the .cabal file, but lets just be -- completely explicit about it too, since we rely on the completeness -- checking in the cases below for the completeness of our proofs. {-# OPTIONS_GHC -Wincomplete-patterns #-} --- | Proofs about the typed protocol framework. --- --- It also provides helpful testing utilities. +-- | Proofs and helpful testing utilities. -- module Network.TypedProtocol.Proofs - ( -- * About these proofs - -- $about - -- * Connect proof + ( -- * Connect proofs connect , connectPipelined , TerminalStates (..) @@ -42,27 +37,6 @@ import Network.TypedProtocol.Core import Network.TypedProtocol.Lemmas import Network.TypedProtocol.Peer --- $about --- --- Typed languages such as Haskell can embed proofs. In total languages this --- is straightforward: a value inhabiting a type is a proof of the property --- corresponding to the type. --- --- In languages like Haskell that have ⊥ as a value of every type, things --- are slightly more complicated. We have to demonstrate that the value that --- inhabits the type of interest is not ⊥ which we can do by evaluation. --- --- This idea crops up frequently in advanced type level programming in Haskell. --- For example @Refl@ proofs that two types are equal have to have a runtime --- representation that is evaluated to demonstrate it is not ⊥ before it --- can be relied upon. --- --- The proofs here are about the nature of typed protocols in this framework. --- The 'connect' and 'connectPipelined' proofs rely on a few lemmas about --- the individual protocol. See 'AgencyProofs'. - - - -- | The 'connect' function takes two peers that agree on a protocol and runs -- them in lock step, until (and if) they complete. @@ -82,8 +56,11 @@ connect :: forall ps (pr :: PeerRole) (initSt :: ps) m a b. (Monad m, SingI pr) => Peer ps pr NonPipelined initSt m a + -- ^ a peer -> Peer ps (FlipAgency pr) NonPipelined initSt m b + -- ^ a peer with flipped agency -> m (a, b, TerminalStates ps) + -- ^ peers results and an evidence of their termination connect = go where singPeerRole :: Sing pr @@ -140,7 +117,9 @@ data TerminalStates ps where :: forall ps (st :: ps). (StateAgency st ~ NobodyAgency) => StateToken st + -- ^ state termination evidence for the first peer -> StateToken st + -- ^ state termination evidence for the second peer -> TerminalStates ps -- @@ -164,7 +143,7 @@ enqueue a EmptyQ = ConsQ a EmptyQ enqueue a (ConsQ b q) = ConsQ b (enqueue a q) --- | Prove that we have a total conversion from pipelined peers to regular +-- | Proof that we have a total conversion from pipelined peers to regular -- peers. This is a sanity property that shows that pipelining did not give -- us extra expressiveness or to break the protocol state machine. -- @@ -172,13 +151,10 @@ forgetPipelined :: forall ps (pr :: PeerRole) (st :: ps) m a. Functor m => [Bool] - -- ^ interleaving choices for pipelining allowed by - -- `Collect` and `CollectSTM` primitive. False values or `[]` give no - -- pipelining. For the 'CollectSTM' primitive, the stm action must not - -- block otherwise even if the choice is to pipeline more (a 'True' value), - -- we'll actually collect a result. - -> PeerPipelined ps pr st m a - -> Peer ps pr NonPipelined st m a + -- ^ interleaving choices for pipelining allowed by `Collect` primitive. False + -- values or `[]` give no pipelining. + -> PeerPipelined ps pr st m a + -> Peer ps pr NonPipelined st m a forgetPipelined cs0 (PeerPipelined peer) = goSender EmptyQ cs0 peer where goSender :: forall st' n c. @@ -214,14 +190,13 @@ forgetPipelined cs0 (PeerPipelined peer) = goSender EmptyQ cs0 peer -- -- >>> forgetPipelined . promoteToPipelined = id -- --- This function is useful to test a pipelined peer against a non-pipelined one --- using `connectPipelined` function. --- promoteToPipelined :: forall ps (pr :: PeerRole) st m a. Functor m - => Peer ps pr NonPipelined st m a - -> PeerPipelined ps pr st m a + => Peer ps pr NonPipelined st m a + -- ^ a peer + -> PeerPipelined ps pr st m a + -- ^ a pipelined peer promoteToPipelined p = PeerPipelined (go p) where go :: forall st' c. @@ -248,9 +223,13 @@ connectPipelined (st :: ps) m a b. (Monad m, SingI pr) => [Bool] + -- ^ an interleaving -> PeerPipelined ps pr st m a + -- ^ a pipelined peer -> Peer ps (FlipAgency pr) NonPipelined st m b + -- ^ a non-pipelined peer with fliped agency -> m (a, b, TerminalStates ps) + -- ^ peers results and an evidence of their termination connectPipelined csA a b = connect (forgetPipelined csA a) b From bdcf30a43caaf65545ab5a221fea0116e8f29be9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 23 Aug 2024 16:54:40 +0200 Subject: [PATCH 36/39] Core module cannot be checked with stylish-haskell This is because stylish-parser cannot parse the export list which starts with ```hs module Network.TypedProtocol.Core ( -- * Introduction -- $intro -- * Defining protocols -- $defining Protocol (..) ``` But this is required by haddock, to include the next section. --- scripts/check-stylish.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/check-stylish.sh b/scripts/check-stylish.sh index 897adc8e..a90a801e 100755 --- a/scripts/check-stylish.sh +++ b/scripts/check-stylish.sh @@ -5,6 +5,6 @@ export LC_ALL=C.UTF-8 [[ -x '/usr/bin/fd' ]] && FD="fd" || FD="fdfind" -$FD . './typed-protocols' -e hs -E Setup.hs -X stylish-haskell -c .stylish-haskell.yaml -i +$FD . './typed-protocols' -e hs -E Setup.hs -E Core.hs -X stylish-haskell -c .stylish-haskell.yaml -i $FD . './typed-protocols-cborg' -e hs -E Setup.hs -X stylish-haskell -c .stylish-haskell.yaml -i $FD . './typed-protocols-examples' -e hs -E Setup.hs -E Channel.hs -X stylish-haskell -c .stylish-haskell.yaml -i From 0042b72a5519bc9cb925fab5b533f841fd07ed21 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 4 Sep 2024 13:00:11 +0200 Subject: [PATCH 37/39] Removed Stateful PingPong example --- .../TypedProtocol/Stateful/PingPong/Client.hs | 51 ------------------- .../typed-protocols-examples.cabal | 1 - 2 files changed, 52 deletions(-) delete mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs deleted file mode 100644 index c56e364c..00000000 --- a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/PingPong/Client.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Network.TypedProtocol.Stateful.PingPong.Client - ( -- * Non-pipelined peer - PingPongClient (..) - , pingPongClientPeer - ) where - -import Data.Kind (Type) - -import Network.TypedProtocol.PingPong.Type -import Network.TypedProtocol.Stateful.Peer.Client - - -data PingPongClient (f :: PingPong -> Type) m a where - -- | Choose to go for sending a ping message. The ping has no body so - -- all we have to provide here is a continuation for the single legal - -- reply message. - -- - SendMsgPing :: f StBusy - -> m (PingPongClient f m a) -- continuation for Pong response - -> PingPongClient f m a - - -- | Choose to terminate the protocol. This is an actual but nullary message, - -- we terminate with the local result value. So this ends up being much like - -- 'return' in this case, but in general the termination is a message that - -- can communicate final information. - -- - SendMsgDone :: f StDone -> a -> PingPongClient f m a - - -pingPongClientPeer - :: Functor m - => (f StBusy -> f StIdle) - -> PingPongClient f m a - -> Client PingPong StIdle f m (a, f StDone) - -pingPongClientPeer _busytoIdle (SendMsgDone f result) = - Yield f MsgDone (Done (result, f)) - -pingPongClientPeer busyToIdle (SendMsgPing f next) = - Yield f MsgPing $ - Await $ \f' MsgPong -> - ( Effect $ pingPongClientPeer busyToIdle <$> next - , busyToIdle f' - ) diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 3bed5292..3a717155 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -38,7 +38,6 @@ library , Network.TypedProtocol.ReqResp2.Type , Network.TypedProtocol.ReqResp2.Client - , Network.TypedProtocol.Stateful.PingPong.Client , Network.TypedProtocol.Stateful.ReqResp.Client , Network.TypedProtocol.Stateful.ReqResp.Examples From b195c921250444399522980bf086010af47018cc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 5 Sep 2024 05:53:23 +0200 Subject: [PATCH 38/39] Stateful RPC example --- .../Network/TypedProtocol/ReqResp/Codec.hs | 6 +- .../TypedProtocol/Stateful/ReqResp/Client.hs | 58 ++++----- .../TypedProtocol/Stateful/ReqResp/Codec.hs | 114 ++++++++++++++++++ .../Stateful/ReqResp/Examples.hs | 59 ++++----- .../TypedProtocol/Stateful/ReqResp/Server.hs | 36 ++++++ .../TypedProtocol/Stateful/ReqResp/Type.hs | 101 ++++++++++++++++ .../typed-protocols-examples.cabal | 3 + 7 files changed, 302 insertions(+), 75 deletions(-) create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs create mode 100644 typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Type.hs diff --git a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs index 95e77c27..9152de55 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs @@ -39,12 +39,12 @@ codecReqResp = decodeTerminatedFrame '\n' $ \str trailing -> case (stok, break (==' ') str) of (SingIdle, ("MsgReq", str')) - | Just resp <- readMaybe str' - -> DecodeDone (SomeMessage (MsgReq resp)) trailing + | Just req <- readMaybe str' + -> DecodeDone (SomeMessage (MsgReq req)) trailing (SingIdle, ("MsgDone", "")) -> DecodeDone (SomeMessage MsgDone) trailing (SingBusy, ("MsgResp", str')) - | Just resp <- readMaybe str' + | Just resp <- readMaybe str' -> DecodeDone (SomeMessage (MsgResp resp)) trailing (_ , _ ) -> DecodeFail failure diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs index 505daaed..31ca125c 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs @@ -1,52 +1,42 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} module Network.TypedProtocol.Stateful.ReqResp.Client - ( -- * Non-Pipelined Client - ReqRespClient (..) + ( ReqRespClient (..) , reqRespClientPeer ) where -import Data.Kind (Type) - -import Network.TypedProtocol.ReqResp.Type +import Data.Typeable import Network.TypedProtocol.Stateful.Peer.Client +import Network.TypedProtocol.Stateful.ReqResp.Type +data ReqRespClient req m a where + SendMsgReq :: Typeable resp + => req resp + -> (resp -> m (ReqRespClient req m a)) + -> ReqRespClient req m a -data ReqRespClient req resp (f :: ReqResp req resp -> Type) m a where - SendMsgReq :: f StBusy - -> req - -> (f StBusy -> resp -> ( m (ReqRespClient req resp f m a) - , f StIdle - )) - -> ReqRespClient req resp f m a - - SendMsgDone :: f StDone - -> m a - -> ReqRespClient req resp f m a + SendMsgDone :: a + -> ReqRespClient req m a reqRespClientPeer :: Monad m - => ReqRespClient req resp f m a - -> Client (ReqResp req resp) StIdle f m a - -reqRespClientPeer (SendMsgDone f result) = - Effect $ do - r <- result - return $ Yield f MsgDone (Done r) - -reqRespClientPeer (SendMsgReq f req next) = - Yield f (MsgReq req) $ - Await $ \f' (MsgResp resp) -> - case next f' resp of - (client, f'') -> - ( Effect $ reqRespClientPeer <$> client - , f'' - ) + => ReqRespClient req m a + -> Client (ReqResp req) StIdle State m a + +reqRespClientPeer (SendMsgDone a) = + Yield StateDone MsgDone (Done a) + +reqRespClientPeer (SendMsgReq req next) = + Yield (StateBusy req) + (MsgReq req) $ + Await $ \_ (MsgResp resp) -> + let client = next resp + in ( Effect $ reqRespClientPeer <$> client + , StateIdle + ) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs new file mode 100644 index 00000000..f78991a9 --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Network.TypedProtocol.Stateful.ReqResp.Codec where + +import Data.Kind (Type) +import Data.Singletons.Decide +import Data.Typeable +import Network.TypedProtocol.Core +import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) +import Network.TypedProtocol.Stateful.Codec +import Network.TypedProtocol.Stateful.ReqResp.Type + +data Some (f :: k -> Type) where + Some :: Typeable a => f a -> Some f + + +-- | Codec polymorphic in the RPC (e.g. `req` type) +-- +codecReqResp + :: forall req m. Monad m + => (forall resp. req resp -> String) + -- ^ encode `req resp` + -> (String -> Maybe (Some req)) + -- ^ decode `req resp` + -> (forall resp. resp -> String) + -- ^ encode resp + -> (forall resp. req resp -> String -> Maybe resp) + -- ^ decode resp + -> Codec (ReqResp req) CodecFailure State m String +codecReqResp encodeReq decodeReq encodeResp decodeResp = + Codec { encode, decode } + where + encode :: State st' + -> Message (ReqResp req) st st' + -> String + encode _ (MsgReq req) = "MsgReq " ++ encodeReq req ++ "\n" + encode _ MsgDone = "MsgDone\n" + encode _ (MsgResp resp) = "MsgResp " ++ encodeResp resp ++ "\n" + + decode :: forall (st :: ReqResp req). + ActiveState st + => StateToken st + -> State st + -> m (DecodeStep String CodecFailure m (SomeMessage st)) + decode stok state = + decodeTerminatedFrame '\n' $ \str trailing -> + case (stok, state, break (==' ') str) of + (SingIdle, StateIdle, ("MsgReq", str')) + | Just (Some req) <- decodeReq str' + -> DecodeDone (SomeMessage (MsgReq req)) trailing + (SingIdle, StateIdle, ("MsgDone", "")) + -> DecodeDone (SomeMessage MsgDone) trailing + (SingBusy, StateBusy req, ("MsgResp", str')) + -- note that we need `req` to decode response of the given type + | Just resp <- decodeResp req str' + -> DecodeDone (SomeMessage (MsgResp resp)) trailing + (_, _, _) -> DecodeFail failure + where failure = CodecFailure ("unexpected server message: " ++ str) + + +data Bytes where + Bytes :: Message (ReqResp FileAPI) st st' -> Bytes + +-- | An identity codec which wraps messages into `AnyMessage`. +-- +codecReqRespId + :: forall m. + Applicative m + => (forall (res1 :: Type) (res2 :: Type). + (Typeable res1, Typeable res2) + => Proxy res1 + -> Proxy res2 + -> Maybe (res1 :~: res2) + ) + -> Codec FileRPC String State m Bytes +codecReqRespId eqRespTypes = Codec { encode, decode } + where + encode _ = Bytes + + decode :: forall (st :: ReqResp FileAPI). + ActiveState st + => StateToken st + -> State st + -> m (DecodeStep Bytes String m (SomeMessage st)) + decode stok state = pure $ DecodePartial $ \bytes -> pure $ + case (stok, state, bytes) of + (SingIdle, StateIdle, Just (Bytes msg@MsgDone)) + -> DecodeDone (SomeMessage msg) Nothing + (SingIdle, StateIdle, Just (Bytes msg@MsgReq{})) + -> DecodeDone (SomeMessage msg) Nothing + (SingBusy, StateBusy req, Just (Bytes msg@(MsgResp _))) + -- the codec needs to verify that response type of `req` and `msg` agrees + | Just Refl <- eqRespTypes (reqRespType req) (msgRespType msg) + -> DecodeDone (SomeMessage msg) Nothing + + (SingDone, _, _) -> notActiveState stok + (_, _, Nothing) -> DecodeFail "no bytes" + (_, _, _) -> DecodeFail "no matching message" + + msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle + -> Proxy resp + msgRespType (MsgResp _) = Proxy + + reqRespType :: forall resp. FileAPI resp -> Proxy resp + reqRespType _ = Proxy + + diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs index 72556c02..7827e5a8 100644 --- a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs @@ -2,49 +2,32 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Network.TypedProtocol.Stateful.ReqResp.Examples - ( ReqRespStateCallbacks (..) - , reqRespClientMap - ) where +module Network.TypedProtocol.Stateful.ReqResp.Examples where -import Data.Kind (Type) +import Network.TypedProtocol.Stateful.ReqResp.Server +import Network.TypedProtocol.Stateful.ReqResp.Type -import Network.TypedProtocol.ReqResp.Type -import Network.TypedProtocol.Stateful.ReqResp.Client +fileRPCServer :: Monad m + => (forall resp. FileAPI resp -> m resp) + -- ^ execute `FileAPI` locally + -> ReqRespServer FileAPI m () +fileRPCServer run = ReqRespServer { + reqRespServerDone = (), + reqRespHandleReq = \req -> do + resp <- run req + return (resp, fileRPCServer run) + } -data ReqRespStateCallbacks (f :: ReqResp req resp -> Type) = - ReqRespStateCallbacks { - rrBusyToIdle :: f StBusy -> f StIdle - , rrBusyToBusy :: f StBusy -> f StBusy - , rrBusyToDone :: f StBusy -> f StDone - } +-- | Example of a file API +-- +simpleFileAPI :: Monad m => FileAPI resp -> m resp +simpleFileAPI (ReadFile filepath) = return filepath +simpleFileAPI (WriteFile _ _) = return () -reqRespClientMap - :: forall req resp f m. - Monad m - => ReqRespStateCallbacks f - -> f StBusy - -> [req] - -> ReqRespClient req resp f m ([resp], f StDone) -reqRespClientMap ReqRespStateCallbacks - { rrBusyToIdle - , rrBusyToBusy - , rrBusyToDone - } = go [] - where - go :: [resp] - -> f StBusy - -> [req] - -> ReqRespClient req resp f m ([resp], f StDone) - go resps f [] = SendMsgDone f' (pure (reverse resps, f')) - where - f' = rrBusyToDone f - go resps f (req:reqs) = - SendMsgReq f req $ \f' resp -> - ( return (go (resp:resps) (rrBusyToBusy f') reqs) - , rrBusyToIdle f' - ) +simpleFileRPCServer :: Monad m => ReqRespServer FileAPI m () +simpleFileRPCServer = fileRPCServer simpleFileAPI diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs new file mode 100644 index 00000000..2898b6f1 --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.TypedProtocol.Stateful.ReqResp.Server + ( ReqRespServer (..) + , reqRespServerPeer + ) where + +import Data.Typeable +import Network.TypedProtocol.Stateful.Peer.Server +import Network.TypedProtocol.Stateful.ReqResp.Type + + +data ReqRespServer req m a = ReqRespServer { + reqRespServerDone :: a, + reqRespHandleReq :: forall resp. Typeable resp => req resp -> m (resp, ReqRespServer req m a) + } + +reqRespServerPeer :: Functor m + => ReqRespServer req m a + -> Server (ReqResp req) StIdle State m a +reqRespServerPeer ReqRespServer { reqRespServerDone = a, + reqRespHandleReq = k } = + Await $ \_ -> \case + MsgDone -> (Done a, StateDone) + MsgReq req -> + ( Effect $ + (\(resp, k') -> Yield StateIdle (MsgResp resp) (reqRespServerPeer k')) + <$> k req + , StateBusy req + ) diff --git a/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Type.hs b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Type.hs new file mode 100644 index 00000000..bcc25153 --- /dev/null +++ b/typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Type.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + + +-- | An RPC protocol which in which request type determines respond time. +-- Unlike in the `Network.TypedProtocol.ReqResp.Type` where `req` and `resp` +-- types where statically defined, here the respond type is dynamically +-- determined by the type of request. +-- +module Network.TypedProtocol.Stateful.ReqResp.Type where + +import Data.Kind (Type) +import Data.Typeable +import Network.TypedProtocol.Core + + +type ReqResp :: (Type -> Type) -> Type +data ReqResp req where + StIdle :: ReqResp req + StBusy :: res + -> ReqResp req + StDone :: ReqResp req + +type SReqResp :: ReqResp req -> Type +data SReqResp st where + SingIdle :: SReqResp StIdle + SingBusy :: SReqResp (StBusy res :: ReqResp req) + SingDone :: SReqResp StDone + +deriving instance Show (SReqResp st) + +instance StateTokenI StIdle where stateToken = SingIdle +instance StateTokenI (StBusy res) where stateToken = SingBusy +instance StateTokenI StDone where stateToken = SingDone + + +instance Protocol (ReqResp req) where + + -- Messages for the `ReqResp` protocol. + -- + -- Typeable constraint is used to support + -- `Network.TypeProtocol.Stateful.ReqResp.Codec.codecReqRespId' - an + -- efficient encoder / decoder useful for testing purposes. + -- + data Message (ReqResp req) from to where + MsgReq :: Typeable resp + => req resp -- ^ request which expects `resp` as a result, `resp` is + -- promoted to the state `StBusy` state. + -> Message (ReqResp req) StIdle (StBusy resp) + MsgResp :: Typeable resp + => resp -- ^ respond type + -> Message (ReqResp req) (StBusy resp) StIdle + MsgDone :: Message (ReqResp req) StIdle StDone + + type StateAgency StIdle = ClientAgency + type StateAgency (StBusy _) = ServerAgency + type StateAgency StDone = NobodyAgency + + type StateToken = SReqResp + + +-- deriving instance Show req +-- => Show (Message (ReqResp req) from to) +-- +-- deriving instance Eq req +-- => Eq (Message (ReqResp req) from to) + +type State :: ReqResp req -> Type +data State st where + StateIdle :: State StIdle + -- fancy type signature is needed to help GHC infer that when pattern + -- matching on `StateBusy resp` then `resp :: Type` + StateBusy :: forall (req :: Type -> Type) + (result :: Type). + Typeable result + => req result + -> State (StBusy result :: ReqResp req) + StateDone :: State StDone + +-- +-- A simple example RPC +-- + +-- | An example RPC, e.g. the `req` type. +-- +type FileAPI :: Type -> Type +data FileAPI result where + ReadFile :: FilePath -> FileAPI String + -- read a file + + WriteFile :: FilePath -> String -> FileAPI () + -- write to a file +-- TODO: input-output-hk/typed-protocols#57 + +type FileRPC = ReqResp FileAPI diff --git a/typed-protocols-examples/typed-protocols-examples.cabal b/typed-protocols-examples/typed-protocols-examples.cabal index 3a717155..fb2850e1 100644 --- a/typed-protocols-examples/typed-protocols-examples.cabal +++ b/typed-protocols-examples/typed-protocols-examples.cabal @@ -38,7 +38,10 @@ library , Network.TypedProtocol.ReqResp2.Type , Network.TypedProtocol.ReqResp2.Client + , Network.TypedProtocol.Stateful.ReqResp.Type , Network.TypedProtocol.Stateful.ReqResp.Client + , Network.TypedProtocol.Stateful.ReqResp.Server + , Network.TypedProtocol.Stateful.ReqResp.Codec , Network.TypedProtocol.Stateful.ReqResp.Examples , Network.TypedProtocol.Trans.Wedge From f451040f54587869a10abe7db69045bfa6909b2d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 14 Sep 2024 21:06:19 +0200 Subject: [PATCH 39/39] typed-protocols: fixed typos --- typed-protocols/src/Network/TypedProtocol/Driver.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/typed-protocols/src/Network/TypedProtocol/Driver.hs b/typed-protocols/src/Network/TypedProtocol/Driver.hs index 23c849fe..b12d66c9 100644 --- a/typed-protocols/src/Network/TypedProtocol/Driver.hs +++ b/typed-protocols/src/Network/TypedProtocol/Driver.hs @@ -262,7 +262,7 @@ runPipelinedPeerSender receiveQueue collectQueue Driver{sendMessage, recvMessage} peer dstate0 = do threadId <- myThreadId - labelThread threadId "pipeliend-peer-seneder" + labelThread threadId "pipelined-peer-sender" go Zero (HasDState dstate0) peer where go :: forall st' n. @@ -314,7 +314,7 @@ runPipelinedPeerReceiverQueue runPipelinedPeerReceiverQueue receiveQueue collectQueue driver@Driver{initialDState} = do threadId <- myThreadId - labelThread threadId "pipelined-recevier-queue" + labelThread threadId "pipelined-receiver-queue" go initialDState where go :: dstate -> m Void