mohws-0.2.1: src/Network/MoHWS/Server.hs
-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- * Neither the name of the copyright holder(s) nor the names of
-- contributors may be used to endorse or promote products derived from
-- this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}
module Network.MoHWS.Server (main, mainWithOptions, ) where
import qualified Network.MoHWS.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Environment as ServerEnv
import qualified Network.MoHWS.Server.Context as ServerContext
import Network.MoHWS.Logger.Error (debug, logError, logInfo, )
import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Logger.Access as AccessLogger
import qualified Network.MoHWS.Logger.Error as ErrorLogger
import qualified Network.MoHWS.Configuration.Parser as ConfigParser
import Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.Initialization as Init
import qualified Network.MoHWS.HTTP.MimeType as MimeType
import qualified Network.MoHWS.Server.Options as Options
import Network.MoHWS.ParserUtility (getUntilEmptyLine, )
import qualified Network.MoHWS.HTTP.Version as Version
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Request as Request
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Stream as Stream
import qualified Network.MoHWS.Utility as Util
import Data.Monoid (mempty, )
import Data.Maybe (catMaybes, )
import Data.Tuple.HT (swap, )
import Data.List.HT (viewR, )
import qualified Data.Set as Set
import Control.Monad.Trans.State (StateT, runStateT, modify, )
import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Exception as Exception
import Control.Monad.Trans.Class (lift, )
import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, )
import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, )
import Control.Exception (ErrorCall(ErrorCall), finally, mask, )
import Control.Monad (liftM, when, )
import Network.BSD
import Network.Socket hiding (listen)
import qualified Network.Socket as Socket
import Network.URI (uriPath, )
import System.Environment (getArgs, )
import System.IO
import System.IO.Error (isAlreadyInUseError, isEOFError, )
import System.Posix
import Text.ParserCombinators.Parsec (parse, choice, )
{- -----------------------------------------------------------------------------
ToDo:
- MAJOR:
- deal with http version numbers
- timeouts (partly done)
- languages
- per-directory permissions (ala apache)
- error logging levels
- per-directory config options.
- languages (content-language, accept-language)
- multipart/byteranges
- MINOR:
- access logging (various bits left)
- implement user & group setting
- log time to serve request
- terminate & restart signal (like Apache's SIGHUP)
- don't die if the new configuration file contains errors after a restart
- reading config file may block, unsafe if we receive another SIGHUP
- common up headers with same name (eg. accept).
- implement if-modified-since (need to parse time)
- MAYBE:
- throttling if too many open connections (config: MaxClients)
-}
-----------------------------------------------------------------------------
-- Top-level server
main :: (Stream.C body) =>
Init.T body ext -> IO ()
main initExt =
do args <- getArgs
case Options.parse args of
Left err -> Util.die err
Right opts -> mainWithOptions initExt opts
mainWithOptions :: (Stream.C body) =>
Init.T body ext -> Options.T -> IO ()
mainWithOptions initExt opts =
do main_thread <- myThreadId
_ <- installHandler sigPIPE Ignore Nothing
_ <- installHandler sigHUP (Catch (hupHandler main_thread)) Nothing
mask (readConfig initExt opts)
type Unblock a = IO a -> IO a
hupHandler :: ThreadId -> IO ()
hupHandler main_thread =
throwTo main_thread (ErrorCall "**restart**")
sigsToBlock :: SignalSet
sigsToBlock = addSignal sigHUP emptySignalSet
-- Async exceptions should be blocked on entry to readConfig (so that
-- multiple SIGHUPs close together can't kill us). Make sure that
-- there aren't any interruptible operations until we've blocked signals.
readConfig :: (Stream.C body) =>
Init.T body ext -> Options.T -> (forall a. Unblock a) -> IO ()
readConfig initExt opts unblock = do
blockSignals sigsToBlock
r <- ConfigParser.run
(choice $ map ModuleDesc.configParser $ Init.moduleList initExt)
(Options.configPath opts)
case r of
Left err ->
Util.die $ unlines $
"Failed to parse configuration file" : show err : []
Right b -> do
let updates = map ModuleDesc.setDefltConfig $ Init.moduleList initExt
confExtDeflt =
foldl (flip ($)) (Init.configurationExtensionDefault initExt) updates
conf = b (Config.deflt confExtDeflt)
st <- initServerState opts conf
mods <- fmap catMaybes $ mapM (loadModule st) $ Init.moduleList initExt
topServer st mods initExt unblock
rereadConfig :: (Stream.C body) =>
ServerContext.T ext -> Init.T body ext -> (forall a. Unblock a) -> IO ()
rereadConfig st initExt unblock =
do mapM_ AccessLogger.stop (ServerContext.accessLoggers st)
ErrorLogger.stop (ServerContext.errorLogger st)
readConfig initExt (ServerContext.options st) unblock
initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext)
initServerState opts conf =
do host <- do ent <- getHostEntry
case serverName conf of
"" -> return ent
n -> return ent { hostName = n }
mimeTypes
<- MimeType.loadDictionary (Options.inServerRoot opts (typesConfig conf))
errorLogger
<- ErrorLogger.start (Options.inServerRoot opts (errorLogFile conf)) (logLevel conf)
accessLoggers
<- sequence [AccessLogger.start format (Options.inServerRoot opts file)
| (file,format) <- customLogs conf]
let st = ServerContext.Cons
{
ServerContext.options = opts,
ServerContext.config = conf,
ServerContext.hostName = host,
ServerContext.mimeTypes = mimeTypes,
ServerContext.errorLogger = errorLogger,
ServerContext.accessLoggers = accessLoggers
}
return st
loadModule :: (Stream.C body) =>
ServerContext.T ext -> ModuleDesc.T body ext -> IO (Maybe (Module.T body))
loadModule st md =
(do logInfo st $ "Loading module " ++ ModuleDesc.name md ++ "..."
fmap Just $ ModuleDesc.load md st)
`Exception.catch`
\(Exception.SomeException e) ->
do logError st $ unlines ["Error loading module " ++ ModuleDesc.name md,
show e]
return Nothing
-- We catch exceptions from the main server thread, and restart the
-- server. If we receive a restart signal (from a SIGHUP), then we
-- re-read the configuration file.
topServer :: (Stream.C body) =>
ServerContext.T ext -> [Module.T body] -> Init.T body ext -> (forall a. Unblock a) -> IO ()
topServer st mods initExt unblock =
let startServers =
do ts <- servers st mods
(Util.wait `Exception.catch`
(\e -> case e of
ErrorCall "**restart**" ->
do mapM_ killThread ts
rereadConfig st initExt unblock
_ -> Exception.throw e))
loop =
(do unblockSignals sigsToBlock
unblock startServers)
`Exception.catch`
(\(Exception.SomeException e) ->
do logError st ("server: " ++ show e)
loop)
in loop
servers :: (Stream.C body) =>
ServerContext.T ext -> [Module.T body] -> IO [ThreadId]
servers st mods =
let mkEnv port =
ServerEnv.Cons {
ServerEnv.context = st,
ServerEnv.modules = mods,
ServerEnv.port = port
}
mkAddr (maddr,port) =
do addr <- case maddr of
Nothing -> return iNADDR_ANY
Just ip -> inet_addr ip
return (mkEnv port, SockAddrInet port addr)
in do addrs <- mapM mkAddr (listen (ServerContext.config st))
mapM (\ (env,addr) -> forkIO (server env addr)) addrs
-- open the server socket and start accepting connections
server :: (Stream.C body) =>
ServerEnv.T body ext -> SockAddr -> IO ()
server st addr = do
logInfo st $ "Starting server thread on " ++ show addr
proto <- getProtocolNumber "tcp"
Exception.bracket
(socket AF_INET Stream proto)
(\sock -> sClose sock)
(\sock -> do setSocketOption sock ReuseAddr 1
ok <- Util.catchSomeIOErrors isAlreadyInUseError
(bindSocket sock addr >> return True)
(\e -> do logError st ("server: " ++ show e)
hPutStrLn stderr $ show e
return False)
when ok $ do Socket.listen sock maxListenQueue
acceptConnections st sock
)
-- accept connections, and fork off a new thread to handle each one
acceptConnections :: (Stream.C body) =>
ServerEnv.T body ext -> Socket -> IO ()
acceptConnections st sock = do
debug st "Calling accept..."
(h, SockAddrInet port haddr) <- Util.accept sock
inet_ntoa haddr >>=
\ip -> debug st $ "Got connection from " ++ ip ++ ":" ++ show port
_ <- forkIO (
(talk st h haddr `finally` hClose h)
`Exception.catch`
(\(Exception.SomeException e) ->
debug st ("servlet died: " ++ show e))
)
acceptConnections st sock
talk :: (Stream.C body) =>
ServerEnv.T body ext -> Handle -> HostAddress -> IO ()
talk st h haddr = do
debug st "Started"
hSetBuffering h LineBuffering
run st True h haddr
debug st "Done"
run :: (Stream.C body) =>
ServerEnv.T body ext -> Bool -> Handle -> HostAddress -> IO ()
run st first h haddr = do
let conf = ServerEnv.config st
-- read a request up to the first empty line. If we
-- don't get a request within the alloted time, issue
-- a "Request Time-out" response and close the connection.
let time_allowed =
if first
then requestTimeout conf
else keepAliveTimeout conf
debug st "Waiting for request..."
req <- catch (
do ok <- hWaitForInput h (time_allowed * 1000)
if ok then liftM Just (getUntilEmptyLine h)
-- only send a "request timed out" response if this
-- was the first request on the socket. Subsequent
-- requests time-out and close the socket silently.
-- ToDo: if we get a partial request, still emit the
-- the timeout response.
else do debug st $ "Request timeout (after " ++ show time_allowed ++ " s)"
when first (response st h (Response.makeRequestTimeOut conf))
return Nothing
)
(\e ->
if isEOFError e
then debug st "EOF from client" >> return Nothing
else do logError st ("request: " ++ show e)
return Nothing )
case req of { Nothing -> return (); Just r -> do
case parse Request.pHeaders "Request" r of
-- close the connection after a badly formatted request
Left err -> do
debug st (show err)
response st h (Response.makeBadRequest conf)
return ()
Right req_no_body -> do
reqt <- getBody h req_no_body
debug st $ show reqt
resp <- request st reqt haddr
response st h resp
-- Persistent Connections
--
-- We close the connection if
-- (a) client specified "connection: close"
-- (b) client is pre-HTTP/1.1, and didn't
-- specify "connection: keep-alive"
let connection_headers = Request.getConnection (Request.headers reqt)
if Request.ConnectionClose `elem` connection_headers
|| (Request.httpVersion reqt < Version.http1_1
&& Request.ConnectionKeepAlive `notElem` connection_headers)
then return ()
else run st False h haddr
}
getBody :: (Stream.C body) =>
Handle -> Request.T body -> IO (Request.T body)
getBody h req =
let -- FIXME: handled chunked input
readBody =
case Header.getContentLength req of
Nothing -> return mempty
-- FIXME: what if input is huge?
Just len -> Stream.read h len
in do b <- readBody
return $ req { Request.body = b}
-----------------------------------------------------------------------------
-- Dealing with requests
request :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (Response.T body)
request st req haddr =
do (sreq,merr) <- serverRequest st req haddr
resp <- case merr of
Nothing -> do sreq' <- tweakRequest st sreq
debug st $ "Handling request..."
handleRequest st sreq'
Just err -> return err
debug st (Response.showStatusLine resp)
ServerEnv.logAccess st sreq resp (error "noTimeDiff"){-FIXME-}
return resp
serverRequest :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (ServerRequest.T body, Maybe (Response.T body))
serverRequest st req haddr =
let conf = ServerEnv.config st
sreq =
ServerRequest.Cons {
ServerRequest.clientRequest = req,
ServerRequest.clientAddress = haddr,
ServerRequest.clientName = Nothing,
ServerRequest.requestHostName = ServerEnv.hostName st,
ServerRequest.serverURIPath = "-",
ServerRequest.serverFilename = "-",
ServerRequest.serverPort = ServerEnv.port st
}
maybeExc x =
case x of
Exc.Success _ -> Nothing
Exc.Exception e -> Just e
in fmap swap (runStateT
(fmap maybeExc $ runExceptionalT $ serverRequestExc st req haddr) sreq)
`Exception.catch`
( \(Exception.SomeException exception) -> do
logError st ("request: " ++ show exception)
return (sreq, Just (Response.makeInternalServerError conf))
)
serverRequestExc :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress -> ExceptionalT (Response.T body) (StateT (ServerRequest.T body) IO) ()
serverRequestExc st req haddr =
let conf = ServerEnv.config st
use = Exc.mapExceptionalT lift
update = lift . modify
in do remoteName <- use $ lift $ maybeLookupHostname conf haddr
update $ \sreq -> sreq { ServerRequest.clientName = remoteName }
host <- use $ getServerHostName st req
update $ \sreq -> sreq { ServerRequest.requestHostName = host }
path <- use $ requestAbsPath st req
update $ \sreq -> sreq { ServerRequest.serverURIPath = path }
file <- use $ translatePath st (hostName host) path
update $ \sreq -> sreq { ServerRequest.serverFilename = file }
maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname conf haddr =
if hostnameLookups conf
then catch
(liftM Just (getHostByAddr AF_INET haddr))
(\_ -> return Nothing)
else return Nothing
type EIO body = ExceptionalT (Response.T body) IO
-- make sure we've got a host field
-- if the request version is >= HTTP/1.1
getServerHostName :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> EIO body HostEntry
getServerHostName st req =
let conf = ServerEnv.config st
isServerHost host =
host `Set.member` (Set.insert (serverName conf) $ serverAlias conf) ||
any (flip Module.isServerHost host) (ServerEnv.modules st)
in case Request.getHost req of
Nothing ->
if Request.httpVersion req < Version.http1_1
then return $ ServerEnv.hostName st
else Exc.throwT $ Response.makeBadRequest conf
Just (host,_) ->
if isServerHost host
then return $ (ServerEnv.hostName st) { hostName = host }
else do lift $ logError st ("Unknown host: " ++ show host)
Exc.throwT $ Response.makeNotFound conf
-- | Get the absolute path from the request.
requestAbsPath :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> EIO body String
requestAbsPath _ req = return $ uriPath $ Request.uri req
-- Path translation
translatePath :: (Stream.C body) =>
ServerEnv.T body ext -> String -> String -> EIO body FilePath
translatePath st host pth =
do m_file <- lift $ ServerEnv.tryModules st (\m -> Module.translatePath m host pth)
case m_file of
Just file -> return $ file
Nothing -> defaultTranslatePath st pth
defaultTranslatePath :: (Stream.C body) =>
ServerEnv.T body ext -> String -> EIO body FilePath
defaultTranslatePath st pth =
let conf = ServerEnv.config st
in case pth of
'/':_ -> return $ documentRoot conf ++ pth
_ -> Exc.throwT $ Response.makeNotFound conf
-- Request tweaking
tweakRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (ServerRequest.T body)
tweakRequest st =
ServerEnv.foldModules st (\m r -> Module.tweakRequest m r)
-- Request handling
handleRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
handleRequest st req =
do m_resp <- ServerEnv.tryModules st (\m -> Module.handleRequest m req)
case m_resp of
Just resp -> return resp
Nothing -> defaultHandleRequest st req
defaultHandleRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
defaultHandleRequest st _ =
return $ Response.makeNotFound $ ServerEnv.config st
-- Sending response
response :: (Stream.C body) =>
ServerEnv.T body ext ->
Handle ->
Response.T body ->
IO ()
response env h
(Response.Cons {
Response.code = code,
Response.description = desc,
Response.headers = headers,
Response.coding = tes,
Response.body = body,
Response.doSendBody = sendBody
}) =
do
Util.hPutStrCrLf h (Response.statusLine code desc)
hPutHeader h Response.serverHeader
-- Date Header: required on all messages
date <- Response.dateHeader
hPutHeader h date
mapM_ (hPutHeader h) (Header.list headers)
-- Output a Content-Length when the message body isn't
-- encoded. If it *is* encoded, then the last transfer
-- coding must be "chunked", according to RFC2616 sec 3.6. This
-- allows the client to determine the message-length.
let contentLength = Response.size body
when (Response.hasBody body && null tes)
(maybe (return ()) (hPutHeader h . Header.makeContentLength) contentLength)
mapM_ (hPutHeader h . Header.makeTransferCoding) tes
Util.hPutStrCrLf h ""
-- ToDo: implement transfer codings
let conf = ServerEnv.config env
when sendBody $
case viewR tes of
Just (_, Header.ChunkedTransferCoding) ->
Response.sendBodyChunked (Config.chunkSize conf) h body
_ -> Response.sendBody h body
hPutHeader :: Handle -> Header.T -> IO ()
hPutHeader h =
hPutStr h . show
-- Util.hPutStrCrLf h . show