module Network.HTTP.RedHandler.Httpd
(runHttpServer) where
import Control.Concurrent (ThreadId, forkIO)
import Control.Monad (forever, replicateM)
import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Result, receiveHTTP, respondHTTP, Request, Response, Stream, close, readLine, readBlock, writeBlock, writeBlockWithFile)
import Network
import System.IO
import Data.Array.IO
import Control.Exception as Exception
import Network.HTTP.RedHandler.RequestContext (RequestContext, mkRqCtx)
import Network.HTTP.RedHandler.Handler (IORqHandler, getResponse, anyOf)
import Network.HTTP.RedHandler.Response (BasicRsp)
runHttpServer :: PortNumber -> [IORqHandler BasicRsp] -> IO ()
runHttpServer port hans = withSocketsDo $ do
sock <- listenOn (PortNumber $ port)
forever $ acceptConnection sock $ handleConnection hans
handleConnection :: [IORqHandler BasicRsp] -> Handle -> IO ()
handleConnection rhans h = do requestCtx <- getRequestContext h
response <- runRequestHandler (anyOf rhans) requestCtx
responseSend h response
getRequestContext :: Handle -> IO (Result RequestContext)
getRequestContext h = receiveHTTP h >>= mkRqCtx'
mkRqCtx' :: Result Request-> IO (Result RequestContext)
mkRqCtx' (Left e) = return $ Left e
mkRqCtx' (Right rq) = fmap Right (mkRqCtx rq)
runRequestHandler :: IORqHandler BasicRsp -> Result RequestContext -> IO (Result Response)
runRequestHandler han (Left e) = return $ Left e
runRequestHandler han (Right rq) = fmap Right (getResponse han rq)
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
writeBlockWithFile conn _ filename = sendFile conn filename >>= return . Right
close = hClose
sendFile :: Handle -> String -> IO ()
sendFile conn filename = Exception.bracket
(openFile filename ReadMode)
hClose
(\handle -> squirt handle conn >> hFlush conn)
squirt :: Handle -> Handle -> IO ()
squirt rd wr = do
arr <- newArray_ (0, bufsize1)
let loop = do
r <- hGetArray rd arr bufsize
if (r == 0)
then return ()
else if (r < bufsize)
then hPutArray wr arr r
else hPutArray wr arr bufsize >> loop
loop
where
bufsize = 4 * 1024 :: Int
sniff_received = sniff . ("\n{{Received}}"++)
sniff_sent = sniff . ("\n{{Sent}}"++)
sniff :: String -> IO ()
sniff s = Exception.bracket
(openFile "sniff.log" AppendMode)
hClose
(\hdl -> hPutStr hdl s)