mohws-0.1: src/Main.hs
-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- 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.
-- -----------------------------------------------------------------------------
module Main (main) where
import AccessLogger
import ConfigParser
import Config
import ErrorLogger
import Headers
import MimeTypes
import Options
import Parse
import Request
import Response
import ServerRequest
import ServerState
import StaticModules
import Util
import Control.Concurrent
import Control.Exception as Exception
import Control.Monad
import Data.Maybe
import Network.BSD
import Network.Socket hiding (listen)
import qualified Network.Socket as Socket
import Network.URI
import System.Environment (getArgs)
import System.IO
import System.IO.Error
import System.Posix
import Text.ParserCombinators.Parsec
{- -----------------------------------------------------------------------------
ToDo:
- MAJOR:
- deal with http version numbers
- timeouts (partly done)
- languages
- per-directory permissions (ala apache)
- directory indexing
- error logging levels
- virtual hosts, 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)
- when we get a request for http://foo.com/bar, where 'bar' is a
directory and contains an index.html, we need to send back a
redirect for http://foo.com/bar/ (i.e. add the final slash),
otherwise relative links from index.html will be relative to
http://foo.com/ instead of http://foo.com/bar/. eg. look at
http://www.haskell.org/happy/.
- MAYBE:
- throttling if too many open connections (config: MaxClients)
-}
-----------------------------------------------------------------------------
-- Top-level server
main :: IO ()
main =
do args <- getArgs
case parseOptions args of
Left err -> die err
Right opts -> main2 opts
main2 :: Options -> IO ()
main2 opts =
do main_thread <- myThreadId
installHandler sigPIPE Ignore Nothing
installHandler sigHUP (Catch (hupHandler main_thread)) Nothing
block $ readConfig opts
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 :: Options -> IO ()
readConfig opts = do
blockSignals sigsToBlock
r <- parseConfig (configPath opts)
case r of
Left err -> die $ unlines ["Failed to parse configuration file",
show err]
Right b -> do
let conf = b defaultConfig
st <- initServerState opts conf
topServer st
rereadConfig :: ServerState -> IO ()
rereadConfig st =
do mapM_ stopAccessLogger (serverAccessLoggers st)
stopErrorLogger (serverErrorLogger st)
readConfig (serverOptions st)
initServerState :: Options -> Config -> IO ServerState
initServerState opts conf =
do host <- do ent <- getHostEntry
case serverName conf of
"" -> return ent
n -> return ent { hostName = n }
mimeTypes
<- initMimeTypes (inServerRoot opts (typesConfig conf))
errorLogger
<- startErrorLogger (inServerRoot opts (errorLogFile conf)) (logLevel conf)
accessLoggers
<- sequence [startAccessLogger format (inServerRoot opts file)
| (file,format) <- customLogs conf]
let st = ServerState
{
serverOptions = opts,
serverConfig = conf,
serverHostName = host,
serverPort = error "serverPort not set yet",
serverMimeTypes = mimeTypes,
serverErrorLogger = errorLogger,
serverAccessLoggers = accessLoggers,
serverModules = []
}
foldM loadModule st staticModules
loadModule :: ServerState -> ModuleDesc -> IO ServerState
loadModule st md =
(do logInfo st $ "Loading module " ++ moduleName md ++ "..."
m <- moduleLoad md
moduleLoadConfig m st
return $ st { serverModules = serverModules st ++ [m] })
`Exception.catch`
\e -> do logError st $ unlines ["Error loading module " ++ moduleName md,
show e]
return st
-- 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 :: ServerState -> IO ()
topServer st
= (do unblockSignals sigsToBlock
unblock startServers)
`Exception.catch`
(\e -> do logError st ("server: " ++ show e)
topServer st)
where startServers =
do ts <- servers st
(wait `Exception.catch`
(\e -> case e of
ErrorCall "**restart**" ->
do mapM_ killThread ts
rereadConfig st
_ -> Exception.throw e))
servers :: ServerState -> IO [ThreadId]
servers st =
do addrs <- mapM mkAddr (listen (serverConfig st))
mapM (\ (st',addr) -> forkIO (server st' addr)) addrs
where
mkAddr (maddr,port) =
do addr <- case maddr of
Nothing -> return iNADDR_ANY
Just ip -> inet_addr ip
return (st { serverPort = port },
SockAddrInet (fromIntegral port) addr)
-- open the server socket and start accepting connections
server :: ServerState -> 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 <- 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 :: ServerState -> 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`
(\e -> debug st ("servlet died: " ++ show e))
)
acceptConnections st sock
talk :: ServerState -> Handle -> HostAddress -> IO ()
talk st h haddr = do
debug st "Started"
hSetBuffering h LineBuffering
run st True h haddr
debug st "Done"
run :: ServerState -> Bool -> Handle -> HostAddress -> IO ()
run st first h haddr = do
let conf = serverConfig 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 | first = requestTimeout conf
| otherwise = keepAliveTimeout conf
debug st "Waiting for request..."
req <- catchJust ioErrors (
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 (requestTimeOutResponse 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 pRequestHeaders "Request" r of
-- close the connection after a badly formatted request
Left err -> do
debug st (show err)
response st h (badRequestResponse 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 = getConnection (reqHeaders reqt)
if ConnectionClose `elem` connection_headers
|| (reqHTTPVer reqt < http1_1
&& ConnectionKeepAlive `notElem` connection_headers)
then return ()
else run st False h haddr
}
getBody :: Handle -> Request -> IO Request
getBody h req = do b <- readBody
return $ req { reqBody = b}
where
-- FIXME: handled chunked input
readBody = case getContentLength req of
Nothing -> return ""
-- FIXME: what if input is huge?
Just len -> hGetChars h (fromIntegral len)
-----------------------------------------------------------------------------
-- Dealing with requests
request :: ServerState -> Request -> HostAddress -> IO Response
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 (showResponseLine resp)
logAccess st sreq resp (error "noTimeDiff"){-FIXME-}
return resp
serverRequest :: ServerState -> Request -> HostAddress -> IO (ServerRequest, Maybe Response)
serverRequest st req haddr
= ( do remoteName <- maybeLookupHostname conf haddr
let sreq1 = sreq { clientName = remoteName }
e_host <- getServerHostName st req
case e_host of
Left resp -> return (sreq1, Just resp)
Right host ->
do let sreq2 = sreq1 { requestHostName = host }
e_path <- requestAbsPath st req
case e_path of
Left resp -> return (sreq2, Just resp)
Right pth ->
do let sreq3 = sreq2 { serverURIPath = pth }
e_file <- translatePath st pth
case e_file of
Left resp -> return (sreq3, Just resp)
Right file ->
do let sreq4 = sreq3 { serverFilename = file }
return (sreq4, Nothing)
)
`Exception.catch`
( \exception -> do
logError st ("request: " ++ show exception)
return (sreq, Just (internalServerErrorResponse conf))
)
where conf = serverConfig st
sreq = ServerRequest {
clientRequest = req,
clientAddress = haddr,
clientName = Nothing,
requestHostName = serverHostName st,
serverURIPath = "-",
serverFilename = "-"
}
maybeLookupHostname :: Config -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname conf haddr =
if hostnameLookups conf
then catchJust ioErrors (liftM Just (getHostByAddr AF_INET haddr))
(\_ -> return Nothing)
else return Nothing
-- make sure we've got a host field
-- if the request version is >= HTTP/1.1
getServerHostName :: ServerState -> Request -> IO (Either Response HostEntry)
getServerHostName st req
= case getHost req of
Nothing | reqHTTPVer req < http1_1
-> return $ Right (serverHostName st)
| otherwise
-> return $ Left (badRequestResponse conf)
Just (host,_)
| isServerHost host
-> return $ Right ((serverHostName st) { hostName = host })
| otherwise
-> do logError st ("Unknown host: " ++ show host)
return $ Left $ notFoundResponse conf
where conf = serverConfig st
isServerHost host = host `elem` (serverName conf:serverAlias conf)
-- | Get the absolute path from the request.
-- TODO: do something about virtual hosts?
requestAbsPath :: ServerState -> Request -> IO (Either Response String)
requestAbsPath _ req = return $ Right $ uriPath $ reqURI req
-- Path translation
translatePath :: ServerState -> String -> IO (Either Response FilePath)
translatePath st pth =
do m_file <- tryModules st (\m -> moduleTranslatePath m st pth)
case m_file of
Just file -> return $ Right file
Nothing -> defaultTranslatePath st pth
defaultTranslatePath :: ServerState -> String -> IO (Either Response FilePath)
defaultTranslatePath st pth =
case pth of
'/':_ -> return $ Right $ documentRoot conf ++ pth
_ -> return $ Left $ notFoundResponse conf
where conf = serverConfig st
-- Request tweaking
tweakRequest :: ServerState -> ServerRequest -> IO ServerRequest
tweakRequest st = foldModules st (\m r -> moduleTweakRequest m st r)
-- Request handling
handleRequest :: ServerState -> ServerRequest -> IO Response
handleRequest st req =
do m_resp <- tryModules st (\m -> moduleHandleRequest m st req)
case m_resp of
Just resp -> return resp
Nothing -> defaultHandleRequest st req
defaultHandleRequest :: ServerState -> ServerRequest -> IO Response
defaultHandleRequest st _ = return $ notFoundResponse $ serverConfig st
-- Sending response
response :: ServerState
-> Handle
-> Response
-> IO ()
response _ h (Response { respCode = code,
respDesc = desc,
respHeaders = headers,
respCoding = tes,
respBody = body,
respSendBody = send_body }) =
do
hPutStrCrLf h (statusLine code desc)
hPutHeader h serverHeader
-- Date Header: required on all messages
date <- dateHeader
hPutHeader h date
mapM_ (hPutHeader h) (listHeaders 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 content_length = responseBodyLength body
when (hasBody body && null tes)
(hPutHeader h (contentLengthHeader content_length))
mapM_ (hPutHeader h . transferCodingHeader) tes
hPutStrCrLf h ""
-- ToDo: implement transfer codings
if send_body
then sendBody h body
else return ()
hPutHeader :: Handle -> Header -> IO ()
hPutHeader h = hPutStrCrLf h . show