{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Network.TypedProtocol.Driver.Simple (
runPeer,
TraceSendRecv(..),
runPipelinedPeer,
runConnectedPeers,
runConnectedPeersPipelined,
driverSimple,
runDecoderWithChannel,
) where
import Network.TypedProtocol.Core
import Network.TypedProtocol.Pipelined
import Network.TypedProtocol.Driver
import Network.TypedProtocol.Channel
import Network.TypedProtocol.Codec
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Tracer (Tracer (..), traceWith, contramap)
data TraceSendRecv ps where
TraceSendMsg :: AnyMessage ps -> TraceSendRecv ps
TraceRecvMsg :: AnyMessage ps -> TraceSendRecv ps
instance Show (AnyMessage ps) => Show (TraceSendRecv ps) where
show :: TraceSendRecv ps -> String
show (TraceSendMsg AnyMessage ps
msg) = String
"Send " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnyMessage ps -> String
forall a. Show a => a -> String
show AnyMessage ps
msg
show (TraceRecvMsg AnyMessage ps
msg) = String
"Recv " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnyMessage ps -> String
forall a. Show a => a -> String
show AnyMessage ps
msg
driverSimple :: forall ps failure bytes m.
(MonadThrow m, Exception failure)
=> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
driverSimple :: Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec{forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode, forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode} channel :: Channel m bytes
channel@Channel{bytes -> m ()
send :: forall (m :: * -> *) a. Channel m a -> a -> m ()
send :: bytes -> m ()
send} =
Driver :: forall ps dstate (m :: * -> *).
(forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ())
-> (forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st -> dstate -> m (SomeMessage st, dstate))
-> dstate
-> Driver ps dstate m
Driver { forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage, forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage, startDState :: Maybe bytes
startDState = Maybe bytes
forall a. Maybe a
Nothing }
where
sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st
-> Message ps st st'
-> m ()
sendMessage :: PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage PeerHasAgency pr st
stok Message ps st st'
msg = do
bytes -> m ()
send (PeerHasAgency pr st -> Message ps st st' -> bytes
forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode PeerHasAgency pr st
stok Message ps st st'
msg)
Tracer m (TraceSendRecv ps) -> TraceSendRecv ps -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessage ps -> TraceSendRecv ps
forall ps. AnyMessage ps -> TraceSendRecv ps
TraceSendMsg (Message ps st st' -> AnyMessage ps
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> AnyMessage ps
AnyMessage Message ps st st'
msg))
recvMessage :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes
-> m (SomeMessage st, Maybe bytes)
recvMessage :: PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage PeerHasAgency pr st
stok Maybe bytes
trailing = do
DecodeStep bytes failure m (SomeMessage st)
decoder <- PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode PeerHasAgency pr st
stok
Either failure (SomeMessage st, Maybe bytes)
result <- Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (SomeMessage st)
-> m (Either failure (SomeMessage st, Maybe bytes))
forall (m :: * -> *) bytes failure a.
Monad m =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel Channel m bytes
channel Maybe bytes
trailing DecodeStep bytes failure m (SomeMessage st)
decoder
case Either failure (SomeMessage st, Maybe bytes)
result of
Right x :: (SomeMessage st, Maybe bytes)
x@(SomeMessage Message ps st st'
msg, Maybe bytes
_trailing') -> do
Tracer m (TraceSendRecv ps) -> TraceSendRecv ps -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessage ps -> TraceSendRecv ps
forall ps. AnyMessage ps -> TraceSendRecv ps
TraceRecvMsg (Message ps st st' -> AnyMessage ps
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> AnyMessage ps
AnyMessage Message ps st st'
msg))
(SomeMessage st, Maybe bytes) -> m (SomeMessage st, Maybe bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st, Maybe bytes)
x
Left failure
failure ->
failure -> m (SomeMessage st, Maybe bytes)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO failure
failure
runPeer
:: 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
runPeer :: Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m a
runPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel Peer ps pr st m a
peer =
(a, Maybe bytes) -> a
forall a b. (a, b) -> a
fst ((a, Maybe bytes) -> a) -> m (a, Maybe bytes) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Driver ps (Maybe bytes) m
-> Peer ps pr st m a -> Maybe bytes -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
Monad m =>
Driver ps dstate m -> Peer ps pr st m a -> dstate -> m (a, dstate)
runPeerWithDriver Driver ps (Maybe bytes) m
driver Peer ps pr st m a
peer (Driver ps (Maybe bytes) m -> Maybe bytes
forall ps dstate (m :: * -> *). Driver ps dstate m -> dstate
startDState Driver ps (Maybe bytes) m
driver)
where
driver :: Driver ps (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
forall ps failure bytes (m :: * -> *).
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel
runPipelinedPeer
:: forall ps (st :: ps) pr failure bytes m a.
(MonadSTM m, 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
runPipelinedPeer :: Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m a
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel PeerPipelined ps pr st m a
peer =
(a, Maybe bytes) -> a
forall a b. (a, b) -> a
fst ((a, Maybe bytes) -> a) -> m (a, Maybe bytes) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Driver ps (Maybe bytes) m
-> PeerPipelined ps pr st m a -> Maybe bytes -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
MonadAsync m =>
Driver ps dstate m
-> PeerPipelined ps pr st m a -> dstate -> m (a, dstate)
runPipelinedPeerWithDriver Driver ps (Maybe bytes) m
driver PeerPipelined ps pr st m a
peer (Driver ps (Maybe bytes) m -> Maybe bytes
forall ps dstate (m :: * -> *). Driver ps dstate m -> dstate
startDState Driver ps (Maybe bytes) m
driver)
where
driver :: Driver ps (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
forall ps failure bytes (m :: * -> *).
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel
runDecoderWithChannel :: Monad m
=> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel :: Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel Channel{m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv :: m (Maybe bytes)
recv} = Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go
where
go :: Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
_ (DecodeDone a
x Maybe bytes
trailing) = Either failure (a, Maybe bytes)
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe bytes) -> Either failure (a, Maybe bytes)
forall a b. b -> Either a b
Right (a
x, Maybe bytes
trailing))
go Maybe bytes
_ (DecodeFail failure
failure) = Either failure (a, Maybe bytes)
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) a. Monad m => a -> m a
return (failure -> Either failure (a, Maybe bytes)
forall a b. a -> Either a b
Left failure
failure)
go Maybe bytes
Nothing (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m a)
k) = m (Maybe bytes)
recv m (Maybe bytes)
-> (Maybe bytes -> m (DecodeStep bytes failure m a))
-> m (DecodeStep bytes failure m a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes -> m (DecodeStep bytes failure m a)
k m (DecodeStep bytes failure m a)
-> (DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes)))
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
forall a. Maybe a
Nothing
go (Just bytes
trailing) (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m a)
k) = Maybe bytes -> m (DecodeStep bytes failure m a)
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
trailing) m (DecodeStep bytes failure m a)
-> (DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes)))
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
forall a. Maybe a
Nothing
runConnectedPeers :: (MonadSTM m, MonadAsync m, MonadCatch m,
Exception failure)
=> m (Channel m bytes, Channel m bytes)
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> Peer ps (FlipAgency pr) st m b
-> m (a, b)
runConnectedPeers :: m (Channel m bytes, Channel m bytes)
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> Peer ps (FlipAgency pr) st m b
-> m (a, b)
runConnectedPeers m (Channel m bytes, Channel m bytes)
createChannels Tracer m (PeerRole, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Peer ps pr st m a
client Peer ps (FlipAgency pr) st m b
server =
m (Channel m bytes, Channel m bytes)
createChannels m (Channel m bytes, Channel m bytes)
-> ((Channel m bytes, Channel m bytes) -> m (a, b)) -> m (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Channel m bytes
clientChannel, Channel m bytes
serverChannel) ->
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m a
forall ps (st :: ps) (pr :: PeerRole) 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
runPeer Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec Channel m bytes
clientChannel Peer ps pr st m a
client
m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
`concurrently`
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps (FlipAgency pr) st m b
-> m b
forall ps (st :: ps) (pr :: PeerRole) 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
runPeer Tracer m (TraceSendRecv ps)
tracerServer Codec ps failure m bytes
codec Channel m bytes
serverChannel Peer ps (FlipAgency pr) st m b
server
where
tracerClient :: Tracer m (TraceSendRecv ps)
tracerClient = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) PeerRole
AsClient) Tracer m (PeerRole, TraceSendRecv ps)
tracer
tracerServer :: Tracer m (TraceSendRecv ps)
tracerServer = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) PeerRole
AsServer) Tracer m (PeerRole, TraceSendRecv ps)
tracer
runConnectedPeersPipelined :: (MonadSTM m, MonadAsync m, MonadCatch m,
Exception failure)
=> 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
-> m (a, b)
runConnectedPeersPipelined :: 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
-> m (a, b)
runConnectedPeersPipelined m (Channel m bytes, Channel m bytes)
createChannels Tracer m (PeerRole, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec PeerPipelined ps pr st m a
client Peer ps (FlipAgency pr) st m b
server =
m (Channel m bytes, Channel m bytes)
createChannels m (Channel m bytes, Channel m bytes)
-> ((Channel m bytes, Channel m bytes) -> m (a, b)) -> m (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Channel m bytes
clientChannel, Channel m bytes
serverChannel) ->
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m a
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
a.
(MonadSTM m, 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
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec Channel m bytes
clientChannel PeerPipelined ps pr st m a
client
m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
`concurrently`
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps (FlipAgency pr) st m b
-> m b
forall ps (st :: ps) (pr :: PeerRole) 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
runPeer Tracer m (TraceSendRecv ps)
tracerServer Codec ps failure m bytes
codec Channel m bytes
serverChannel Peer ps (FlipAgency pr) st m b
server
where
tracerClient :: Tracer m (TraceSendRecv ps)
tracerClient = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) PeerRole
AsClient) Tracer m (PeerRole, TraceSendRecv ps)
tracer
tracerServer :: Tracer m (TraceSendRecv ps)
tracerServer = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) PeerRole
AsServer) Tracer m (PeerRole, TraceSendRecv ps)
tracer