[Haskell-cafe] First go at reactive programming

[Conal Elliott]

Hi Levi,

Delightful!  I'd been hoping for a networking-related use of Reactive.  I
made a few tweaks to clean up the code:

* Factored the fmap out of handleConnection, handleToRequest,
runRequestHandler r, and responseSend, to simplify their
interfaces/semantics (no more events).
* Used (second.fmap) in runRequestHandler in place of explicit
manipulation.  Then factored it out into handleConnection, to simplify
interface/semantics (no more pair/IO).
* Added a few type signatures.
* Replaced (putStrLn . show) with print in responseSend.

Let's play some more with improving on the handle-passing.  Meanwhile, new
version below.  I bet we can make it more functional/elegant, isolating the
IO from a simple & pure core.  For instance, the pattern of accepting
connections and then dialoging on each one smells very like what I have in
mind for the (functional) Event monad.

Cheers,  - Conal

module Main where

import Control.Applicative
import Control.Arrow (second,(&&&),(>>>))
import Control.Concurrent
import Control.Monad

import Data.Reactive

import Network.BSD
import Network.HTTP
import Network

import System.IO

import Text.XHtml.Strict

type RequestHandler = Request -> Response

main = runHttpServer helloWorldHandler

helloWorldHandler :: RequestHandler
helloWorldHandler _ =  Response (2,0,0) "" [] $ prettyHtml helloWorldDoc

helloWorldDoc = header << thetitle << "Hello World"
            +++ body   << h1       << "Hello World"

runHttpServer :: RequestHandler -> IO a
runHttpServer r = socketServer >>= runE . fmap (handleConnection r)

socketServer :: IO (Event Handle)
socketServer = withSocketsDo $ do
  (e,snk) <- mkEventShow "Server"
  sock    <- listenOn (PortNumber 8080)
  forkIO $ forever $ acceptConnection sock $ snk
  return e

handleConnection :: RequestHandler -> Handle -> IO ()
handleConnection r =
  handleToRequest >>> (second.fmap) (runRequestHandler r) >>> responseSend


handleToRequest :: Handle -> (Handle, IO (Result Request))
handleToRequest = id &&& receiveHTTP

runRequestHandler :: RequestHandler -> Result Request -> Result Response
runRequestHandler r rq =  rq `bindE` (Right . r)

responseSend :: (Handle, IO (Result Response)) -> IO ()
responseSend (h,rsp) =
  rsp >>= either print (respondHTTP h) >> close h

acceptConnection :: Socket -> (Handle -> IO ()) -> IO ThreadId
acceptConnection s k = accept s >>= \(h,_,_) -> forkIO $ k h

instance Stream Handle where
 readLine   h   = hGetLine h >>= \l -> return $ Right $ l ++ "\n"
 readBlock  h n = replicateM n (hGetChar h) >>= return . Right
 writeBlock h s = mapM_ (hPutChar h) s >>= return . Right
 close          = hClose




On Jan 15, 2008 3:29 AM, Levi Stephen <levi.stephen at optusnet.com.au> wrote:

> Hi,
>
> Listed below is my first experiment with reactive programming. It is a
> simple web server written using the Data.Reactive[1] library. The
> intended interface is given by the runHttpServer function, so the
> remainder is intended to be internal.
>
> I'd be happy to hear comments on any parts of this, but am particularly
> interested in the following:
>
> 1. Is this kind of code what is intended from reactive programming?
> 2a. I'm not sure about passing the (Handle,...) tuple around. Is there a
> way to avoid this?
> 2b. I'm not sure of the best place to handle possible socket exceptions
> 2c. I'd like to be able to pass a function of type Event Request ->
> Event Response to runHttpServer, so that reactive programming could be
> used throughout client code also, but the (Handle,...) tuples seem to be
> getting in the way.
> 3. I have a feeling there's a clearer way to write responseSend.
>
> Thanks,
> Levi
>
> [1] http://www.haskell.org/haskellwiki/Reactive
>
> module Main where
>
> import Control.Applicative
> import Control.Arrow ((&&&),(>>>))
> import Control.Concurrent
> import Control.Monad
>
> import Data.Reactive
>
> import Network.BSD
> import Network.HTTP
> import Network
>
> import System.IO
>
> import Text.XHtml.Strict
>
> type RequestHandler = Request -> Response
>
> main = runHttpServer helloWorldHandler
>
> helloWorldHandler :: RequestHandler
> helloWorldHandler _ =  Response (2,0,0) "" [] $ prettyHtml helloWorldDoc
>
> helloWorldDoc = header << thetitle << "Hello World"
>            +++ body << h1 << "Hello World"
>
> runHttpServer r = socketServer >>= runE . handleConnection r
>
> socketServer :: IO (Event Handle)
> socketServer = withSocketsDo $ do
>  (e,snk) <- mkEventShow "Server"
>  sock <- listenOn (PortNumber 8080)
>  forkIO $ forever $ acceptConnection sock $ snk
>  return e
>
> handleConnection :: RequestHandler -> Event Handle -> Event (IO ())
> handleConnection r = handleToRequest >>> runRequestHandler r >>>
> responseSend
>
>
> handleToRequest :: Event Handle -> Event (Handle, IO (Result Request))
> handleToRequest e = fmap (id &&& receiveHTTP) e
>
> responseSend :: Event (Handle, IO (Result Response)) -> Event (IO ())
> responseSend e = fmap (\(h,rsp) -> rsp >>= either (putStrLn . show)
> (respondHTTP h) >> close h) e
>
> runRequestHandler :: RequestHandler -> Event (Handle, IO (Result
> Request)) -> Event (Handle, IO (Result Response))
> runRequestHandler r e = fmap hrToHr e
>  where
>    rqhdl :: Result Request -> Result Response
>    rqhdl rq =  bindE rq (Right . r)
>    hrToHr :: (Handle, IO (Result Request)) -> (Handle, IO (Result
> Response))
>    hrToHr (h,req) = (h, liftA rqhdl req)
>
> acceptConnection s k = accept s >>= \(h,_,_) -> forkIO $ k h
>
> instance Stream Handle where
>  readLine h = hGetLine h >>= \l -> return $ Right $ l ++ "\n"
>  readBlock h n = replicateM n (hGetChar h) >>= return . Right
>  writeBlock h s = mapM_ (hPutChar h) s >>= return . Right
>  close = hClose
>
>
>
>
>
>
> _______________________________________________
> Haskell-Cafe mailing list
> Haskell-Cafe at haskell.org
> http://www.haskell.org/mailman/listinfo/haskell-cafe
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://www.haskell.org/pipermail/haskell-cafe/attachments/20080115/ab10d9cc/attachment-0001.htm