I feel like you are close to a something, but the recursion makes it difficult. You need to think about what types you've given and what you need. The types of Send, Recv and Close make sense to me. Send takes a chan and a bytestring and returns bool. Recv takes a chan and returns a bytestring, close takes a chan and returns nothing. Accept takes a chan, and something? and returns a chan?
I feel like if you can figure out what you actually want Accept to do, it will become clearer. Here's my attempt. Accept takes a chan, takes a procedure to loop on, a procedure to accept on, and then returns the server chan to continue the loop. I don't know if this is entirely right, but it type checks and hopefully it will give you some ideas.
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor, OverloadedStrings #-}
module Lib where
import Protolude
import Control.Monad.Free
import System.Socket
import System.Socket.Family.Inet
import System.Socket.Type.Stream
import System.Socket.Protocol.TCP
import Control.Exception ( bracket, catch )
import Data.ByteString as BS (uncons)
data NetworkActivity chan next =
Accept
chan
(Free (NetworkActivity chan) chan)
(chan -> Free (NetworkActivity chan) Text)
(chan -> next)
| Send chan ByteString (Bool -> next)
| Recv chan (ByteString -> next)
| Close chan (() -> next)
| Forked chan deriving Functor
recv :: a -> Free (NetworkActivity a) ByteString
recv chan = liftF (Recv chan identity)
sendit :: a -> ByteString -> Free (NetworkActivity a) Bool
sendit chan pl = liftF (Send chan pl identity)
clse :: a -> Free (NetworkActivity a) Text
clse chan = liftF (Close chan (const "Quit"))
acc :: a -> Free (NetworkActivity a) a -> (a -> Free (NetworkActivity a) Text) -> Free (NetworkActivity a) a
acc chan srv acc = liftF (Accept chan srv acc identity)
mchatterServer :: a -> Free (NetworkActivity a) a
mchatterServer chan = acc chan (mchatterServer chan) mchatterLoop
mchatterLoop :: a -> Free (NetworkActivity a) Text
mchatterLoop chan = do
str <- recv chan
case BS.uncons str of
Nothing -> do
msg <- clse chan
Pure msg
Just x -> if str == "Bye" then
clse chan
else do
_ <- sendit chan str
mchatterLoop chan
interpretStdIO :: Free (NetworkActivity ()) r -> IO r
interpretStdIO prg = case prg of
Free (Accept sock _ _ g) -> interpretStdIO (g sock)
Free (Recv _ g) -> do
ln <- getLine
interpretStdIO (g (encodeUtf8 ln))
Free (Close _ r) -> do
putStrLn ("Server bye!" :: Text)
interpretStdIO (r ())
Pure r -> return r
Free (Send _ pl f) -> do
putStrLn (decodeUtf8 pl)
interpretStdIO (f True)
type TCPSocket = Socket Inet Stream TCP
tcpSock :: IO TCPSocket
tcpSock = do
s <- socket :: IO (Socket Inet Stream TCP)
setSocketOption s (ReuseAddress True)
bind s (SocketAddressInet inetAny 5000)
listen s 5
return s
interpretTCP :: Free (NetworkActivity TCPSocket) r -> IO r
interpretTCP prg = case prg of
Free (Accept serverSock svrLoop acceptProc g) -> bracket (return serverSock)
(\s-> interpretTCP (clse s))
(\s-> do
(ss, sa) <- accept s
forkIO $ do
_ <- interpretTCP (acceptProc ss)
return ()
interpretTCP (g s)
)
Free (Recv sock g) -> do
bs <- receive sock 4096 mempty
putStrLn (decodeUtf8 bs)
interpretTCP (g bs)
Free (Close sock g) -> do
close sock
putStrLn ("Server bye!" :: Text)
interpretTCP (g ())
Pure r -> return r
Free (Send sock pl g) -> do
sent <- send sock pl mempty
interpretTCP (g (sent > 0))
I feel like it should be able to be written without Free in the NetworkActivity datatype, but it will require some pattern matching on Free and maybe some liftF's that I couldn't quite figure out.