[Haskell-cafe] First go at reactive programming

[Levi Stephen]

Hi,

Below is a version that was aimed at getting rid of the (Handle,IO 
(Request a)) tuples and as a result made it easier to remove the IO 
monad from some types, but I don't think it removed it completely from 
any methods.

module Main where

import Control.Applicative
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 :: Request -> Html
helloWorldDoc rq =     header << thetitle << "Hello World"
                   +++ body   << (h1 << "Hello World" +++ p << show rq)

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 :: Handle -> RequestHandler -> IO ()
handleConnection h r =
  handleToRequest h >>= responseSend h . runRequestHandler r

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

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

responseSend :: Handle -> Result Response -> IO ()
responseSend h rsp = either print (respondHTTP h) rsp >> 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