mohws (empty) → 0.1
raw patch · 28 files changed
+3321/−0 lines, 28 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, directory, html, network, old-locale, old-time, parsec, process, unix
Files
- LICENSE +29/−0
- README +68/−0
- Setup.lhs +8/−0
- mohws.cabal +41/−0
- src/AccessLogger.hs +129/−0
- src/Config.hs +116/−0
- src/ConfigParser.hs +177/−0
- src/ErrorLogger.hs +82/−0
- src/Headers.hs +317/−0
- src/LogLevel.hs +32/−0
- src/Logger.hs +124/−0
- src/Main.hs +490/−0
- src/MimeTypes.hs +94/−0
- src/Module/CGI.hs +207/−0
- src/Module/DynHS.hs +79/−0
- src/Module/DynHS/CGI.hs +47/−0
- src/Module/DynHS/GHCUtil.hs +98/−0
- src/Module/File.hs +70/−0
- src/Module/Index.hs +40/−0
- src/Module/Userdir.hs +35/−0
- src/Options.hs +58/−0
- src/Parse.hs +84/−0
- src/Request.hs +208/−0
- src/Response.hs +304/−0
- src/ServerRequest.hs +19/−0
- src/ServerState.hs +111/−0
- src/StaticModules.hs +26/−0
- src/Util.hs +228/−0
+ LICENSE view
@@ -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.
+ README view
@@ -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).
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ mohws.cabal view
@@ -0,0 +1,41 @@+Name: mohws+Version: 0.1+Author: Simon Marlow, Bjorn Bringert+Copyright: Simon Marlow, Bjorn Bringert+Maintainer: Bjorn Bringert <bjorn@bringert.net>+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
+ src/AccessLogger.hs view
@@ -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
+ src/Config.hs view
@@ -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"
+ src/ConfigParser.hs view
@@ -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)+
+ src/ErrorLogger.hs view
@@ -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)
+ src/Headers.hs view
@@ -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)+
+ src/LogLevel.hs view
@@ -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 ]
+ src/Logger.hs view
@@ -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
+ src/Main.hs view
@@ -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
+ src/MimeTypes.hs view
@@ -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
+ src/Module/CGI.hs view
@@ -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)
+ src/Module/DynHS.hs view
@@ -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))+
+ src/Module/DynHS/CGI.hs view
@@ -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"
+ src/Module/DynHS/GHCUtil.hs view
@@ -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
+ src/Module/File.hs view
@@ -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
+ src/Module/Index.hs view
@@ -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
+ src/Module/Userdir.hs view
@@ -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
+ src/Options.hs view
@@ -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 ("<server-root>/" ++ 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)
+ src/Parse.hs view
@@ -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)
+ src/Request.hs view
@@ -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+
+ src/Response.hs view
@@ -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) = "<no file>"+getFileName (FileBody _size filename) = filename+getFileName (HereItIs _) = "<generated content>"++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
+ src/ServerRequest.hs view
@@ -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
+ src/ServerState.hs view
@@ -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 = "<unnamed module>",+ 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)
+ src/StaticModules.hs view
@@ -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+ ]
+ src/Util.hs view
@@ -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