module Network.Web.Server (connection, WebServer, WebConfig(..)) where
import Control.Applicative
import Control.Exception
import qualified Data.ByteString.Char8 as S
import Data.Maybe
import Data.Time
import Network.Web.Date
import qualified Network.Web.HTTP as HTTP (receive,respond)
import Network.Web.HTTP hiding (receive,respond)
import System.IO
import System.Timeout
type WebServer = Maybe Request -> IO Response
data WebConfig = WebConfig {
closedHook :: String -> IO ()
, accessHook :: String -> IO ()
, errorHook :: String -> IO ()
, fatalErrorHook :: String -> IO ()
, connectionTimer :: Int
}
connection :: Handle -> WebServer -> WebConfig -> IO ()
connection hdl srv cnf = session hdl srv cnf `catches` serverError
where
serverError =
[Handler (\e -> closedHook cnf (show (e::ServerException))),
Handler (\e -> errorHook cnf (show (e::SomeException)))]
session :: Handle -> WebServer -> WebConfig -> IO ()
session hdl svr cnf = do
mreq <- recvRequest hdl cnf
rsp <- runServer svr mreq
persist <- sendResponse hdl cnf rsp mreq
case persist of
Close -> closedHook cnf "Connection is closed"
Keep -> session hdl svr cnf
_ -> return ()
where
runServer server mreq = do
date <- utcToDate <$> getCurrentTime
addDate date <$> server mreq
addDate = insertField FkDate
recvRequest :: Handle -> WebConfig -> IO (Maybe Request)
recvRequest hdl cnf = fromMaybe (throw TimeOut) <$> timeout tm (HTTP.receive hdl)
where
microseconds = 1000000
tm = connectionTimer cnf * microseconds
sendResponse :: Handle -> WebConfig -> Response -> Maybe Request -> IO Persist
sendResponse hdl cnf rsp (Just req) = do
let ver = reqVersion req
cnct = lookupField FkConnection req
status = rspStatus rsp
persist = if badStatus status
then Close
else checkPersist ver cnct rsp
hook = accessHook cnf
sendResponse' hdl ver persist rsp hook
sendResponse hdl cnf rsp Nothing = do
let hook = errorHook cnf
sendResponse' hdl HTTP10 Close rsp hook
sendResponse' :: Handle -> Version -> Persist -> Response -> (String -> IO ()) -> IO Persist
sendResponse' hdl ver persist rsp hook = do
HTTP.respond hdl ver persist rsp
hook $ rspLogMsg rsp ++ " [" ++ show (rspStatus rsp) ++ "]"
return persist
checkPersist :: Version -> Maybe S.ByteString -> Response -> Persist
checkPersist HTTP11 Nothing _ = Keep
checkPersist HTTP11 (Just cnct) _
| toPersist cnct == Close = Close
| otherwise = Keep
checkPersist HTTP10 Nothing _ = Close
checkPersist HTTP10 (Just cnct) rsp
| toPersist cnct == Keep = if isJust (rspBody rsp) &&
isNothing (rspLength rsp)
then Close
else Keep
| otherwise = Close