<div dir="ltr"><div><div>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?<br><br>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.<br></div> <br><br>{-# LANGUAGE NoImplicitPrelude, DeriveFunctor, OverloadedStrings #-}<br>module Lib where<br><br>import Protolude<br>import Control.Monad.Free<br>import System.Socket<br>import System.Socket.Family.Inet<br>import System.Socket.Type.Stream<br>import System.Socket.Protocol.TCP<br>import Control.Exception ( bracket, catch )<br>import Data.ByteString as BS (uncons)<br><br>data NetworkActivity chan next =<br> Accept<br> chan<br> (Free (NetworkActivity chan) chan)<br> (chan -> Free (NetworkActivity chan) Text)<br> (chan -> next)<br> | Send chan ByteString (Bool -> next)<br> | Recv chan (ByteString -> next)<br> | Close chan (() -> next)<br> | Forked chan deriving Functor<br><br>recv :: a -> Free (NetworkActivity a) ByteString<br>recv chan = liftF (Recv chan identity)<br><br>sendit :: a -> ByteString -> Free (NetworkActivity a) Bool<br>sendit chan pl = liftF (Send chan pl identity)<br><br>clse :: a -> Free (NetworkActivity a) Text<br>clse chan = liftF (Close chan (const "Quit"))<br><br>acc :: a -> Free (NetworkActivity a) a -> (a -> Free (NetworkActivity a) Text) -> Free (NetworkActivity a) a<br>acc chan srv acc = liftF (Accept chan srv acc identity)<br><br>mchatterServer :: a -> Free (NetworkActivity a) a<br>mchatterServer chan = acc chan (mchatterServer chan) mchatterLoop<br><br>mchatterLoop :: a -> Free (NetworkActivity a) Text<br>mchatterLoop chan = do<br> str <- recv chan<br> case BS.uncons str of<br> Nothing -> do<br> msg <- clse chan<br> Pure msg<br> Just x -> if str == "Bye" then<br> clse chan<br> else do<br> _ <- sendit chan str<br> mchatterLoop chan<br><br>interpretStdIO :: Free (NetworkActivity ()) r -> IO r<br>interpretStdIO prg = case prg of<br> Free (Accept sock _ _ g) -> interpretStdIO (g sock)<br> Free (Recv _ g) -> do<br> ln <- getLine<br> interpretStdIO (g (encodeUtf8 ln))<br> Free (Close _ r) -> do<br> putStrLn ("Server bye!" :: Text)<br> interpretStdIO (r ())<br> Pure r -> return r<br> Free (Send _ pl f) -> do<br> putStrLn (decodeUtf8 pl)<br> interpretStdIO (f True)<br><br>type TCPSocket = Socket Inet Stream TCP<br><br>tcpSock :: IO TCPSocket<br>tcpSock = do<br> s <- socket :: IO (Socket Inet Stream TCP)<br> setSocketOption s (ReuseAddress True)<br> bind s (SocketAddressInet inetAny 5000)<br> listen s 5<br> return s<br><br>interpretTCP :: Free (NetworkActivity TCPSocket) r -> IO r<br>interpretTCP prg = case prg of<br> Free (Accept serverSock svrLoop acceptProc g) -> bracket (return serverSock)<br> (\s-> interpretTCP (clse s))<br> (\s-> do<br> (ss, sa) <- accept s<br> forkIO $ do <br> _ <- interpretTCP (acceptProc ss)<br> return ()<br> interpretTCP (g s)<br> ) <br> Free (Recv sock g) -> do<br> bs <- receive sock 4096 mempty<br> putStrLn (decodeUtf8 bs)<br> interpretTCP (g bs)<br> Free (Close sock g) -> do<br> close sock<br> putStrLn ("Server bye!" :: Text)<br> interpretTCP (g ())<br> Pure r -> return r<br> Free (Send sock pl g) -> do<br> sent <- send sock pl mempty<br> interpretTCP (g (sent > 0))<br><br></div><div>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.<br></div></div><div class="gmail_extra"><br><div class="gmail_quote">On Wed, Oct 12, 2016 at 10:15 PM, Sumit Raja <span dir="ltr"><<a href="mailto:sumitraja@gmail.com" target="_blank">sumitraja@gmail.com</a>></span> wrote:<br><blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">Hello,<br>
<br>
I am trying to get my head around free monads by developing a simple<br>
network abstraction DSL.<br>
I've made good progress before adding TCP/IP semantics of accepting<br>
connections. I'm now stuck with the creation of monadic functions.<br>
<br>
I've defined the following:<br>
<br>
data NetworkActivity chan next = Accept chan next (chan -> next) |<br>
Send chan ByteString (Bool -> next) |<br>
Recv chan (ByteString -> next) |<br>
Close chan (() -> next)<br>
<br>
clse :: a -> Free (NetworkActivity a) Text<br>
clse chan = liftF (Close chan (const "Quit"))<br>
<br>
chatterServer :: a -> Free (NetworkActivity a) Text<br>
chatterServer svrchan = Free $ Accept svrchan (chatterServer<br>
svrchan) chatterLoop<br>
<br>
chatterLoop :: a -> Free (NetworkActivity a) Text<br>
chatterLoop chan = Free $ Recv chan $ \bs -> case BS.uncons bs of<br>
Nothing -> clse chan<br>
Just x -> if bs == "Bye" then<br>
Free $ Close chan (\_ -> Pure "Quit")<br>
else<br>
Free (Send chan bs (\_ -> chatterLoop chan))<br>
<br>
This works fine with the interpretTCP interpreter below accepting<br>
multiple connections:<br>
<br>
interpretTCP :: Free (NetworkActivity TCPSocket) r -> IO r<br>
interpretTCP prg = case prg of<br>
Free (Accept serverSock svrLoop acceptProc) -> bracket (return serverSock)<br>
(\s-> interpretTCP (clse s))<br>
(\s-> do<br>
(ss, sa) <- accept s<br>
forkIO $ do<br>
_ <- interpretTCP (acceptProc ss)<br>
return ()<br>
interpretTCP svrLoop<br>
)<br>
Free (Recv sock g) -> do<br>
bs <- receive sock 4096 mempty<br>
putStrLn (decodeUtf8 bs)<br>
interpretTCP (g bs)<br>
Free (Close sock g) -> do<br>
close sock<br>
putStrLn ("Server bye!" :: Text)<br>
interpretTCP (g ())<br>
Pure r -> return r<br>
Free (Send sock pl g) -> do<br>
sent <- send sock pl mempty<br>
interpretTCP (g (sent > 0))<br>
<br>
Where I'm stuck is defining the monadic version of accept and I'm<br>
beginning to think my original<br>
data type defined above may be wrong. As an initial step I've defined<br>
the following:<br>
<br>
recv :: a -> Free (NetworkActivity a) ByteString<br>
recv chan = liftF (Recv chan identity)<br>
<br>
sendit :: a -> ByteString -> Free (NetworkActivity a) Bool<br>
sendit chan pl = liftF (Send chan pl identity)<br>
<br>
mchatterServer :: a -> Free (NetworkActivity a) Text<br>
mchatterServer chan = Free $ Accept chan (mchatterServer chan)<br>
(\s<br>
-> return (identity s) >>= mchatterLoop)<br>
<br>
mchatterServer works as is, the interpreter accepts multiple<br>
connections. Similarly all good with recv and sendit.<br>
I am struggling with converting the Accept in mchatterServer into a<br>
function to use in the do syntax. The signature I think I should be<br>
using is<br>
<br>
acc :: a -> NetworkActivity a Text -> Free (NetworkActivity a)<br>
(NetworkActivity a Text)<br>
<br>
What I can't figure out is why it can't follow the pattern of recv and<br>
sendit above:<br>
<br>
acc chan next = liftF $ Accept chan next identity<br>
<br>
Which results in error on identity (using Protolude):<br>
<br>
Expected type: a -> NetworkActivity a Text<br>
Actual type: NetworkActivity a Text -> NetworkActivity a Text<br>
<br>
I can't really see how to get the types to line up and have now can't<br>
see through the type fog. What am I missing in my reasoning about the<br>
types?<br>
<br>
Help much appreciated!<br>
<br>
Thanks<br>
<br>
Sumit<br>
______________________________<wbr>_________________<br>
Beginners mailing list<br>
<a href="mailto:Beginners@haskell.org">Beginners@haskell.org</a><br>
<a href="http://mail.haskell.org/cgi-bin/mailman/listinfo/beginners" rel="noreferrer" target="_blank">http://mail.haskell.org/cgi-<wbr>bin/mailman/listinfo/beginners</a><br>
</blockquote></div><br></div>