module Network.Web.Server (connection, WebServer, WebConfig(..)) where
import Control.Exception
import Control.Monad
import Control.Applicative
import Data.Char
import Data.Maybe
import Data.Time
import IO
import Network.Web.HTTP hiding (receive,respond)
import qualified Network.Web.HTTP as HTTP (receive,respond)
import Network.Web.Date
import Network.Web.Params
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 date rsp = insertField FkDate date rsp
recvRequest :: Handle -> WebConfig -> IO (Maybe Request)
recvRequest hdl cnf = do
mmreq <- timeout tm (HTTP.receive hdl)
case mmreq of
Nothing -> throw TimeOut
Just mreq -> return mreq
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 String -> Response -> Persist
checkPersist HTTP11 Nothing _ = Keep
checkPersist HTTP11 (Just cnct) _
| read cnct == Close = Close
| otherwise = Keep
checkPersist HTTP10 Nothing _ = Close
checkPersist HTTP10 (Just cnct) rsp
| read cnct == Keep = if isJust (rspBody rsp) &&
isNothing (rspLength rsp)
then Close
else Keep
| otherwise = Close