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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,68 @@ +This is a web server written in Haskell, based on Simon Marlow's original +Haskell Web Server. It has a module system and can run CGI programs. + +The original program is described in: +Developing a high-performance web server in Concurrent Haskell, +Simon Marlow, +Journal of Functional Programming, 12(4+5):359--374, July 2002 +[http://www.haskell.org/~simonmar/papers/web-server-jfp.pdf] + +The original version available from: +[http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/hws/] + +A more conservative update of the original HWS is available from: +[http://darcs.haskell.org/hws/] + + +=== Build === + +You can use either Cabal or make to build HWS. + +==== With Cabal ==== + +{{{pre: +$ runghc Setup.hs configure +$ runghc Setup.hs build +}}} + +This produces the binary ``dist/build/hws/hws``. + +==== With make ==== + +{{{pre: +$ make +}}} + +This produces the binary ``./hws``. + + +=== Configure === + +There is a config file example in ``conf/httpd.conf``. The server should run with the +example settings, but it would not be very usable. See the example file +for more information about the configuration parameters. + + +=== Run === + +{{{pre: +usage: hws [option...] + -f filename --config=filename default: "conf/httpd.conf" + -d directory --server-root=directory default: "." +}}} + +The server root is the directory which hws uses as base for the +configuration and log file paths. + +Files are served from the DocumentRoot. + + +==== CGI ==== + +Files which have the filename suffix ``.cgi`` are run as CGI programs. + + +==== Debug ==== + +Look in the error log file (``log/error.log`` by default) for any error messages. +If this does not help, try setting LogLevel to debug (in the config file). diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/mohws.cabal b/mohws.cabal new file mode 100644 --- /dev/null +++ b/mohws.cabal @@ -0,0 +1,41 @@ +Name: mohws +Version: 0.1 +Author: Simon Marlow, Bjorn Bringert +Copyright: Simon Marlow, Bjorn Bringert +Maintainer: Bjorn Bringert +License: BSD3 +License-file: LICENSE +Category: Web +Synopsis: Modular Haskell Web Server +Description: + A web server with a module system and support for CGI. + Based on Simon Marlow's original Haskell Web Server. +Homepage: http://code.haskell.org/mohws/ + +Build-depends: + base>3, + directory, + network, + unix, + parsec, + html, + process, + containers, + old-time, + old-locale, + array +Data-files: README +Tested-with: GHC==6.8.2 +Build-Type: Simple + +Executable: hws +Main-is: Main.hs +Hs-source-dirs: src +Ghc-options: -threaded -Wall +Extensions: CPP +other-modules: Options, AccessLogger, LogLevel, Headers, + Main, StaticModules, Parse, ErrorLogger, + MimeTypes, Config, ServerState, Logger, Util + Request, Response, ServerRequest, Module.Index, + Module.DynHS, Module.File, Module.DynHS, Module.DynHS.CGI, + Module.DynHS.GHCUtil, Module.Userdir, Module.CGI, ConfigParser diff --git a/src/AccessLogger.hs b/src/AccessLogger.hs new file mode 100644 --- /dev/null +++ b/src/AccessLogger.hs @@ -0,0 +1,129 @@ +-- ----------------------------------------------------------------------------- +-- 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 AccessLogger ( + AccessLoggerHandle, + AccessLogRequest(..), + startAccessLogger, + stopAccessLogger, + mkAccessLogRequest, + logAccessLogRequest + ) where + +import Logger +import Headers +import Response +import ServerRequest +import Util + +import Network.BSD (HostEntry, hostName) +import Network.Socket (inet_ntoa) +import System.Time +import System.IO.Unsafe (unsafePerformIO) + +type AccessLoggerHandle = LoggerHandle AccessLogRequest + +data AccessLogRequest = AccessLogRequest + { + log_request :: ServerRequest, + log_response :: Response, + log_server_host :: HostEntry, + log_time :: ClockTime, + log_delay :: TimeDiff + } + + +startAccessLogger :: String -> FilePath -> IO AccessLoggerHandle +startAccessLogger format file = startLogger f file + where f = mkLogLine format + +mkLogLine :: String -> AccessLogRequest -> String +mkLogLine "" _ = "" +mkLogLine ('%':'{':rest) r = + case span (/= '}') rest of + (str, '}':c:rest1) -> expand (Just str) c r ++ mkLogLine rest1 r + _ -> '%':'{':mkLogLine rest r +mkLogLine ('%':c:rest) r = expand Nothing c r ++ mkLogLine rest r +mkLogLine (c:rest) r = c : mkLogLine rest r + +expand :: Maybe String -> Char -> AccessLogRequest -> String +expand arg c info = + case c of + 'b' -> let len = responseBodyLength (respBody resp) + in if len == 0 then "-" else show len + 'f' -> serverFilename sreq + + -- %h is the hostname if hostnameLookups is on, otherwise the + -- IP address. + 'h' -> maybe addr hostName (clientName sreq) + 'a' -> addr + 'l' -> "-" -- FIXME: does anyone use identd these days? + 'r' -> show req + -- ToDo: 'p' -> canonical port number of server + 's' -> show (respCode resp) + 't' -> formatTimeSensibly (toUTCTime (log_time info)) + 'T' -> timeDiffToString (log_delay info) + 'v' -> hostName (log_server_host info) + 'u' -> "-" -- FIXME: implement HTTP auth + + 'i' -> header req arg + 'o' -> header resp arg + + -- ToDo: other stuff + _ -> ['%',c] + where + resp = log_response info + sreq = log_request info + req = clientRequest sreq +-- host = clientName (log_request info) + header _ Nothing = "" + header x (Just n) = unwords (lookupHeaders (mkHeaderName n) x) + addr = unsafePerformIO (inet_ntoa (clientAddress sreq)) + +stopAccessLogger :: AccessLoggerHandle -> IO () +stopAccessLogger l = stopLogger l + +mkAccessLogRequest :: ServerRequest -> Response -> HostEntry -> TimeDiff -> IO AccessLogRequest +mkAccessLogRequest req resp host delay = + do time <- getClockTime + return $ AccessLogRequest + { + log_request = req, + log_response = resp, + log_server_host = host, + log_time = time, + log_delay = delay + } + +logAccessLogRequest :: AccessLoggerHandle -> AccessLogRequest -> IO () +logAccessLogRequest l r = logMessage l r diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,116 @@ +-- ----------------------------------------------------------------------------- +-- 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 Config where + +import LogLevel + +----------------------------------------------------------------------------- +-- Config info + +data Config = Config { + user :: String, + group :: String, + + listen :: [(Maybe String,Int)], + + requestTimeout :: Int, + keepAliveTimeout :: Int, + maxClients :: Int, + + serverAdmin :: String, -- "" indicates no admin + serverName :: String, -- "" indicates no canon name + serverAlias :: [String], + useCanonicalName :: Bool, + hostnameLookups :: Bool, + + documentRoot :: String, + userDir :: String, + directoryIndex :: String, + accessFileName :: String, + indexes :: Bool, + followSymLinks :: Bool, + + typesConfig :: String, + defaultType :: String, + + addLanguage :: [(String,String)], + languagePriority :: [String], + + customLogs :: [(FilePath, String)], + + errorLogFile :: String, + logLevel :: LogLevel + } + deriving Show + +defaultConfig :: Config +defaultConfig = Config{ + user = "nobody", + group = "nobody", + + listen = [(Nothing,80)], + + requestTimeout = 300, + keepAliveTimeout = 15, + maxClients = 150, + + serverAdmin = "", + serverName = "", + serverAlias = [], + useCanonicalName = False, + hostnameLookups = False, + + documentRoot = ".", + userDir = "", + directoryIndex = "index.html", + accessFileName = ".htaccess", + indexes = False, + followSymLinks = False, + + typesConfig = "/etc/mime.types", + defaultType = "text/plain", + + addLanguage = [], + languagePriority = [], + + customLogs = [("http-access.log", + "%h %l %u %t \"%r\" %s %b \"%{Referer}i\" \"%{User-Agent}i\"")], + + errorLogFile = "httpd-error.log", + logLevel = LogWarn + } + +-- not user-definable... +serverSoftware, serverVersion :: String +serverSoftware = "HWS" +serverVersion = "0.1" diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs new file mode 100644 --- /dev/null +++ b/src/ConfigParser.hs @@ -0,0 +1,177 @@ +-- ----------------------------------------------------------------------------- +-- 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 ConfigParser (parseConfig) where + +import Config +import Parse +import Util + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language +import Text.ParserCombinators.Parsec.Token + + +type ConfigBuilder = Config -> Config + +p :: TokenParser st +p = makeTokenParser tokenDef + +tokenDef :: LanguageDef st +tokenDef = emptyDef { + commentLine = "#", + nestedComments = False, + reservedOpNames = [], + reservedNames = [], + caseSensitive = False + } + + +parseConfig :: String -> IO (Either ParseError ConfigBuilder) +parseConfig fname + = parseFromFile configParser fname + +configParser :: Parser ConfigBuilder +configParser = do + whiteSpace p + cs <- many configLine + eof + return (fixConfig . foldr (.) id cs) + +fixConfig :: Config -> Config +fixConfig conf = conf { listen = f (listen conf) } + where f xs | length xs > 1 = init xs + | otherwise = xs + +configLine :: Parser ConfigBuilder +configLine + = do (reserved p "user" >> p_user) + <|> (reserved p "group" >> p_group) + <|> (reserved p "timeout" >> p_timeout) + <|> (reserved p "keepalivetimeout" >> p_keepAliveTimeout) + <|> (reserved p "maxclients" >> p_maxClients) + <|> (reserved p "listen" >> p_listen) + <|> (reserved p "serveradmin" >> p_serverAdmin) + <|> (reserved p "servername" >> p_serverName) + <|> (reserved p "serveralias" >> p_serverAlias) + <|> (reserved p "usecanonicalname" >> p_useCanonicalName) + <|> (reserved p "documentroot" >> p_documentRoot) + <|> (reserved p "userdir" >> p_userDir) + <|> (reserved p "directoryindex" >> p_directoryIndex) + <|> (reserved p "accessfilename" >> p_accessFileName) + <|> (reserved p "typesconfig" >> p_typesConfig) + <|> (reserved p "defaulttype" >> p_defaultType) + <|> (reserved p "hostnamelookups" >> p_hostnameLookups) + <|> (reserved p "errorlog" >> p_errorLog) + <|> (reserved p "loglevel" >> p_logLevel) + <|> (reserved p "customlog" >> p_customLog) + <|> (reserved p "listen" >> p_listen) + <|> (reserved p "addlanguage" >> p_addlanguage) + <|> (reserved p "languagepriority" >> p_languagepriority) + +p_user :: GenParser Char st (Config -> Config) +p_user = do str <- stringLiteral p; return (\c -> c{user = str}) +p_group :: GenParser Char st (Config -> Config) +p_group = do str <- stringLiteral p; return (\c -> c{group = str}) +p_timeout :: GenParser Char () (Config -> Config) +p_timeout = do i <- int; return (\c -> c{requestTimeout = i}) +p_keepAliveTimeout :: GenParser + Char () (Config -> Config) +p_keepAliveTimeout = do i <- int; return (\c -> c{keepAliveTimeout = i}) +p_maxClients :: GenParser Char () (Config -> Config) +p_maxClients = do i <- int; return (\c -> c{maxClients = i}) +p_serverAdmin :: GenParser Char st (Config -> Config) +p_serverAdmin = do str <- stringLiteral p; return (\c -> c{serverAdmin = str}) +p_serverName :: GenParser Char st (Config -> Config) +p_serverName = do str <- stringLiteral p; return (\c -> c{serverName = str}) +p_serverAlias :: GenParser Char st (Config -> Config) +p_serverAlias = do str <- stringLiteral p + return (\c -> c{serverAlias = str : serverAlias c}) +p_useCanonicalName :: GenParser Char st (Config -> Config) +p_useCanonicalName = do b <- bool; return (\c -> c{useCanonicalName = b}) +p_documentRoot :: GenParser Char st (Config -> Config) +p_documentRoot = do str <- stringLiteral p; return (\c -> c{documentRoot = str}) +p_userDir :: GenParser Char st (Config -> Config) +p_userDir = do str <- stringLiteral p; return (\c -> c{userDir = str}) +p_directoryIndex :: GenParser Char st (Config -> Config) +p_directoryIndex = do str <- stringLiteral p; return (\c -> c{directoryIndex = str}) +p_accessFileName :: GenParser Char st (Config -> Config) +p_accessFileName = do str <- stringLiteral p; return (\c -> c{accessFileName = str}) +p_typesConfig :: GenParser Char st (Config -> Config) +p_typesConfig = do str <- stringLiteral p; return (\c -> c{typesConfig = str}) +p_defaultType :: GenParser Char st (Config -> Config) +p_defaultType = do str <- stringLiteral p; return (\c -> c{defaultType = str}) + +p_hostnameLookups :: GenParser Char st (Config -> Config) +p_hostnameLookups = do b <- bool; return (\c -> c{hostnameLookups = b}) +p_errorLog :: GenParser Char st (Config -> Config) +p_errorLog = do str <- stringLiteral p; return (\c -> c{errorLogFile = str}) + +p_logLevel :: GenParser Char st (Config -> Config) +p_logLevel = do i <- identifier p >>= readM + return (\c -> c{logLevel = i}) + +p_customLog :: GenParser Char st (Config -> Config) +p_customLog = do file <- stringLiteral p + format <- stringLiteral p + return (\c -> c { customLogs = (file,format) : customLogs c}) + +p_listen :: GenParser Char () (Config -> Config) +p_listen = do maddr <- p_addr + port <- int + return (\c -> c{ listen = (maddr,port) : listen c}) + where + p_addr = option Nothing $ try $ do addr <- p_ip_addr + char ':' + return $ Just addr + p_ip_addr = do b1 <- p_dec_byte + char '.' + b2 <- p_dec_byte + char '.' + b3 <- p_dec_byte + char '.' + b4 <- p_dec_byte + return (b1++"."++b2++"."++b3++"."++b4) + p_dec_byte = countBetween 1 3 digit + +p_addlanguage :: GenParser Char st (Config -> Config) +p_addlanguage = do lang <- stringLiteral p; ext <- stringLiteral p; return (\c -> c{addLanguage = (lang,ext) : addLanguage c}) +p_languagepriority :: GenParser Char st (Config -> Config) +p_languagepriority = do langs <- many (stringLiteral p); return (\c -> c{languagePriority = langs}) + +bool :: GenParser Char st Bool +bool = do { reserved p "On"; return True } + <|> do { reserved p "Off"; return False } + +int :: Parser Int +int = do i <- integer p; return (fromInteger i) + diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs new file mode 100644 --- /dev/null +++ b/src/ErrorLogger.hs @@ -0,0 +1,82 @@ +-- ----------------------------------------------------------------------------- +-- 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 ErrorLogger ( + ErrorLoggerHandle, + startErrorLogger, + stopErrorLogger, + logErrorMessage + ) where + +import Logger +import LogLevel +import Util + +import System.IO +import System.Time + +data ErrorLoggerHandle = ErrorLoggerHandle + { + errorLogger ::LoggerHandle ErrorLoggerMessage, + errorMinLevel :: LogLevel + } + +data ErrorLoggerMessage = ErrorLoggerMessage + { + errorTime :: ClockTime, + errorString :: String + } + + +startErrorLogger :: FilePath -> LogLevel -> IO ErrorLoggerHandle +startErrorLogger file level = + do l <- startLogger format file + let h = ErrorLoggerHandle { + errorLogger = l, + errorMinLevel = level + } + logErrorMessage h LogWarn $ "Starting error logger with log level " + ++ show level ++ "..." + return h + where format m = formatTimeSensibly (toUTCTime (errorTime m)) + ++ " " ++ errorString m + +stopErrorLogger :: ErrorLoggerHandle -> IO () +stopErrorLogger l = do logErrorMessage l LogWarn "Stopping error logger..." + stopLogger (errorLogger l) + +logErrorMessage :: ErrorLoggerHandle -> LogLevel -> String -> IO () +logErrorMessage l level s + | level < errorMinLevel l = return () + | otherwise = do time <- getClockTime + logMessage (errorLogger l) (ErrorLoggerMessage time s) diff --git a/src/Headers.hs b/src/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Headers.hs @@ -0,0 +1,317 @@ +-- Copyright 2002 Warrick Gray +-- Copyright 2001,2002 Peter Thiemann +-- Copyright 2003-2006 Bjorn Bringert +module Headers (Headers(..), + mkHeaders, + Header(..), + HeaderName(..), + HasHeaders(..), + -- * Header parsing + pHeaders, mkHeaderName, + -- * Header manipulation + insertHeader, + insertHeaderIfMissing, + replaceHeader, insertHeaders, + lookupHeaders, lookupHeader, + -- * Constructing headers + contentLengthHeader, + contentTypeHeader, + lastModifiedHeader, + TransferCoding, + transferCodingHeader, + -- * Getting values of specific headers + getContentType, getContentLength + ) where + +import Parse +import Util + +import Control.Monad (liftM) +import Data.Char (toLower) +import Data.Map (Map) +import qualified Data.Map as Map hiding (Map) +import Data.Maybe (listToMaybe) +import System.Time (ClockTime, toUTCTime) +import Text.ParserCombinators.Parsec + +newtype Headers = Headers { unHeaders :: [Header] } + +mkHeaders :: [Header] -> Headers +mkHeaders = Headers + +instance Show Headers where + showsPrec _ + = foldr (.) id . map (\x -> shows x . showString crLf) . unHeaders + +instance HasHeaders Headers where + getHeaders = id + setHeaders _ = id + + +-- | This class allows us to write generic header manipulation functions +-- for both 'Request' and 'Response' data types. +class HasHeaders x where + getHeaders :: x -> Headers + setHeaders :: x -> Headers -> x + listHeaders :: x -> [Header] + listHeaders = unHeaders . getHeaders + modifyHeaders :: ([Header] -> [Header]) -> x -> x + modifyHeaders f x = setHeaders x $ mkHeaders $ f $ listHeaders x + +-- | The Header data type pairs header names & values. +data Header = Header HeaderName String + +instance Show Header where + showsPrec _ (Header key value) + = shows key . showString ": " . showString value + + +-- | HTTP Header Name type: +-- Why include this at all? I have some reasons +-- 1) prevent spelling errors of header names, +-- 2) remind everyone of what headers are available, +-- 3) might speed up searches for specific headers. +-- +-- Arguments against: +-- 1) makes customising header names laborious +-- 2) increases code volume. +-- +data HeaderName = + -- Generic Headers -- + HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTrailer + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrTE + | HdrUserAgent + + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + + -- Mime entity headers (for sub-parts) + | HdrContentTransferEncoding + + -- | Allows for unrecognised or experimental headers. + | HdrCustom String -- not in header map below. + deriving (Eq,Ord) + + +-- Translation between header names and values, +headerNames :: [ (String,HeaderName) ] +headerNames + = [ ("Cache-Control" ,HdrCacheControl ) + , ("Connection" ,HdrConnection ) + , ("Date" ,HdrDate ) + , ("Pragma" ,HdrPragma ) + , ("Trailer" ,HdrTrailer ) + + , ("Transfer-Encoding" ,HdrTransferEncoding ) + , ("Upgrade" ,HdrUpgrade ) + , ("Via" ,HdrVia ) + , ("Accept" ,HdrAccept ) + , ("Accept-Charset" ,HdrAcceptCharset ) + , ("Accept-Encoding" ,HdrAcceptEncoding ) + , ("Accept-Language" ,HdrAcceptLanguage ) + , ("Authorization" ,HdrAuthorization ) + , ("From" ,HdrFrom ) + , ("Host" ,HdrHost ) + , ("If-Modified-Since" ,HdrIfModifiedSince ) + , ("If-Match" ,HdrIfMatch ) + , ("If-None-Match" ,HdrIfNoneMatch ) + , ("If-Range" ,HdrIfRange ) + , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince ) + , ("Max-Forwards" ,HdrMaxForwards ) + , ("Proxy-Authorization" ,HdrProxyAuthorization) + , ("Range" ,HdrRange ) + , ("Referer" ,HdrReferer ) + , ("TE" ,HdrTE ) + , ("User-Agent" ,HdrUserAgent ) + , ("Age" ,HdrAge ) + , ("Location" ,HdrLocation ) + , ("Proxy-Authenticate" ,HdrProxyAuthenticate ) + , ("Public" ,HdrPublic ) + , ("Retry-After" ,HdrRetryAfter ) + , ("Server" ,HdrServer ) + , ("Vary" ,HdrVary ) + , ("Warning" ,HdrWarning ) + , ("WWW-Authenticate" ,HdrWWWAuthenticate ) + , ("Allow" ,HdrAllow ) + , ("Content-Base" ,HdrContentBase ) + , ("Content-Encoding" ,HdrContentEncoding ) + , ("Content-Language" ,HdrContentLanguage ) + , ("Content-Length" ,HdrContentLength ) + , ("Content-Location" ,HdrContentLocation ) + , ("Content-MD5" ,HdrContentMD5 ) + , ("Content-Range" ,HdrContentRange ) + , ("Content-Type" ,HdrContentType ) + , ("ETag" ,HdrETag ) + , ("Expires" ,HdrExpires ) + , ("Last-Modified" ,HdrLastModified ) + , ("Set-Cookie" ,HdrSetCookie ) + , ("Cookie" ,HdrCookie ) + , ("Expect" ,HdrExpect ) ] + +toHeaderNameMap :: Map String HeaderName +toHeaderNameMap = Map.fromList [(map toLower x, y) | (x,y) <- headerNames] + +fromHeaderNameMap :: Map HeaderName String +fromHeaderNameMap = Map.fromList [(y,x) | (x,y) <- headerNames] + +instance Show HeaderName where + show (HdrCustom s) = s + show x = case Map.lookup x fromHeaderNameMap of + Nothing -> error "headerNames incomplete" + Just h -> h + +mkHeaderName :: String -> HeaderName +mkHeaderName s = + case Map.lookup (map toLower s) toHeaderNameMap of + Just n -> n + Nothing -> HdrCustom s + + +-- * Header manipulation functions + +-- | Inserts a header with the given name and value. +-- Allows duplicate header names. +insertHeader :: HasHeaders a => HeaderName -> String -> a -> a +insertHeader name value = modifyHeaders (Header name value:) + +-- | Adds the new header only if no previous header shares +-- the same name. +insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a +insertHeaderIfMissing name value x = setHeaders x $ mkHeaders hs' + where hs' = case lookupHeader name x of + Nothing -> Header name value : hs + Just _ -> hs + hs = listHeaders (getHeaders x) + +-- | Removes old headers with the same name. +replaceHeader :: HasHeaders a => HeaderName -> String -> a -> a +replaceHeader name value = modifyHeaders f + where f hs = Header name value : [ x | x@(Header n _) <- hs, name /= n ] + +-- | Inserts multiple headers. +insertHeaders :: HasHeaders a => [Header] -> a -> a +insertHeaders hdrs = modifyHeaders (hdrs++) + +lookupHeaders :: HasHeaders a => HeaderName -> a -> [String] +lookupHeaders name x = [ v | Header n v <- listHeaders x, name == n ] + +lookupHeader :: HasHeaders a => HeaderName -> a -> Maybe String +lookupHeader n x = listToMaybe $ lookupHeaders n x + + +-- * Constructing specific headers + +contentLengthHeader :: Integer -> Header +contentLengthHeader i = Header HdrContentLength (show i) + +contentTypeHeader :: String -> Header +contentTypeHeader t = Header HdrContentType t + +lastModifiedHeader :: ClockTime -> Header +lastModifiedHeader t = Header HdrLastModified (formatTimeSensibly (toUTCTime t)) + +transferCodingHeader :: TransferCoding -> Header +transferCodingHeader te = Header HdrTransferEncoding (transferCodingStr te) + +data TransferCoding + = ChunkedTransferCoding + | GzipTransferCoding + | CompressTransferCoding + | DeflateTransferCoding + deriving Eq + +transferCodingStr :: TransferCoding -> String +transferCodingStr ChunkedTransferCoding = "chunked" +transferCodingStr GzipTransferCoding = "gzip" +transferCodingStr CompressTransferCoding = "compress" +transferCodingStr DeflateTransferCoding = "deflate" + +-- validTransferCoding :: [TransferCoding] -> Bool +-- validTransferCoding codings +-- | null codings +-- || last codings == ChunkedTransferCoding +-- && ChunkedTransferCoding `notElem` init codings = True +-- | otherwise = False +; + +-- * Values of specific headers + +getContentType :: HasHeaders a => a -> Maybe String +getContentType x = lookupHeader HdrContentType x + +getContentLength :: HasHeaders a => a -> Maybe Integer +getContentLength x = lookupHeader HdrContentLength x >>= readM + + +-- * Parsing + +pHeaders :: Parser Headers +pHeaders = liftM Headers $ many pHeader + +pHeader :: Parser Header +pHeader = + do name <- pToken + char ':' + many pWS1 + line <- lineString + pCRLF + extraLines <- many extraFieldLine + return $ Header (mkHeaderName name) (concat (line:extraLines)) + +extraFieldLine :: Parser String +extraFieldLine = + do sp <- pWS1 + line <- lineString + pCRLF + return (sp:line) + diff --git a/src/LogLevel.hs b/src/LogLevel.hs new file mode 100644 --- /dev/null +++ b/src/LogLevel.hs @@ -0,0 +1,32 @@ +module LogLevel (LogLevel(..)) where + +import Data.Maybe (fromMaybe) + +data LogLevel = LogDebug + | LogInfo + | LogNotice + | LogWarn + | LogError + | LogCrit + | LogAlert + | LogEmerg + deriving (Eq,Ord,Enum,Bounded) + +logLevelNames :: [(LogLevel,String)] +logLevelNames = [ + (LogDebug, "debug"), + (LogInfo, "info"), + (LogNotice,"notice"), + (LogWarn, "warn"), + (LogError, "error"), + (LogCrit, "crit"), + (LogAlert, "alert"), + (LogEmerg, "emerg") + ] + +instance Show LogLevel where + show l = fromMaybe (error $ "logLevelNames is incomplete") $ + lookup l logLevelNames + +instance Read LogLevel where + readsPrec _ s = [ (l,"") | (l,n) <- logLevelNames, n == s ] diff --git a/src/Logger.hs b/src/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Logger.hs @@ -0,0 +1,124 @@ +-- ----------------------------------------------------------------------------- +-- 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 Logger ( + LoggerHandle, + startLogger, + stopLogger, + logMessage + ) where + +import Util + +import Control.Exception as Exception +import Control.Concurrent +import System.Directory +import System.IO + + +data LoggerHandle a = LoggerHandle + { + loggerHandleChan :: Chan (LoggerCommand a), + loggerHandleThreadId :: ThreadId + } + +data Logger a = Logger + { + loggerChan :: Chan (LoggerCommand a), + loggerFormat :: (a -> String), + loggerFile :: FilePath + } + +data LoggerCommand a = StopLogger + | LogMessage a + +startLogger :: (a -> String) -- ^ Message formatting function + -> FilePath -- ^ log file path + -> IO (LoggerHandle a) +startLogger format file = + do chan <- newChan + createDirectoryIfMissing True (dirname file) + let l = Logger { + loggerChan = chan, + loggerFormat = format, + loggerFile = file + } + t <- forkIO (runLogger l + `Exception.catch` + (\e -> hPutStrLn stderr + ("Error starting logger: " ++ show e))) + return $ LoggerHandle { + loggerHandleChan = chan, + loggerHandleThreadId = t + } + +stopLogger :: LoggerHandle a -> IO () +stopLogger l = writeChan (loggerHandleChan l) StopLogger + +logMessage :: LoggerHandle a -> a -> IO () +logMessage l x = writeChan (loggerHandleChan l) (LogMessage x) + +-- Internals + +runLogger :: Logger a -> IO () +runLogger l = runLogger1 l + `Exception.catch` + (\e -> do hPutStrLn stderr ("Logger died: " ++ show e) + runLogger l) + +runLogger1 :: Logger a -> IO () +runLogger1 l = + Exception.bracket + (openLogFile (loggerFile l)) + (\hdl -> hClose hdl) + (\hdl -> handleLogCommands l hdl) + where + openLogFile :: FilePath -> IO Handle + openLogFile f = + openFile f AppendMode + `Exception.catch` + (\e -> do hPutStrLn stderr ("Failed to open log file: " ++ show e) + Exception.throw e) + +handleLogCommands :: Logger a -> Handle -> IO () +handleLogCommands l hdl = + do comm <- readChan (loggerChan l) + case comm of + StopLogger -> do return () + LogMessage x -> do let str = (loggerFormat l) x + writeLogLine hdl str + handleLogCommands l hdl + where + writeLogLine :: Handle -> String -> IO () + writeLogLine hndl str = do hPutStrLn hndl str + hFlush hndl diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,490 @@ +-- ----------------------------------------------------------------------------- +-- 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 diff --git a/src/MimeTypes.hs b/src/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/src/MimeTypes.hs @@ -0,0 +1,94 @@ +-- ----------------------------------------------------------------------------- +-- 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 MimeTypes ( + MimeTypes, + MimeType(..), + initMimeTypes, + mimeTypeOf, + pMimeType + ) where + +import Parse + +import Data.Map (Map) +import qualified Data.Map as Map hiding (Map) +import Text.ParserCombinators.Parsec + +type MimeTypes = Map String MimeType + +data MimeType = MimeType String String + +instance Show MimeType where + showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2) + +mimeTypeOf :: MimeTypes -> FilePath -> Maybe MimeType +mimeTypeOf mime_types filename = + do let ext = extension filename + if null ext + then Nothing + else Map.lookup ext mime_types + +extension :: String -> String +extension fn = go (reverse fn) "" + where go [] _ = "" + go ('.':_) ext = ext + go (x:s) ext = go s (x:ext) + +initMimeTypes :: FilePath -> IO MimeTypes +initMimeTypes mime_types_file = + do stuff <- readFile mime_types_file + return $ Map.fromList (parseMimeTypes stuff) + +parseMimeTypes :: String -> [(String,MimeType)] +parseMimeTypes file = + [ (ext,val) + | Just (val,exts) <- map (parseMimeLine . takeWhile (/= '#')) (lines file) + , ext <- exts + ] + +parseMimeLine :: String -> Maybe (MimeType, [String]) +parseMimeLine l = case parse pMimeLine "MIME line" l of + Left _ -> Nothing + Right m -> Just m + +pMimeLine :: Parser (MimeType, [String]) +pMimeLine = do t <- pMimeType + es <- (spaces >> sepBy pToken spaces) + return (t, es) + +pMimeType :: Parser MimeType +pMimeType = do part1 <- pToken + char '/' + part2 <- pToken + return $ MimeType part1 part2 diff --git a/src/Module/CGI.hs b/src/Module/CGI.hs new file mode 100644 --- /dev/null +++ b/src/Module/CGI.hs @@ -0,0 +1,207 @@ +-- Copyright 2006, Bjorn Bringert. +module Module.CGI (desc, + mkCGIEnv, mkCGIResponse + ) where + +import Config +import Headers +import Parse +import Request +import Response +import ServerRequest +import ServerState +import Util + +import Control.Concurrent +import Control.Exception as Exception +import Control.Monad +import Data.Char (toUpper) +import Data.List +import Network.BSD (hostName) +import Network.Socket (inet_ntoa) +import Network.URI +import System.IO +import System.IO.Error +import System.Posix +import System.Process (runInteractiveProcess, waitForProcess) +import Text.ParserCombinators.Parsec + + +desc :: ModuleDesc +desc = emptyModuleDesc { + moduleName = "cgi", + moduleLoad = return funs + } + +funs :: Module +funs = emptyModule { + moduleHandleRequest = cgiHandleRequest + } + +cgiHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response) +cgiHandleRequest st sreq = + do m_prog <- findProg st (serverFilename sreq) + case m_prog of + Nothing -> do debug st $ "CGI: not handling " ++ serverFilename sreq + return Nothing + Just (path_prog, path_info) -> + do if ".cgi" `isSuffixOf` path_prog -- FIXME: add AddHandler mechanism + then do let hndle = cgiHandleRequest2 st sreq path_prog path_info + liftM Just $ case reqCmd (clientRequest sreq) of + GetReq -> hndle False + PostReq -> hndle True + _ -> return $ notImplementedResponse conf + else do debug st $ "CGI: not handling " ++ serverFilename sreq ++ ", wrong suffix" + return Nothing + where conf = serverConfig st + +cgiHandleRequest2 :: ServerState -> ServerRequest -> FilePath -> String -> Bool -> IO Response +cgiHandleRequest2 st sreq path_prog path_info useReqBody = + do let conf = serverConfig st + let req = clientRequest sreq + + env <- mkCGIEnv st sreq path_info + let wdir = dirname path_prog + prog = "./" ++ basename path_prog + + debug st $ "Running CGI program: " ++ prog ++ " in " ++ wdir + + (inp,out,err,pid) + <- runInteractiveProcess prog [] (Just wdir) (Just env) + + + if useReqBody then forkIO (writeBody inp req) >> return () + else hClose inp + + -- log process stderr to the error log + forkIO (logErrorsFromHandle st err) + + -- FIXME: exception handling + -- FIXME: close handle? + output <- hGetContents out + + -- wait in a separate thread, so that this thread can continue. + -- this is needed since output is lazy. + forkIO (waitForProcess pid >> return ()) + + case parseCGIOutput output of + Left errp -> do logError st errp + return $ internalServerErrorResponse conf + Right (outputHeaders, content) -> mkCGIResponse outputHeaders content + +mkCGIResponse :: Headers -> String -> IO Response +mkCGIResponse outputHeaders content = + do let stat = lookupHeader (HdrCustom "Status") outputHeaders + loc = lookupHeader HdrLocation outputHeaders + (code,dsc) <- case stat of + Nothing -> let c = maybe 200 (\_ -> 302) loc + in return (c, responseDescription c) + Just s -> case reads s of + [(c,r)] -> return (c,trimLWS r) + _ -> fail "Bad Status line" + -- FIXME: don't use response constructor directly + return (Response code dsc outputHeaders [] (HereItIs content) True) + +-- Split the requested file system path into the path to an +-- existing file, and some extra path info +findProg :: ServerState -> FilePath -> IO (Maybe (FilePath,String)) +findProg st filename = case splitPath filename of + [] -> return Nothing -- this should never happen + [""] -> return Nothing -- we got an empty path + "":p -> firstFile st "/" p -- absolute path + p:r -> firstFile st p r -- relative path + +firstFile :: ServerState -> FilePath -> [String] -> IO (Maybe (FilePath,String)) +firstFile st p pis = + do m_lstat <- statSymLink p + checkStat m_lstat + where conf = serverConfig st + + mkPath x y | "/" `isSuffixOf` x = x ++ y + | otherwise = x ++ "/" ++ y + + mkPathInfo [] = "" + mkPathInfo q = "/" ++ glue "/" q + + checkStat Nothing = do debug st $ "findProg: Not found: " ++ show p + return Nothing + checkStat (Just stat) + | isDirectory stat = + case pis of + [] -> do debug st $ "findProg: " ++ show p ++ " is a directory" + return Nothing + f:pis' -> firstFile st (mkPath p f) pis' + | isRegularFile stat = return $ Just (p,mkPathInfo pis) + | isSymbolicLink stat = if followSymLinks conf + then statFile p >>= checkStat + else do debug st $ "findProg: Not following symlink: " ++ show p + return Nothing + | otherwise = do debug st $ "Strange file: " ++ show p + return Nothing + +mkCGIEnv :: ServerState -> ServerRequest -> String -> IO [(String,String)] +mkCGIEnv st sreq path_info + = do let req = clientRequest sreq + remoteAddr <- inet_ntoa (clientAddress sreq) + let scriptName = serverURIPath sreq `dropSuffix` path_info + -- FIXME: use canonical name if there is no ServerName + serverEnv = + [ + ("SERVER_SOFTWARE", serverSoftware + ++ "/" ++ serverVersion), + ("SERVER_NAME", hostName (requestHostName sreq)), + ("GATEWAY_INTERFACE", "CGI/1.1") + ] + requestEnv = + [ + ("SERVER_PROTOCOL", show (reqHTTPVer req)), + ("SERVER_PORT", show (serverPort st)), + ("REQUEST_METHOD", show (reqCmd req)), + ("PATH_TRANSLATED", serverFilename sreq), + ("SCRIPT_NAME", scriptName), + ("QUERY_STRING", uriQuery (reqURI req) `dropPrefix` "?"), + ("REMOTE_ADDR", remoteAddr), + ("PATH_INFO", path_info) + ] + ++ maybeHeader "AUTH_TYPE" Nothing -- FIXME + ++ maybeHeader "REMOTE_USER" Nothing -- FIXME + ++ maybeHeader "REMOTE_IDENT" Nothing -- FIXME + ++ maybeHeader "REMOTE_HOST" (fmap hostName (clientName sreq)) + ++ maybeHeader "CONTENT_TYPE" (getContentType req) + ++ maybeHeader "CONTENT_LENGTH" (fmap show $ getContentLength req) + hs = [] -- FIXME: convert headers to (name,value) pairs + headerEnv = [("HTTP_"++ map toUpper n, v) | (n,v) <- hs] + + return $ serverEnv ++ requestEnv ++ headerEnv + +-- Writes the body of a request to a handle. +writeBody :: Handle -> Request -> IO () +writeBody h req = do hPutStr h (reqBody req) + hClose h + +-- | Reads lines form the given 'Handle' and log them with 'logError'. +logErrorsFromHandle :: ServerState -> Handle -> IO () +logErrorsFromHandle st h = + (loop `Exception.catch` \e -> + case e of + IOException f | isEOFError f -> return () + _ -> logError st $ "CGI:" ++ show e) + `Exception.finally` hClose h + where loop = do l <- hGetLine h + logError st l + loop + +maybeHeader :: String -> Maybe String -> [(String,String)] +maybeHeader n = maybe [] ((:[]) . (,) n) + +parseCGIOutput :: String -> Either String (Headers,String) +parseCGIOutput s = case parse pCGIOutput "CGI output" s of + Left err -> Left (show err) + Right x -> Right x + +pCGIOutput :: Parser (Headers,String) +pCGIOutput = + do headers <- pHeaders + pCRLF + body <- getInput + return (headers, body) diff --git a/src/Module/DynHS.hs b/src/Module/DynHS.hs new file mode 100644 --- /dev/null +++ b/src/Module/DynHS.hs @@ -0,0 +1,79 @@ +-- Copyright 2006 Bjorn Bringert +module Module.DynHS where + +import Module.DynHS.GHCUtil + +import Headers +import Response +import ServerRequest +import ServerState + +import Control.Exception as Exception +import Control.Monad +import Data.List +import System.IO + + +-- FIXME: keep this in config +packageDirectory :: FilePath +packageDirectory = "/usr/local/lib/ghc-6.6" + + +desc :: ModuleDesc +desc = emptyModuleDesc { + moduleName = "dynhs", + moduleLoad = loadDynHS + } + +loadDynHS :: IO Module +loadDynHS = + do s <- initGHC packageDirectory + return $ emptyModule { + moduleLoadConfig = dynhsLoadConfig s, + moduleHandleRequest = dynhsHandleRequest s + } + +dynhsLoadConfig :: Session -> ServerState -> IO () +dynhsLoadConfig s st = setLogAction s (logError st) + +dynhsHandleRequest :: Session -> ServerState -> ServerRequest -> IO (Maybe Response) +dynhsHandleRequest s st sreq = + do if ".hs" `isSuffixOf` serverFilename sreq + then dynhsHandleRequest2 s st sreq + else return Nothing + +dynhsHandleRequest2 :: Session -> ServerState -> ServerRequest -> IO (Maybe Response) +dynhsHandleRequest2 s st sreq = withCleanUp s $ +-- FIXME: lots of fake stuff here + do debug st $ "DynHS: Loading " ++ show (serverFilename sreq) + e_cgiMain <- logGHCErrors s st (getCgiMain s (serverFilename sreq)) + case e_cgiMain of + Left resp -> return $ Just resp + Right cgiMain -> liftM Just $ runCgiMain st sreq cgiMain + +type CGIMain = [(String,String)] -> [(String,String)] -> IO ([(String,String)], String) + +getCgiMain :: Session -> FilePath -> IO CGIMain +getCgiMain s file = getFileValue s file "cgiMain" + +runCgiMain :: ServerState -> ServerRequest -> CGIMain -> IO Response +runCgiMain st sreq cgiMain = + -- FIXME: lots of fake stuff here + do let env = [] + inputs = [] + (hs,content) <- cgiMain env inputs + let headers = mkHeaders [Header (mkHeaderName n) v | (n,v) <- hs] + let code = 200 + desc = "OK" + return $ Response code desc headers [] (HereItIs content) True + +-- GHC utilities + +logGHCErrors :: Session -> ServerState -> IO a -> IO (Either Response a) +logGHCErrors s st f + = liftM Right f + `Exception.catch` + (\e -> do logError st (show e) + -- FIXME: include error message in response + return $ Left $ internalServerErrorResponse (serverConfig st)) + diff --git a/src/Module/DynHS/CGI.hs b/src/Module/DynHS/CGI.hs new file mode 100644 --- /dev/null +++ b/src/Module/DynHS/CGI.hs @@ -0,0 +1,47 @@ +module Module.DynHS.CGI where + +import Module.CGI + +import Response +import Request +import ServerRequest +import ServerState + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.Map as Map +import Data.Maybe (isJust) + +import Network.CGI.Monad +import Network.CGI.Protocol + + +hwsRunCGI :: ServerState -> ServerRequest -> CGI CGIResult -> IO Response +hwsRunCGI st sreq cgi = + do let path_info = "" -- FIXME: do the path walk + env <- mkCGIEnv st sreq path_info + let input = BS.pack $ reqBody $ clientRequest sreq + (hs,body) <- runCGI_ env input (runCGIT cgi) + mkCGIResponse hs (BS.unpack body) + +-- | Run a CGI action. This is what runCGIEnvFPS really should look like. +runCGI_ :: Monad m => + [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. + -> m (Headers, ByteString) -- ^ Response (headers and content). +runCGI_ vars inp f + = do (hs,outp) <- f $ CGIRequest { + cgiVars = Map.fromList vars, + cgiInputs = decodeInput vars inp, + cgiRequestBody = inp + } + return $ case outp of + CGIOutput c -> (hs',c) + where hs' = if isJust (lookup ct hs) + then hs else hs ++ [(ct,defaultContentType)] + ct = HeaderName "Content-type" + CGINothing -> (hs, BS.empty) + +defaultContentType :: String +defaultContentType = "text/html; charset=ISO-8859-1" diff --git a/src/Module/DynHS/GHCUtil.hs b/src/Module/DynHS/GHCUtil.hs new file mode 100644 --- /dev/null +++ b/src/Module/DynHS/GHCUtil.hs @@ -0,0 +1,98 @@ +module Module.DynHS.GHCUtil + (Session, + initGHC, + setLogAction, + withCleanUp, + getFileValue, + -- * Error logging + Severity(..), SrcSpan, PprStyle, Message, + mkLocMessage + ) where + +-- GHC API stuff +import DynFlags +import ErrUtils +import GHC hiding (Module, Session, moduleName) +import qualified GHC (Module, Session) +import HscMain (newHscEnv) +import HscTypes (Session(..)) +import Outputable (PprStyle) +import SrcLoc (SrcSpan) +import SysTools (initSysTools) + +import Data.Dynamic +import Data.IORef +import System.IO + +initGHC :: FilePath -> IO Session +initGHC pkgDir + = do s <- newSession' Interactive (Just pkgDir) + modifySessionDynFlags s (\flags -> flags{ hscTarget = HscInterpreted }) + return s + + + +-- Like newSesion, but does not install signal handlers +newSession' :: GhcMode -> Maybe FilePath -> IO Session +newSession' mode mb_top_dir = do + dflags0 <- initSysTools mb_top_dir defaultDynFlags + dflags <- initDynFlags dflags0 + env <- newHscEnv dflags{ ghcMode=mode } + ref <- newIORef env + return (Session ref) + +setLogAction :: Session -> (String -> IO ()) -> IO () +setLogAction s f = + modifySessionDynFlags s (\flags -> flags { log_action = mkLogAction f }) + +mkLogAction :: (String -> IO ()) + -> Severity -> SrcSpan -> PprStyle -> Message -> IO () +mkLogAction f severity srcSpan style msg = + case severity of + SevInfo -> f (show (msg style)) + SevFatal -> f (show (msg style)) + _ -> f (show ((mkLocMessage srcSpan msg) style)) + + +modifySessionDynFlags :: Session -> (DynFlags -> DynFlags) -> IO () +modifySessionDynFlags s f = + do flags <- getSessionDynFlags s + setSessionDynFlags s (f flags) + return () + +withCleanUp :: Session -> IO a -> IO a +withCleanUp s f = do flags <- getSessionDynFlags s + defaultCleanupHandler flags f + +loadFile :: Session -> FilePath -> IO GHC.Module +loadFile s file = + do let t = Target (TargetFile file Nothing) Nothing + setTargets s [t] + succ <- load s LoadAllTargets + case succ of + Succeeded -> do m <- fileModule s file + setContext s [] [m] + return m + Failed -> fail $ "Failed to load " ++ show file + +fileModule :: Session -> FilePath -> IO GHC.Module +fileModule s f = + do gr <- getModuleGraph s + case [ms_mod ms | ms <- gr, ml_hs_file (ms_location ms) == Just f] of + [m] -> return m + _ -> fail $ "File " ++ f ++ " does not correspond to a module" + +getValue :: Typeable a => Session -> String -> IO a +getValue s x = + do mdyn <- dynCompileExpr s x + case mdyn of + Nothing -> fail $ "dynCompileExpr " ++ show x ++ " failed" + Just dyn -> case fromDynamic dyn of + Nothing -> fail $ "Type error: " ++ x + ++ " is an " ++ show dyn + Just x -> return x + +getFileValue :: Typeable a => Session -> FilePath -> String -> IO a +getFileValue s file x = + do m <- loadFile s file + getValue s x diff --git a/src/Module/File.hs b/src/Module/File.hs new file mode 100644 --- /dev/null +++ b/src/Module/File.hs @@ -0,0 +1,70 @@ +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +module Module.File (desc) where + +import Config +import Headers +import Request +import Response +import ServerRequest +import ServerState +import Util + +import Control.Monad +import System.Posix + +desc :: ModuleDesc +desc = emptyModuleDesc { + moduleName = "file", + moduleLoad = return funs + } + +funs :: Module +funs = emptyModule { + moduleHandleRequest = fileHandler + } + +fileHandler :: ServerState -> ServerRequest -> IO (Maybe Response) +fileHandler st (ServerRequest { clientRequest = req, + serverFilename = filename }) = + do m_lstat <- statSymLink filename + checkStat m_lstat + where + conf = serverConfig st + checkStat (Just stat) + | isRegularFile stat = + liftM Just $ case reqCmd req of + GetReq -> serveFile st filename stat False + HeadReq -> serveFile st filename stat True + _ -> return (notImplementedResponse conf) + | isSymbolicLink stat = + if followSymLinks conf + then statFile filename >>= checkStat + else do debug st $ "findProg: Not following symlink: " ++ show filename + return Nothing + | otherwise = do debug st $ "Strange file: " ++ show filename + return Nothing + checkStat Nothing = do debug st $ "File not found: " ++ show filename + return Nothing + +serveFile :: ServerState -> FilePath -> FileStatus -> Bool -> IO Response +serveFile st filename stat is_head = + 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 content_type = getMimeType st filename + + let last_modified = epochTimeToClockTime (modificationTime stat) + + let size = toInteger (fileSize stat) + + return (okResponse conf + (FileBody size filename) + (mkHeaders [contentTypeHeader content_type, + lastModifiedHeader last_modified]) + (not is_head) {- send body -}) + where conf = serverConfig st diff --git a/src/Module/Index.hs b/src/Module/Index.hs new file mode 100644 --- /dev/null +++ b/src/Module/Index.hs @@ -0,0 +1,40 @@ +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +module Module.Index (desc) where + +import Config +import ServerRequest +import ServerState +import Util + +import System.Posix + + + +desc :: ModuleDesc +desc = emptyModuleDesc { + moduleName = "index", + moduleLoad = return funs + } + +funs :: Module +funs = emptyModule { + moduleTweakRequest = indexTweakRequest + } + +indexTweakRequest :: ServerState -> ServerRequest -> IO ServerRequest +indexTweakRequest = tweakFilename indexFixPath + +indexFixPath :: ServerState -> FilePath -> IO FilePath +indexFixPath st filename = + do stat <- statFile filename + case stat of + Just state | isDirectory state -> do + let index_filename = filename ++ '/': directoryIndex conf + debug st $ "index_filename = " ++ show index_filename + stt <- statFile index_filename + case stt of + Nothing -> return filename + Just _ -> return index_filename + _ -> return filename + where conf = serverConfig st diff --git a/src/Module/Userdir.hs b/src/Module/Userdir.hs new file mode 100644 --- /dev/null +++ b/src/Module/Userdir.hs @@ -0,0 +1,35 @@ +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +module Module.Userdir (desc) where + +import Config +import ServerState + +import Control.Exception +import System.Posix + + +desc :: ModuleDesc +desc = emptyModuleDesc { + moduleName = "userdir", + moduleLoad = return funs + } + +funs :: Module +funs = emptyModule { + moduleTranslatePath = userdirTranslatePath + } + +userdirTranslatePath :: ServerState -> String -> IO (Maybe FilePath) +userdirTranslatePath st ('/':'~':userpath) | not (null (userDir conf)) = + do let (usr, path) = break (=='/') userpath + debug st $ "looking for user: " ++ show usr + u_ent <- tryJust ioErrors (getUserEntryForName usr) + case u_ent of + Left _ -> return Nothing + Right ent -> + do let p = '/': homeDirectory ent ++ '/':userDir conf ++ path + debug st $ "userdir path: " ++ p + return $ Just p + where conf = serverConfig st +userdirTranslatePath _ _ = return Nothing diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,58 @@ +module Options (Options, + serverRoot, configPath, inServerRoot, + parseOptions) where + +import Data.List (isPrefixOf) +import System.Console.GetOpt + + +type Options = [CmdLineOpt] + +data CmdLineOpt + = O_ConfigFile FilePath + | O_ServerRoot FilePath + + +options :: [OptDescr CmdLineOpt] +options = [ + Option ['f'] ["config"] (ReqArg O_ConfigFile "filename") + ("default: \n" ++ show ("/" ++ defaultConfigFile)), + Option ['d'] ["server-root"] (ReqArg O_ServerRoot "directory") + ("default: " ++ show defaultServerRoot) + ] + +usage :: String +usage = "usage: hws [option...]" + +defaultConfigFile :: FilePath +defaultConfigFile = "conf/httpd.conf" + +defaultServerRoot :: FilePath +defaultServerRoot = "." + +serverRoot :: Options -> FilePath +serverRoot opts = + case [ s | O_ServerRoot s <- opts] of + [] -> defaultServerRoot + s -> last s + +configPath :: Options -> FilePath +configPath args = inServerRoot args (configFile args) + +configFile :: Options -> FilePath +configFile args = + case [ s | O_ConfigFile s <- args] of + [] -> defaultConfigFile + s -> last s + +inServerRoot :: Options -> FilePath -> FilePath +inServerRoot opts f | "/" `isPrefixOf` f = f + | otherwise = serverRoot opts ++ '/':f + +-- returns error message or options +parseOptions :: [String] -> Either String Options +parseOptions args = + case getOpt Permute options args of + (flags, [], []) -> Right flags + (_, _, errs) -> Left (concat errs ++ "\n" + ++ usageInfo usage options) diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,84 @@ +-- HTTP parsing utilities +-- Copyright : (c) Peter Thiemann 2001,2002 +-- (c) Bjorn Bringert 2005-2006 +module Parse where + +import Util + +import Control.Monad (liftM2) +import Data.Char +import Data.List +import System.IO (Handle, hGetLine) +import Text.ParserCombinators.Parsec + + +pSP :: Parser Char +pSP = char ' ' + +-- | RFC 822 LWSP-char +pWS1 :: Parser Char +pWS1 = oneOf " \t" + +crLf :: String +crLf = "\r\n" + +-- | RFC 2616 CRLF +pCRLF :: Parser String +pCRLF = try (string "\r\n" <|> string "\n\r") <|> string "\n" <|> string "\r" + +lexeme :: Parser a -> Parser a +lexeme p = do x <- p; many pWS1; return x + +-- | One line +lineString :: Parser String +lineString = many (noneOf "\n\r") + +headerNameChar :: Parser Char +headerNameChar = noneOf "\n\r:" + +especials, tokenchar :: [Char] +especials = "()<>@,;:\\\"/[]?.=" +tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials + +pToken :: Parser String +pToken = many1 (oneOf tokenchar) + +textChars :: [Char] +textChars = map chr ([1..9] ++ [11,12] ++ [14..127]) + +pText :: Parser Char +pText = oneOf textChars + + +-- parse the list format described in RFC 2616, section 2.1 +parseList :: String -> [String] +parseList = map trimLWS . splitBy (==',') + +dropLeadingLWS :: String -> String +dropLeadingLWS = dropWhile isLWSChar + +trimLWS :: String -> String +trimLWS = reverse . dropLeadingLWS . reverse . dropLeadingLWS + +isLWSChar :: Char -> Bool +isLWSChar c = c == ' ' || c == '\t' + + +-- Read input up to the first empty line +getUntilEmptyLine :: Handle -> IO String +getUntilEmptyLine h = + do l <- hGetLine h + if emptyLine l + then return "\n" + else getUntilEmptyLine h >>= return . ((l++) . ('\n':)) + +emptyLine :: String -> Bool +emptyLine "\r" = True +emptyLine "" = True +emptyLine _ = False + + +countBetween :: Int -> Int -> GenParser tok st a -> GenParser tok st [a] +countBetween 0 0 _ = return [] +countBetween 0 ma p = option [] (liftM2 (:) p (countBetween 0 (ma-1) p)) +countBetween mi ma p = liftM2 (:) p (countBetween (mi-1) (ma-1) p) diff --git a/src/Request.hs b/src/Request.hs new file mode 100644 --- /dev/null +++ b/src/Request.hs @@ -0,0 +1,208 @@ +-- ----------------------------------------------------------------------------- +-- 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 Request ( + HTTPVersion(..), + http1_1, http1_0, + Request(..), + RequestCmd(..), + RequestBody, + Connection(..), + Expect(..), + pRequestHeaders, + getHost, + getConnection + ) where + +import Text.ParserCombinators.Parsec + +import Headers +import Parse +import Util + +import Data.Char +import Data.Maybe +import Network.URI + + +----------------------------------------------------------------------------- +-- Requests + +-- Request-Line = Method SP Request-URI SP HTTP-Version CRLF + +data RequestCmd + = OptionsReq + | GetReq + | HeadReq + | PostReq + | PutReq + | DeleteReq + | TraceReq + | ConnectReq + | ExtensionReq String + +instance Show RequestCmd where + show c = case c of + OptionsReq -> "OPTIONS" + GetReq -> "GET" + HeadReq -> "HEAD" + PostReq -> "POST" + PutReq -> "PUT" + DeleteReq -> "DELETE" + TraceReq -> "TRACE" + ConnectReq -> "CONNECT" + ExtensionReq s -> s + +data Request = Request { + reqCmd :: RequestCmd, + reqURI :: URI, + reqHTTPVer :: HTTPVersion, + reqHeaders :: Headers, + reqBody :: RequestBody + } + +instance Show Request where + showsPrec _ Request{reqCmd = cmd, reqURI = uri, reqHTTPVer = ver} + = shows cmd . (' ':) . shows uri . (' ':) . shows ver + +instance HasHeaders Request where + getHeaders = reqHeaders + setHeaders req hs = req { reqHeaders = hs} + + +data HTTPVersion = HTTPVersion Int Int + deriving (Eq,Ord) + +instance Show HTTPVersion where + showsPrec _ (HTTPVersion maj mini) = + showString "HTTP/" . shows maj . showString "." . shows mini + +http1_1, http1_0 :: HTTPVersion +http1_1 = HTTPVersion 1 1 +http1_0 = HTTPVersion 1 0 + + +-- FIXME: use something more efficient +type RequestBody = String + + +-- Request parsing + +-- Parse the request line and the headers, but not the body. +pRequestHeaders :: Parser Request +pRequestHeaders = + do (cmd,uri,ver) <- pRequestLine + headers <- pHeaders + pCRLF + return $ Request cmd uri ver headers "" + +pRequestLine :: Parser (RequestCmd, URI, HTTPVersion) +pRequestLine = do cmd <- pReqCmd + many1 pSP + uri <- pReqURI + many1 pSP + ver <- pReqHTTPVer + pCRLF + return (cmd,uri,ver) + +pReqCmd :: Parser RequestCmd +pReqCmd = choice [ + c "OPTIONS" OptionsReq, + c "GET" GetReq, + c "HEAD" HeadReq, + c "POST" PostReq, + c "PUT" PutReq, + c "DELETE" DeleteReq, + c "TRACE" TraceReq, + c "CONNECT" ConnectReq, + pToken >>= return . ExtensionReq + ] + where c x y = try (string x >> return y) + +pReqURI :: Parser URI +pReqURI = + do u <- many (noneOf [' ']) + -- FIXME: this does not handle authority Request-URIs + maybe (fail "Bad Request-URI") return $ parseURIReference u + +pReqHTTPVer :: Parser HTTPVersion +pReqHTTPVer = do string "HTTP/"; + major <- int; + char '.'; + minor <- int; + return $ HTTPVersion major minor + +int :: Parser Int +int = many1 digit >>= readM + +----------------------------------------------------------------------------- +-- Getting specific request headers + + +data Connection + = ConnectionClose + | ConnectionKeepAlive -- non-std? Netscape generates it. + | ConnectionOther String + deriving (Eq, Show) + +parseConnection :: String -> [Connection] +parseConnection = map (fn . map toLower) . parseList + where fn "close" = ConnectionClose + fn "keep-alive" = ConnectionKeepAlive + fn other = ConnectionOther other + +getConnection :: HasHeaders a => a -> [Connection] +getConnection = concatMap parseConnection . lookupHeaders HdrConnection + +data Expect + = ExpectContinue + deriving Show + +-- parseExpect :: String -> Maybe Expect +-- parseExpect s = +-- case parseList s of +-- ["100-continue"] -> Just ExpectContinue +-- _ -> Nothing + + +getHost :: HasHeaders a => a -> Maybe (String, Maybe Int) +getHost x = lookupHeader HdrHost x >>= parseHost + +parseHost :: String -> Maybe (String, Maybe Int) +parseHost s = + case prt of + "" -> Just (host, Nothing) + ':':port -> readM port >>= \p -> Just (host, Just p) + _ -> Nothing + where (host,prt) = break (==':') s + diff --git a/src/Response.hs b/src/Response.hs new file mode 100644 --- /dev/null +++ b/src/Response.hs @@ -0,0 +1,304 @@ +-- ----------------------------------------------------------------------------- +-- 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 Response where + +import Config +import Headers +import Parse +import Util + +import Control.Monad +import Control.Exception as Exception +import Data.List (genericLength) +import System.IO +import System.Time +import Text.Html + + +----------------------------------------------------------------------------- +-- Responses + +data ResponseBody + = NoBody + | FileBody Integer{-size-} FilePath + | HereItIs String + +data Response + = Response { + respCode :: Int, + respDesc :: String, + respHeaders :: Headers, + respCoding :: [TransferCoding], -- either empty or terminated with + -- ChunkedTransferEncoding + -- (RFC2616, sec 3.6) + respBody :: ResponseBody, -- filename of body + respSendBody :: Bool -- actually send the body? + -- (False for HEAD requests) + } + + +instance Show Response where + showsPrec _ r + = showString (showResponseLine r) . showString crLf + . shows (respHeaders r) + +instance HasHeaders Response where + getHeaders = respHeaders + setHeaders resp hs = resp { respHeaders = hs} + +showResponseLine :: Response -> String +showResponseLine (Response s desc _ _ _ _) = show s ++ " " ++ desc + + +responseBodyLength :: ResponseBody -> Integer +responseBodyLength bdy = + case bdy of + NoBody -> 0 + HereItIs stuff -> genericLength stuff + FileBody sze _ -> sze + +hasBody :: ResponseBody -> Bool +hasBody NoBody = False +hasBody _ = True + +getFileName :: ResponseBody -> String +getFileName (NoBody) = "" +getFileName (FileBody _size filename) = filename +getFileName (HereItIs _) = "" + +sendBody :: Handle -> ResponseBody -> IO () +sendBody _ NoBody = return () +sendBody h (HereItIs stuff) = do hPutStr h stuff + hFlush h +sendBody h (FileBody _size filename) + = Exception.bracket + (openFile filename ReadMode) + (\hndle -> hClose hndle) + (\hndle -> squirt hndle h >> hFlush h) + + +statusLine :: Int -> String -> String +statusLine cde desc = httpVersion ++ ' ': show cde ++ ' ': desc + +httpVersion :: String +httpVersion = "HTTP/1.1" + + +----------------------------------------------------------------------------- +-- Response Headers + +dateHeader :: IO Header +dateHeader = do + -- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC + clock_time <- getClockTime + let utc = toUTCTime clock_time + let time_str = formatTimeSensibly utc + return $ Header HdrDate time_str + +serverHeader :: Header +serverHeader = Header HdrServer (serverSoftware ++ '/':serverVersion) + + +----------------------------------------------------------------------------- +-- Response codes + +contResponse :: Config -> Response +contResponse = error_resp 100 +switchingProtocolsResponse :: Config -> Response +switchingProtocolsResponse = error_resp 101 +okResponse :: t -> ResponseBody -> Headers -> Bool -> Response +okResponse = body_resp 200 +createdResponse :: Config -> Response +createdResponse = error_resp 201 +acceptedResponse :: Config -> Response +acceptedResponse = error_resp 202 +nonAuthoritiveInformationResponse :: Config + -> Response +nonAuthoritiveInformationResponse = error_resp 203 +noContentResponse :: Config -> Response +noContentResponse = error_resp 204 +resetContentResponse :: Config -> Response +resetContentResponse = error_resp 205 +partialContentResponse :: Config -> Response +partialContentResponse = error_resp 206 +multipleChoicesResponse :: Config -> Response +multipleChoicesResponse = error_resp 300 +movedPermanentlyResponse :: Config -> Response +movedPermanentlyResponse = error_resp 301 +foundResponse :: Config -> Response +foundResponse = error_resp 302 +seeOtherResponse :: Config -> Response +seeOtherResponse = error_resp 303 +notModifiedResponse :: Config -> Response +notModifiedResponse = error_resp 304 +useProxyResponse :: Config -> Response +useProxyResponse = error_resp 305 +temporaryRedirectResponse :: Config -> Response +temporaryRedirectResponse = error_resp 307 +badRequestResponse :: Config -> Response +badRequestResponse = error_resp 400 +unauthorizedResponse :: Config -> Response +unauthorizedResponse = error_resp 401 +paymentRequiredResponse :: Config -> Response +paymentRequiredResponse = error_resp 402 +forbiddenResponse :: Config -> Response +forbiddenResponse = error_resp 403 +notFoundResponse :: Config -> Response +notFoundResponse = error_resp 404 +methodNotAllowedResponse :: Config -> Response +methodNotAllowedResponse = error_resp 405 +notAcceptableResponse :: Config -> Response +notAcceptableResponse = error_resp 406 +proxyAuthenticationRequiredResponse :: Config + -> Response +proxyAuthenticationRequiredResponse = error_resp 407 +requestTimeOutResponse :: Config -> Response +requestTimeOutResponse = error_resp 408 +conflictResponse :: Config -> Response +conflictResponse = error_resp 409 +goneResponse :: Config -> Response +goneResponse = error_resp 410 +lengthRequiredResponse :: Config -> Response +lengthRequiredResponse = error_resp 411 +preconditionFailedResponse :: Config -> Response +preconditionFailedResponse = error_resp 412 +requestEntityTooLargeResponse :: Config -> Response +requestEntityTooLargeResponse = error_resp 413 +requestURITooLargeResponse :: Config -> Response +requestURITooLargeResponse = error_resp 414 +unsupportedMediaTypeResponse :: Config -> Response +unsupportedMediaTypeResponse = error_resp 415 +requestedRangeNotSatisfiableResponse :: Config + -> Response +requestedRangeNotSatisfiableResponse = error_resp 416 +expectationFailedResponse :: Config -> Response +expectationFailedResponse = error_resp 417 +internalServerErrorResponse :: Config -> Response +internalServerErrorResponse = error_resp 500 +notImplementedResponse :: Config -> Response +notImplementedResponse = error_resp 501 +badGatewayResponse :: Config -> Response +badGatewayResponse = error_resp 502 +serviceUnavailableResponse :: Config -> Response +serviceUnavailableResponse = error_resp 503 +gatewayTimeOutResponse :: Config -> Response +gatewayTimeOutResponse = error_resp 504 +versionNotSupportedResponse :: Config -> Response +versionNotSupportedResponse = error_resp 505 + +responseDescription :: Int -> String +responseDescription 100 = "Continue" +responseDescription 101 = "Switching Protocols" + +responseDescription 200 = "OK" +responseDescription 201 = "Created" +responseDescription 202 = "Accepted" +responseDescription 203 = "Non-Authoritative Information" +responseDescription 204 = "No Content" +responseDescription 205 = "Reset Content" +responseDescription 206 = "Partial Content" + +responseDescription 300 = "Multiple Choices" +responseDescription 301 = "Moved Permanently" +responseDescription 302 = "Found" +responseDescription 303 = "See Other" +responseDescription 304 = "Not Modified" +responseDescription 305 = "Use Proxy" +responseDescription 307 = "Temporary Redirect" + +responseDescription 400 = "Bad Request" +responseDescription 401 = "Unauthorized" +responseDescription 402 = "Payment Required" +responseDescription 403 = "Forbidden" +responseDescription 404 = "Not Found" +responseDescription 405 = "Method Not Allowed" +responseDescription 406 = "Not Acceptable" +responseDescription 407 = "Proxy Authentication Required" +responseDescription 408 = "Request Time-out" +responseDescription 409 = "Conflict" +responseDescription 410 = "Gone" +responseDescription 411 = "Length Required" +responseDescription 412 = "Precondition Failed" +responseDescription 413 = "Request Entity Too Large" +responseDescription 414 = "Request-URI Too Large" +responseDescription 415 = "Unsupported Media Type" +responseDescription 416 = "Requested range not satisfiable" +responseDescription 417 = "Expectation Failed" + +responseDescription 500 = "Internal Server Error" +responseDescription 501 = "Not Implemented" +responseDescription 502 = "Bad Gateway" +responseDescription 503 = "Service Unavailable" +responseDescription 504 = "Gateway Time-out" +responseDescription 505 = "HTTP Version not supported" +responseDescription _ = "Unknown response" + +error_resp :: Int -> Config -> Response +error_resp cde conf + = Response cde (responseDescription cde) hs [] + (generateErrorPage cde conf) True + where hs = mkHeaders [contentTypeHeader "text/html"] + +body_resp :: Int -> t -> ResponseBody -> Headers -> Bool -> Response +body_resp cde _conf bdy headers sendbody = + Response cde (responseDescription cde) headers [] bdy sendbody + +----------------------------------------------------------------------------- +-- Error pages + +-- We generate some html for the client to display on an error. + +generateErrorPage :: Int -> Config -> ResponseBody +generateErrorPage cde conf + = HereItIs (renderHtml (genErrorHtml cde conf)) + +genErrorHtml :: Int -> Config -> Html +genErrorHtml cde conf + = header << thetitle << response + +++ body << + (h1 << response + +++ hr + +++ serverSoftware +++ '/' +++ serverVersion + -- ToDo: use real hostname if we don't have a serverName + +++ case serverName conf of + "" -> noHtml + me -> " on " +++ me +++ br + +++ case serverAdmin conf of + "" -> noHtml + her -> "Server Admin: " +++ + hotlink ("mailto:"++her) [toHtml her] + ) + where + descr = responseDescription cde + response = show cde +++ ' ' +++ descr diff --git a/src/ServerRequest.hs b/src/ServerRequest.hs new file mode 100644 --- /dev/null +++ b/src/ServerRequest.hs @@ -0,0 +1,19 @@ +-- Copyright 2006, Bjorn Bringert. +module ServerRequest where + +import Request + +import Network.BSD (HostEntry) +import Network.Socket (HostAddress) + +-- | All the server's information about a request +data ServerRequest = ServerRequest + { + clientRequest :: Request, + clientAddress :: HostAddress, + clientName :: Maybe HostEntry, + requestHostName :: HostEntry, + serverURIPath :: String, + serverFilename :: FilePath + } + deriving Show diff --git a/src/ServerState.hs b/src/ServerState.hs new file mode 100644 --- /dev/null +++ b/src/ServerState.hs @@ -0,0 +1,111 @@ +-- Copyright 2006, Bjorn Bringert. +module ServerState where + +import Config +import AccessLogger +import ErrorLogger +import LogLevel +import MimeTypes +import Options +import Response +import ServerRequest +import Util + +import Control.Concurrent (myThreadId) +import Control.Monad +import Network.BSD (HostEntry) +import System.Time (TimeDiff) + +-- +-- * Module API +-- + +data ModuleDesc = ModuleDesc + { + moduleName :: String, + moduleLoad :: IO Module + } + +emptyModuleDesc :: ModuleDesc +emptyModuleDesc = ModuleDesc + { + moduleName = "", + moduleLoad = return emptyModule + } + +data Module = Module + { + moduleLoadConfig :: ServerState -> IO (), + moduleTranslatePath :: ServerState -> String -> IO (Maybe FilePath), + moduleTweakRequest :: ServerState -> ServerRequest -> IO ServerRequest, + moduleHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response) + } + +emptyModule :: Module +emptyModule = Module { + moduleLoadConfig = \_ -> return (), + moduleTranslatePath = \_ _ -> return Nothing, + moduleTweakRequest = \_ r -> return r, + moduleHandleRequest = \_ _ -> return Nothing + } + +tweakFilename :: (ServerState -> FilePath -> IO FilePath) + -> ServerState -> ServerRequest -> IO ServerRequest +tweakFilename f conf req = + do filename' <- f conf (serverFilename req) + return $ req { serverFilename = filename' } + + +-- +-- * ServerState +-- + +data ServerState = ServerState + { + serverOptions :: Options, + serverConfig :: Config, + serverHostName :: HostEntry, + serverPort :: Int, + serverMimeTypes :: MimeTypes, + serverErrorLogger :: ErrorLoggerHandle, + serverAccessLoggers :: [AccessLoggerHandle], + serverModules :: [Module] + } + +-- * MIME types + +getMimeType :: ServerState -> FilePath -> String +getMimeType st filename = + maybe def show (mimeTypeOf (serverMimeTypes st) filename) + where def = defaultType (serverConfig st) + +-- ** Logging + +debug :: ServerState -> String -> IO () +debug st s = do t <- myThreadId + logDebug st $ show t ++ ": " ++ s + +logError :: ServerState -> String -> IO () +logError st = logErrorMessage (serverErrorLogger st) LogError + +logInfo :: ServerState -> String -> IO () +logInfo st = logErrorMessage (serverErrorLogger st) LogInfo + +logDebug :: ServerState -> String -> IO () +logDebug st = logErrorMessage (serverErrorLogger st) LogDebug + +logAccess :: ServerState -> ServerRequest -> Response -> TimeDiff -> IO () +logAccess st req resp delay = + do msg <- mkAccessLogRequest req resp (serverHostName st) delay + mapM_ (\l -> logAccessLogRequest l msg) (serverAccessLoggers st) + +-- ** Modules + +mapModules_ :: ServerState -> (Module -> IO ()) -> IO () +mapModules_ st f = mapM_ f (serverModules st) + +foldModules :: ServerState -> (Module -> a -> IO a) -> a -> IO a +foldModules st f x = foldM (flip f) x (serverModules st) + +tryModules :: ServerState -> (Module -> IO (Maybe a)) -> IO (Maybe a) +tryModules st f = firstJustM f (serverModules st) diff --git a/src/StaticModules.hs b/src/StaticModules.hs new file mode 100644 --- /dev/null +++ b/src/StaticModules.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +-- Copyright 2006, Bjorn Bringert. +module StaticModules (staticModules) where + +import ServerState (ModuleDesc) + + +import Module.Userdir +import Module.Index +import Module.CGI +#ifdef DYNHS +import Module.DynHS +#endif +import Module.File + +staticModules :: [ModuleDesc] +staticModules = + [ + Module.Userdir.desc, + Module.Index.desc, + Module.CGI.desc, +#ifdef DYNHS + Module.DynHS.desc, +#endif + Module.File.desc + ] diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,228 @@ +-- ----------------------------------------------------------------------------- +-- 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 Util where + +import Control.Exception as Exception +import Control.Concurrent +import Control.Monad +import Data.Array.IO +import Data.Char +import Data.List +import Data.Ratio (numerator) +import Foreign.C.Error (getErrno, eNOENT, eNOTDIR) +import Network.Socket as Socket +import System.IO +import System.Exit +import System.Locale +import System.Posix +import System.Time + +----------------------------------------------------------------------------- +-- Utils + +-- ToDo: deHex is supposed to remove the '%'-encoding +deHex :: String -> String +deHex s = s + +hPutStrCrLf :: Handle -> String -> IO () +hPutStrCrLf h s = hPutStr h s >> hPutChar h '\r' >> hPutChar h '\n' + +die :: String -> IO () +die err = do hPutStrLn stderr err + exitFailure + +----------------------------------------------------------------------------- +-- String utils + +readM :: (Read a, Monad m) => String -> m a +readM s = readSM reads s + +readSM :: Monad m => ReadS a -> String -> m a +readSM f s = case f s of + [] -> fail $ "No parse of " ++ show s + [(x,[])] -> return x + [(_,_)] -> fail $ "Junk at end of " ++ show s + _ -> fail $ "Ambiguous parse of " ++ show s + +lookupLC :: String -> [(String,a)] -> Maybe a +lookupLC s xs = lookup (map toLower s) [(map toLower n,v) | (n,v) <- xs] + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +unlinesS :: [ShowS] -> ShowS +unlinesS = concatS . map (. showChar '\n') + + +----------------------------------------------------------------------------- +-- List utils + +-- Split a list at some delimiter. +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [[]] +splitBy f xs = first : case rest of + _:ys -> splitBy f ys + [] -> [] + where (first, rest) = break f xs + +glue :: [a] -> [[a]] -> [a] +glue g = concat . intersperse g + +splits :: [a] -> [([a],[a])] +splits xs = zip (inits xs) (tails xs) + +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix xs pref | pref `isPrefixOf` xs = drop (length pref) xs + | otherwise = xs + +dropSuffix :: Eq a => [a] -> [a] -> [a] +dropSuffix xs suf = reverse (reverse xs `dropPrefix` reverse suf) + +----------------------------------------------------------------------------- +-- File path utils + +splitPath :: FilePath -> [String] +splitPath = splitBy (=='/') + +joinPath :: [String] -> FilePath +joinPath = glue "/" + +-- Get the directory component of a path +-- FIXME: is this good enough? +dirname :: FilePath -> FilePath +dirname = reverse . dropWhile (/= '/') . reverse + +-- Get the filename component of a path +-- FIXME: probably System.FilePath should be used here. +basename :: FilePath -> FilePath +basename = reverse . takeWhile (/= '/') . reverse + +----------------------------------------------------------------------------- +-- Monad utils + +firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +firstJustM _ [] = return Nothing +firstJustM f (x:xs) = f x >>= maybe (firstJustM f xs) (return . Just) + + +----------------------------------------------------------------------------- +-- Parsec utils + +----------------------------------------------------------------------------- +-- Time utils + +formatTimeSensibly :: CalendarTime -> String +formatTimeSensibly time + = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" time + +epochTimeToClockTime :: EpochTime -> ClockTime +epochTimeToClockTime epoch_time = TOD (numToInteger epoch_time) 0 + where numToInteger = numerator . toRational + +----------------------------------------------------------------------------- +-- concurrency utilities + +-- block forever +wait :: IO a +wait = newEmptyMVar >>= takeMVar + +----------------------------------------------------------------------------- +-- networking utils + +accept :: Socket -- Listening Socket + -> IO (Handle,SockAddr) -- StdIO Handle for read/write +accept sock = do + (sock', addr) <- Socket.accept sock + hndle <- socketToHandle sock' ReadWriteMode + return (hndle,addr) + +----------------------------------------------------------------------------- +-- file utils + +statFile :: String -> IO (Maybe FileStatus) +statFile = stat_ getFileStatus + +statSymLink :: String -> IO (Maybe FileStatus) +statSymLink = stat_ getSymbolicLinkStatus + +stat_ :: (FilePath -> IO FileStatus) -> String -> IO (Maybe FileStatus) +stat_ f filename = do + maybe_stat <- tryJust ioErrors (f filename) + case maybe_stat of + Left e -> do + errno <- getErrno + if errno == eNOENT || errno == eNOTDIR + then return Nothing + else ioError e + Right stat -> + return (Just stat) + +isSymLink :: FilePath -> IO Bool +isSymLink = liftM (maybe False isSymbolicLink) . statSymLink + +----------------------------------------------------------------------------- +-- I/O utils +bufsize :: Int +bufsize = 4 * 1024 + +-- squirt data from 'rd' into 'wr' as fast as possible. We use a 4k +-- single buffer. +squirt :: Handle -> Handle -> IO () +squirt rd wr = do + arr <- newArray_ (0, bufsize-1) + let loop = do r <- hGetArray rd arr bufsize + if (r == 0) + then return () + else if (r < bufsize) + then hPutArray wr arr r + else hPutArray wr arr bufsize >> loop + loop + +-- | Read the given number of bytes from a Handle +hGetChars :: Handle -> Int -> IO String +hGetChars _ 0 = return "" +hGetChars h n = do arr <- newArray_ (0, n-1) + r <- hGetArray h arr n + when (r < n) $ fail $ "" + -- FIXME: input encoding? + liftM (map (toEnum . fromEnum)) $ getElems arr + +----------------------------------------------------------------------------- +-- Exception utils + +-- | Catch IO Errors for which a given predicate is true. +catchSomeIOErrors :: (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a +catchSomeIOErrors p = catchJust p' + where p' (IOException e) | p e = Just e + p' _ = Nothing