diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/hws.cabal b/hws.cabal new file mode 100644 --- /dev/null +++ b/hws.cabal @@ -0,0 +1,39 @@ +name: hws +version: 1.1 +license: BSD3 +license-file: LICENSE +author: Simon Marlow +maintainer: newsham@lava.net +synopsis: Simple Haskell Web Server + +description: The original Haskell Web Server, as described in the + paper "Developing a high-performance web server in + Concurrent Haskell" (JFP 12(4+5):359--374, July 2002). + + I'm making the package available for archaeological and + illustrative reasons; while this certainly can be used to + serve simple static content, there are other much more + fully-featured web servers and frameworks on Hackage. + +category: Web server +build-type: Simple +cabal-version: >= 1.6 + + +Executable hws + build-depends: base >= 4.2 && < 4.4, + text == 0.7.*, + network == 2.2.*, + haskell98 == 1.0.*, + mtl == 1.1.*, + unix == 2.4.*, + html == 1.0.*, + array == 0.3.*, + old-time == 1.0.*, + directory == 1.0.*, + regex-compat == 0.93.*, + containers == 0.3.* + + main-is: Main.hs + hs-source-dirs: src + extensions: CPP diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,447 @@ +-- ----------------------------------------------------------------------------- +-- 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 ] +