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@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@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe