-- ----------------------------------------------------------------------------- -- Copyright 2002, Simon Marlow. -- 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 MimeTypes import Request import Response import ErrorLogger import AccessLogger import ConfigParser import Config hiding (listen) import Util import System import Network.URI import System.Posix import System.Posix.Signals import Network.BSD import IO hiding (bracket) import Control.Exception import Monad import Control.Concurrent import Network.Socket hiding (accept) import Foreign import Foreign.C.Error import Data.IORef import System.Console.GetOpt import Dir {- ----------------------------------------------------------------------------- ToDo: - MAJOR: - deal with http version numbers - timeouts (partly done) - languages - CGI scripts - per-directory permissions (ala apache) - error logging levels - virtual hosts, per-directory config options. - languages (content-language, accept-language) - multipart/byteranges - MINOR: - access logging (various bits left) - implement "listen" (listen on additional ports) - 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) ----------------------------------------------------------------------------- -} -- command-line options data CmdLineOpt = O_ConfigFile String | O_ServerRoot String options = [ Option ['f'] ["config"] (ReqArg O_ConfigFile "filename") "default: \"conf/httpd.conf\"", Option ['d'] ["server-root"] (ReqArg O_ServerRoot "directory") "default: \"/etc/httpd\"" ] usage = "usage: hws [option...]" cmdline :: IORef [CmdLineOpt] cmdline = unsafePerformIO (newIORef (error "no flags")) defaultConfigFile = "conf/httpd.conf" defaultServerRoot = "/home/hws" -- "/etc/httpd" -- ToDo: set this in main serverRoot = unsafePerformIO $ do args <- readIORef cmdline case [ s | O_ServerRoot s <- args] of [] -> return defaultServerRoot (s:_) -> return s configFile = unsafePerformIO $ do args <- readIORef cmdline case [ s | O_ConfigFile s <- args] of [] -> return defaultConfigFile (s:_) -> return s configPath = serverRoot ++ '/':configFile ----------------------------------------------------------------------------- -- Top-level server main = do args <- getArgs case getOpt Permute options args of (flags, [], []) -> do writeIORef cmdline flags main2 (_, _, errs) -> do hPutStr stderr (concat errs) hPutStr stderr (usageInfo usage options) main2 = do main_thread <- myThreadId installHandler sigPIPE Ignore Nothing installHandler sigHUP (Catch (hupHandler main_thread)) Nothing block $ readConfig hupHandler :: ThreadId -> IO () hupHandler main_thread = throwTo main_thread (ErrorCall "**restart**") 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 = do blockSignals sigsToBlock r <- parseConfig configPath case r of Left err -> do hPutStrLn stderr ("failed to parse " ++ configPath) hPutStr stderr (show err) Right b -> do let conf = b defaultConfig initMimeTypes (typesConfig conf) -- read mime.types startErrorLogger conf -- start the error log thread startAccessLogger conf -- start the logging thread my_hostent <- do -- get my hostname/address ent <- getHostEntry case serverName conf of -- Replace the name if "" -> return ent -- serverName is set. n -> return ent{hostName = n} putMVar local_hostent my_hostent topServer conf -- 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 conf = Control.Exception.catch (do unblockSignals sigsToBlock unblock $ do server conf) (\e -> case e of _ | Just (ErrorCall "**restart**") <- fromException e -> do takeMVar local_hostent stopAccessLogger stopErrorLogger readConfig _ | Just ioe <- fromException e -> do let _ = ioe :: IOException logError ("server: " ++ showIOError ioe) topServer conf _other -> do logError ("server: " ++ show e) topServer conf ) -- open the server socket and start accepting connections server conf = do proto <- getProtocolNumber "tcp" Control.Exception.bracket (socket AF_INET Stream proto) (\sock -> sClose sock) (\sock -> do setSocketOption sock ReuseAddr 1 bindSocket sock (SockAddrInet (fromIntegral (port conf)) iNADDR_ANY) listen sock maxListenQueue acceptConnections conf sock ) -- accept connections, and fork off a new thread to handle each one acceptConnections conf sock = do (h, SockAddrInet port haddr) <- accept sock forkIO ( (talk conf h haddr `finally` (hClose h)) `Control.Exception.catch` (\e -> trace ("servlet died: " ++ show (e::SomeException)) (return ())) ) acceptConnections conf sock talk conf h haddr = do hSetBuffering h LineBuffering run conf True h haddr run conf first h haddr = do -- 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 trace "Reading request..." $ do req <- Control.Exception.catch ( timeout time_allowed (do r <- getRequest h return (Just r)) (do -- 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. (if first then response conf h (requestTimeOutResponse conf) else return ()) return Nothing) ) (\e@io -> if isEOFError e then trace "EOF from client" $ return Nothing else do logError ("request: " ++ showIOError io) return Nothing ) case req of { Nothing -> return (); Just r -> trace "Got request" $ do -- tmp: dump out the request #ifdef DEBUG mapM_ (hPutStrLn stderr) r #endif case parseRequest r of -- close the connection after a badly formatted request Bad resp -> do trace (show (resp conf)) $ do response conf h (resp conf) return () Ok req -> do resp <- request conf req trace (show resp) $ do logAccess req resp haddr (error "noTimeDiff"){-ToDo-} response conf 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 req) if ConnectionClose `elem` connection_headers || (reqHTTPVer req < http1_1 && ConnectionKeepAlive `notElem` connection_headers) then return () else run conf False h haddr } -- Read lines up to the first empty line -- ToDo: handle LWS getRequest :: Handle -> IO [String] getRequest h = do l <- hGetLine h if (emptyLine l) then getRequest h else getRequest' l h getRequest' l h = do if (emptyLine l) then return [] else do l' <- hGetLine h ls <- getRequest' l' h return (l:ls) ----------------------------------------------------------------------------- -- Dealing with requests request :: Config -> Request -> IO Response request conf req@Request{reqCmd = cmd} = ( -- make sure we've got a host field -- if the request version is >= HTTP/1.1 case checkHostHeader conf req of Just response -> return (response conf) Nothing -> case cmd of GetReq -> doGet conf req False HeadReq -> doGet conf req True _ -> return (notImplementedResponse conf) ) `Control.Exception.catch` ( \exception -> do logError ("request: " ++ show (exception::SomeException)) return (internalServerErrorResponse conf) ) checkHostHeader conf Request{reqHTTPVer = ver, reqHeaders = headers} = case getHost headers of [] | ver < http1_1 -> Nothing [host] | host == serverName conf || host `elem` serverAlias conf -> Nothing | otherwise -> Just notFoundResponse _ -> Just badRequestResponse doGet conf Request{reqURI = uri, reqHeaders = headers} is_head = case uri of NoURI -> return (badRequestResponse conf) AuthorityURI _ -> return (badRequestResponse conf) AbsPath path -> getFile conf path is_head headers AbsURI uri -> if (uriScheme uri /= "http") -- ToDo: || (authority uri /= host) || (uriQuery uri /= "") || (uriFragment uri /= "") then return (notFoundResponse conf) else getFile conf (uriPath uri) is_head headers getFile conf path is_head headers = do let npath = normPath path -- XXX perhaps better to error if path has colons m_path <- prependDocRoot conf npath case m_path of { Left r -> return r; Right path -> do check <- findRealFilename conf npath path case check of { Left r -> return r; Right (filename,stat) -> do -- check we can actually read this file access <- fileAccess filename True{-read-} False False case access of { False -> return (notFoundResponse conf); -- not "permission denied", we're being paranoid -- about security. True -> do let last_modified = lastModifiedHeader (epochTimeToClockTime (modificationTime stat)) let send_body = not is_head -- XXX here would be a good place to generalize -- dir listings -- cgis (body,content_type) <- if isDirectory stat then createDirListing npath filename else let size = toInteger (fileSize stat) content_type = case mimeTypeOf filename of Nothing -> contentTypeHeader (show (defaultType conf)) Just t -> contentTypeHeader (show t) in return ((FileBody size filename),content_type) return (okResponse conf body [content_type, last_modified] send_body) }}} statFile :: String -> IO (Maybe FileStatus) statFile filename = do maybe_stat <- Control.Exception.try (getFileStatus filename) case maybe_stat of Left e -> do errno <- getErrno if errno == eNOENT then return Nothing else ioError e Right stat -> return (Just stat) -- expand "~user" in the path name prependDocRoot :: Config -> String -> IO (Either Response String) prependDocRoot conf ('/':'~':userpath) | not (null (userDir conf)) = do let (user, path) = break (=='/') userpath u_ent <- Control.Exception.try (getUserEntryForName user) case u_ent of Left e -> let _ = e :: SomeException in return (Left (notFoundResponse conf)) Right ent -> return (Right ('/': homeDirectory ent ++ '/':userDir conf ++ path)) prependDocRoot conf path@('/':_) = do return (Right (documentRoot conf ++ path)) prependDocRoot conf _path = return (Left (notFoundResponse conf)) -- See if the path exists, and if it implicitely references index.html. -- If its a directory without a trailing slash, redirect appropriately. findRealFilename :: Config -> String -> String -> IO (Either Response (String,FileStatus)) findRealFilename conf urlpath filename = do stat <- statFile filename case stat of Nothing -> return (Left (notFoundResponse conf)) Just stat | isDirectory stat -> if (last urlpath == '/') then do let index_filename = filename ++ '/': directoryIndex conf indexstat <- statFile index_filename case indexstat of Nothing -> return (Right (filename,stat)) Just stat -> return (Right (index_filename,stat)) else let dirurl = urlpath ++ "/" in return (Left (movedPermanentlyResponse conf dirurl)) | isRegularFile stat -> return (Right (filename,stat)) | otherwise -> return (Left (notFoundResponse conf)) -- ignore port for now getHost hdrs = [ h | Host h p <- hdrs ] getConnection hdrs = [ c | Connection cs <- hdrs, c <- cs ]