This is part of an ongoing series of posts about fun with Cofree Comonads. If you’re just jumping in, I’d recommend reading the series from the start, since this post assumes that you’re up to date.

For this post I want to focus on establishing a pairing between a `Free`

-based DSL with a `Cofree`

-based interpreter over the network.

This is all meant to be illustrative. I won’t be spending any time on getting the asynchronous exceptions or the binary streaming to anything beyond a toy level, although I may double back at a later date and take care of that.

Coproducts and products will take a back seat for a post or two, although they’ll return as soon as we have described all of the pieces we need.

Recall that we had a type `AdderF`

:

```
data AdderF k = Add Int (Bool -> k)
| Clear k
| Total (Int -> k)
```

and a type `CoAdderF`

:

```
data CoAdderF k = CoAdderF {
addH :: Int -> (Bool, k)
, clearH :: k
, totalH :: (Int, k)
}
```

In earlier posts, we have discussed that we can view each of the constructors `Add`

, `Clear`

and `Total`

as being comprised of a set of input parameters and a function from output parameters to `k`

.

If we view our `Free AdderF`

as a protocol, we can view these as requests and responses. Considering our goal is to establish a pairing over the network, this seems like a good avenue to explore.

To formalize the protocol / request / response notion somewhat, if we had

`type Client req res k = (req, res -> k)`

we could recast `AdderF`

as

```
data AdderF k = Add (Client Int Bool k)
| Clear (Client () () k)
| Total (Client () Int k)
```

and with

`type Interpreter req res k = req -> (res, k)`

we could recast `CoAdderF`

as

```
data CoAdderF k = CoAdderF {
addH :: Interpreter Int Bool k
, clearH :: Interpreter () () k
, totalH :: Interpreter () Int k
}
```

We can turn this “inside out” if we define

```
data AdderReq = AddReq Int
| ClearReq
| TotalReq
```

and

```
data AdderRes = AddRes Bool
| ClearRes
| TotalRes Int
```

from which we can get

`type AdderF k = Client AdderReq AdderRes k`

and

`type CoAdderF k = Interpreter AdderReq AdderRes k`

Regardless of which approach we take, we’re going to need:

- pairings between the DSL and the interpreter
- serialization of our requests and responses
- the ability to handle errors and IO

The first approach is going to require a serialization strategy where none of the coproducts contributing to `AdderF`

will get in each others way. We’ll return to that once we’ve covered some of the associated type-level machinery in the next post.

The second approach has some risk of mismatching requests and responses while they are in flight. Since we need to handle errors anyway, we just need to make sure that our methods of error handling is sufficient to deal with mismatched requests and responses and all should be well.

Since we’re going to handle effects when we take to the network, lets weave some effects into our client and interpreter types:

```
data NetworkClientF req res m k = NetworkClientF (req, res -> m k)
data NetworkInterpreterF req res m k = NetworkInterpreterF (req -> m (res, k))
```

We also want these to be `Functor`

s, so that we can pair them:

```
instance Functor m => Functor (NetworkClientF req res m) where
fmap f (NetworkClientF k) = NetworkClientF (fmap (fmap (fmap f)) k)
instance Functor m => Functor (NetworkInterpreterF req res m) where
fmap f (NetworkInterpreterF k) = NetworkInterpreterF (fmap (fmap (fmap f)) k)
```

The problem we have now is that `Pairing`

doesn’t know about effects:

```
class Pairing f g | f -> g, g -> f where
pair :: (a -> b -> r) -> f a -> g b -> r
```

We deal with this in the usual manner - if we need effects, add an `m`

somewhere:

```
class PairingM f g m | f -> g, g -> f where
pairM :: (a -> b -> m r) -> f a -> g b -> m r
```

(although this was actually concocted in a slightly less ad-hoc manner than just adding an `m`

and hoping).

Now we have what we need to link the client and interpreter:

```
instance Monad m => PairingM (NetworkInterpreterF req res m) (NetworkClientF req res m) m where
pairM p (NetworkInterpreterF fi) (NetworkClientF (rq, fc)) = do
(rs, ki) <- fi rq
kc <- fc rs
p ki kc
```

given some way to actually make use of the `PairingM`

:

```
pairEffectM :: ( Functor (f m)
, PairingM (f m) (g m) m
, Comonad w
, Monad m
)
=> (a -> b -> m r) -> CofreeT (f m) w (m a) -> FreeT (g m) m b -> m r
pairEffectM p s c = do
a <- extract s
mb <- runFreeT c
case mb of
Pure x -> p a x
Free gs -> pairM (pairEffectM p) (unwrap s) gs
```

This is where we need to get to as a first step to connecting our DSL and interpreter over the network.

Our previous console example was

```
run :: IO ()
run = pairEffect (\_ r -> r) (mkCoAdderWithLogging 10 0) runConsole
```

which connects an interactive console with an interpreter which prints information about what it is up to.

This made use of

`runConsole :: (Functor f, MonadIO m, ConsoleClient f, Monad m) => FreeT f m ()`

and the instance of `ConsoleClient`

