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
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