for `AdderF`

, along with

`mkCoAdderWithLogging :: MonadIO m => Int -> Int -> CofreeT CoAdderF (StoreT Int (EnvT Int Identity)) (m ())`

Our goal is to get the same functionality working across the network.

What we have so far has the form `FreeT AdderF m a`

or `CofreeT CoAdderF w a`

, and we need to get it into a form that uses `NetworkClientF`

or `NetworkInterpreterF`

.

There are some useful helper functions for working with `FreeT`

in the `Control.Monad.Trans.Free`

module of the `free`

package.

Amongst them are

`transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b `

which lets us swap out the underlying `Functor`

, and

`hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b`

which lets us swap out (or transform) the underlying `Monad`

.

There are also some very handy tools we can use in conjunction with `hoistFreeT`

in the mmorph package.

For cofree, there are instances of `ComonadHoist`

throughout the `free`

package which will give us hoisting, and the `master`

branch on github has

`transCofreeT :: (Comonad w, Functor g) => (forall a. f a -> g a) -> CofreeT f w b -> CofreeT g w b `

if you’re feeling adventurous and want to play along.

As an aside: ordinarily I’d try to use `transFreeT`

and `hoistFreeT`

to try to get by with a regular `Pairing`

instance rather than a `PairingM`

instance. I tried a few variants to make that work, but struggled with some of the details of getting the error handling interleaved with the pairing in the correct fashion. I’ll be trying again later on, but if anyone happens to play around with this and finds a way to do without `PairingM`

, please get in touch and let me know.

We’re usually working with `FreeT AdderF m a`

and we’d like to get that to `FreeT (NetworkClientF AdderReq AdderRes m) m a`

, so it seems like `transFreeT`

is just what we want. Now we need a function to transform `AdderF k`

into `NetworkClientF AdderReq AdderRes m k`

and a function to transform `CoAdderF k`

into `NetworkInterpreterF AdderReq AdderRes m k`

.

With that in mind - and realizing that we may want to use some of this machinery for more than this single toy example - we set up the type families:

```
class ToNetworkClient (a :: * -> *) m where
type ClientReq a
type ClientRes a
toNetworkClient :: a k -> NetworkClientF (ClientReq a) (ClientRes a) m k
class ToNetworkInterpreter (a :: * -> *) m where
type InterpreterReq a
type InterpreterRes a
toNetworkInterpreter :: a k -> NetworkInterpreterF (InterpreterReq a) (InterpreterRes a) m k
```

to assist us.

The translation for `AdderF`

makes use of our network error type:

```
data NetError = Disconnected
| UnexpectedRequest
| UnexpectedResponse
```

and introduces a `MonadError NetError m`

constraint from the `Control.Monad.Except`

module in the `mtl`

package:

```
instance (Monad m, MonadError NetError m) => ToNetworkClient AdderF m where
type ClientReq AdderF = AdderReq
type ClientRes AdderF = AdderRes
toNetworkClient (Add x f) = NetworkClientF (AddReq x, g)
where
g (AddRes b) = return $ f b
g _ = throwError UnexpectedResponse
toNetworkClient (Clear k) = NetworkClientF (ClearReq, g)
where
g ClearRes = return k
g _ = throwError UnexpectedResponse
toNetworkClient (Total f) = NetworkClientF (TotalReq, g)
where
g (TotalRes i) = return $ f i
g _ = throwError UnexpectedResponse
```

The translation for `CoAdderF`

involves less drama:

```
instance Monad m => ToNetworkInterpreter CoAdderF m where
type InterpreterReq CoAdderF = AdderReq
type InterpreterRes CoAdderF = AdderRes
toNetworkInterpreter (CoAdderF a c t) = NetworkInterpreterF $ \rq -> case rq of
AddReq i -> let
(b, k) = a i
in return (AddRes b, k)
ClearReq -> return (ClearRes, c)
TotalReq -> let
(i, k) = t
in return (TotalRes i, k)
```

At this point we can recast our DSLs and interpreters into a more network-friendly form, but we still need to connect them up to the network.

From the client side, we want to translate our `FreeT c m a`

to a `FreeT (NetworkClientF (ClientReq c) (ClientRes c) m) m a`

, and then pair it with something to connect it with the network.

We want something like this:

```
pairClient :: ( Functor m
, MonadError NetError m
, ToNetworkClient c m
)
=> FreeT c m () -> m ()
pairClient = pairEffectM (\_ r -> return r) ??? . transFreeT toNetworkClient
```

and from the pairing we already have, we can reasonably assume that `???`

is going to be some kind of `CofreeT (NetworkInterpreterF (InterpreterReq c) (InterpreterRes c) m) w a`

Making use of the `network-simple`

package and assuming that we’ve already got access to a connected `Socket`

, we can devise something like that:

```
mkClientConnector :: ( Functor m
, MonadReader Socket m
, MonadError NetError m
, MonadIO m
, Binary req
, Binary res
)
=> Cofree (NetworkInterpreterF req res m) (m ())
mkClientConnector = coiterT f (Identity (return ()))
where
f w = NetworkInterpreterF $ \req -> do
-- get the socket
s <- ask
-- encode and send the request
send s . L.toStrict . encode $ req
-- read and decode the response
res <- fmap (decode . L.fromStrict) <$> recv s 1024
-- check for disconnection
case res of
Nothing -> throwError Disconnected
Just x -> return (x, w)
```

This is where we end up needing `Binary`

instances for `AdderReq`

and `AdderRes`

:

```
instance Binary AdderReq where
put (AddReq i) = putWord8 0 >> put i
put ClearReq = putWord8 1
put TotalReq = putWord8 2
get = do
x <- getWord8
case x of
0 -> AddReq <$> get
1 -> return ClearReq
2 -> return TotalReq
_ -> empty
instance Binary AdderRes where
put (AddRes b) = putWord8 0 >> put b
put ClearRes = putWord8 1
put (TotalRes i) = putWord8 2 >> put i
get = do
x <- getWord8
case x of
0 -> AddRes <$> get
1 -> return ClearRes
2 -> TotalRes <$> get
_ -> empty
```

With that in hand, we can update `pairClient`

to make use of `mkClientConnector`

:

```
pairClient :: ( Functor m
, MonadReader Socket m
, MonadError NetError m
, MonadIO m
, ToNetworkClient c m
, Binary (ClientReq c)
, Binary (ClientRes c)
)
=> FreeT c m () -> m ()
pairClient = pairEffectM (\_ r -> return r) mkClientConnector . transFreeT toNetworkClient
```

We add a helper function to connect the socket and handle the `MonadReader Socket`

and `MonadError NetError`

obligations:

```
runClient :: (MonadIO m, MonadMask m) => HostName -> ServiceName -> ReaderT Socket (ExceptT NetError m) a -> m (Either NetError a)
runClient host service x = connect host service $ \(sock, _) -> runExceptT . flip runReaderT sock $ x
```

With all of this in hand, we can finally connect our `runConsole`

function to the network:

```
networkClient :: HostName -> ServiceName -> IO (Either NetError ())
networkClient host service = runClient host service (pairClient console)
where
console = runConsole :: FreeT AdderF (ReaderT Socket (ExceptT NetError IO)) ()
```

We end up with similar pieces of functionality to get the interpreter connected to the network.

We have the pairing function:

```
pairInterpreter :: ( Functor m
, Comonad w
, MonadReader Socket m
, MonadError NetError m
, MonadIO m
, ToNetworkInterpreter i m
, Binary (InterpreterReq i)
, Binary (InterpreterRes i)
)
=> CofreeT i w (m ()) -> m ()
pairInterpreter server = pairEffectM (\_ r -> return r) (transCofreeT toNetworkInterpreter server) mkInterpreterConnector
```

and we have the `FreeT (NetworkClientF (ClientReq i) (ClientRes i) m) ()`

that the pairing function needs:

```
mkInterpreterConnector :: ( Functor m
, MonadReader Socket m
, MonadError NetError m
, MonadIO m
, Binary req
, Binary res
)
=> FreeT (NetworkClientF req res m) m ()
mkInterpreterConnector = do
-- get the socket
s <- ask
-- read and decode the request
r <- fmap (decode . L.fromStrict) <$> recv s 1024
case r of
-- stop on disconnection
Nothing -> FreeT $ throwError Disconnected
Just x -> FreeT . return . Free . NetworkClientF $ (x, \t -> do
-- encode and send the response
_ <- liftIO . send s . L.toStrict . encode $ t
-- keep on going
return mkInterpreterConnector
)
```

With the client we didn’t need to use recursion, since the `coiterT`

in `mkClientConnector`

gave us that. Here we need to make a recursive call, but we don’t make the call in the event of a disconnection.

We have a helper function to serve the interpreter on a particular address and port:

```
runInterpreter :: HostName -> ServiceName -> ReaderT Socket (ExceptT NetError IO) () -> IO ()
runInterpreter host service x =
serve (Host host) service $ \(sock, _) ->
void . runExceptT . flip runReaderT sock $ x
```

with which we can connect our `CoAdderF`

to the network:

```
networkInterpreter :: HostName -> ServiceName -> IO ()
networkInterpreter host service = runInterpreter host service (pairInterpreter $ mkCoAdderWithLogging 10 0)
```

There were a few pieces in here, but we should be able to get some good usage out of them in the future.

Next we will revisit the products and sums of functors (and the pairings between them). I figured out a bit of this on my own, but the excellent course notes by Andres Löh got me the rest of the way there.

After that we will be looking at how to pair our coproduct-based DSLs and product-based interpreters over the network.

Since we have the various actions in serialized form, we can make further use of that. This could involve playing around with event sourcing - which has a lot of fun side-alleys associated with it - or it could involve setting up a write-ahead log in an attempt to make the pairing-over-the-network atomic an durable.

I’ve got a growing queue of `Cofree`

-based topics I want to write about, so some of those things might come later.

Site proudly generated by Hakyll

This work is licensed under a Creative Commons Attribution 4.0 International License