diff --git a/mohws.cabal b/mohws.cabal --- a/mohws.cabal +++ b/mohws.cabal @@ -1,20 +1,23 @@ Name: mohws -Version: 0.1 -Author: Simon Marlow, Bjorn Bringert +Version: 0.2 +Author: Simon Marlow, Bjorn Bringert Copyright: Simon Marlow, Bjorn Bringert -Maintainer: Bjorn Bringert +Maintainer: Henning Thielemann 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/ + 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/ +Tested-with: GHC==6.8.2 +Build-Type: Simple Build-depends: base>3, directory, + HTTP >=4000.0.4 && <4001, network, unix, parsec, @@ -23,19 +26,74 @@ containers, old-time, old-locale, - array -Data-files: README -Tested-with: GHC==6.8.2 -Build-Type: Simple + bytestring, + filepath, + utility-ht >=0.0.3 && <0.1, + transformers >=0.1.3 && <0.2, + explicit-exception >=0.1 && <0.2, + data-accessor >=0.2 && <0.3 +Data-Files: + README + public_html/html.cgi + public_html/Pi.hs + public_html/text.cgi +Hs-Source-dirs: src +Ghc-Options: -threaded -Wall +Exposed-Modules: + -- server + Network.MoHWS.Server + Network.MoHWS.Server.Context + Network.MoHWS.Server.Request + Network.MoHWS.Server.Options + -- logging + Network.MoHWS.Logger + Network.MoHWS.Logger.Access + Network.MoHWS.Logger.Error + Network.MoHWS.Logger.Level + -- configuration + Network.MoHWS.Configuration + Network.MoHWS.Configuration.Accessor + Network.MoHWS.Configuration.Parser + Network.MoHWS.Initialization + Network.MoHWS.Initialization.Standard + -- http + Network.MoHWS.HTTP.Header + Network.MoHWS.HTTP.MimeType + Network.MoHWS.HTTP.Request + Network.MoHWS.HTTP.Response + Network.MoHWS.HTTP.Version + -- module system + Network.MoHWS.Module + Network.MoHWS.Module.Description + Network.MoHWS.Part.AddSlash + Network.MoHWS.Part.CGI + Network.MoHWS.Part.File + Network.MoHWS.Part.Index + Network.MoHWS.Part.Listing + Network.MoHWS.Part.UserDirectory + Network.MoHWS.Part.VirtualHost + -- basics + Network.MoHWS.Stream +Other-Modules: + Network.MoHWS.Utility + Network.MoHWS.ParserUtility + Network.MoHWS.Server.Environment + Network.MoHWS.ByteString + 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 +Hs-Source-dirs: src +Ghc-Options: -threaded -Wall + +Executable: hws-dyn +-- Buildable: False +Main-is: MainDynamic.hs +Hs-Source-dirs: src +Ghc-Options: -threaded -Wall +Build-Depends: ghc >=6.8 && <6.9 + -- ghc package needed for GHCUtil in DynHS +Other-Modules: + Network.MoHWS.Part.DynHS + Network.MoHWS.Part.DynHS.CGI + Network.MoHWS.Part.DynHS.GHCUtil diff --git a/public_html/Pi.hs b/public_html/Pi.hs new file mode 100644 --- /dev/null +++ b/public_html/Pi.hs @@ -0,0 +1,5 @@ +module Pi where + +cgiMain :: [(String,String)] -> [(String,String)] -> IO ([(String,String)], String) +cgiMain _ _ = + return ([("Content-Type", "text/plain")], show (pi::Double)) diff --git a/public_html/html.cgi b/public_html/html.cgi new file mode 100644 --- /dev/null +++ b/public_html/html.cgi @@ -0,0 +1,16 @@ +#! /bin/bash +echo Content-Type: text/html +echo +echo '' +echo '' +echo 'Hello World' +echo '' +echo '' +echo '
    ' +echo '
  • Hello World
    • ' +echo '
  • '`date`'
    • ' +echo '
  • Query: '$QUERY_STRING'
    • ' +echo '
  • Port: '$SERVER_PORT'
    • ' +echo '
' +echo '' +echo '' diff --git a/public_html/text.cgi b/public_html/text.cgi new file mode 100644 --- /dev/null +++ b/public_html/text.cgi @@ -0,0 +1,6 @@ +#! /bin/bash +echo Content-Type: text/plain +echo +echo Hello World +date +echo Query: $QUERY_STRING diff --git a/src/AccessLogger.hs b/src/AccessLogger.hs deleted file mode 100644 --- a/src/AccessLogger.hs +++ /dev/null @@ -1,129 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module AccessLogger ( - AccessLoggerHandle, - AccessLogRequest(..), - startAccessLogger, - stopAccessLogger, - mkAccessLogRequest, - logAccessLogRequest - ) where - -import Logger -import Headers -import Response -import ServerRequest -import Util - -import Network.BSD (HostEntry, hostName) -import Network.Socket (inet_ntoa) -import System.Time -import System.IO.Unsafe (unsafePerformIO) - -type AccessLoggerHandle = LoggerHandle AccessLogRequest - -data AccessLogRequest = AccessLogRequest - { - log_request :: ServerRequest, - log_response :: Response, - log_server_host :: HostEntry, - log_time :: ClockTime, - log_delay :: TimeDiff - } - - -startAccessLogger :: String -> FilePath -> IO AccessLoggerHandle -startAccessLogger format file = startLogger f file - where f = mkLogLine format - -mkLogLine :: String -> AccessLogRequest -> String -mkLogLine "" _ = "" -mkLogLine ('%':'{':rest) r = - case span (/= '}') rest of - (str, '}':c:rest1) -> expand (Just str) c r ++ mkLogLine rest1 r - _ -> '%':'{':mkLogLine rest r -mkLogLine ('%':c:rest) r = expand Nothing c r ++ mkLogLine rest r -mkLogLine (c:rest) r = c : mkLogLine rest r - -expand :: Maybe String -> Char -> AccessLogRequest -> String -expand arg c info = - case c of - 'b' -> let len = responseBodyLength (respBody resp) - in if len == 0 then "-" else show len - 'f' -> serverFilename sreq - - -- %h is the hostname if hostnameLookups is on, otherwise the - -- IP address. - 'h' -> maybe addr hostName (clientName sreq) - 'a' -> addr - 'l' -> "-" -- FIXME: does anyone use identd these days? - 'r' -> show req - -- ToDo: 'p' -> canonical port number of server - 's' -> show (respCode resp) - 't' -> formatTimeSensibly (toUTCTime (log_time info)) - 'T' -> timeDiffToString (log_delay info) - 'v' -> hostName (log_server_host info) - 'u' -> "-" -- FIXME: implement HTTP auth - - 'i' -> header req arg - 'o' -> header resp arg - - -- ToDo: other stuff - _ -> ['%',c] - where - resp = log_response info - sreq = log_request info - req = clientRequest sreq --- host = clientName (log_request info) - header _ Nothing = "" - header x (Just n) = unwords (lookupHeaders (mkHeaderName n) x) - addr = unsafePerformIO (inet_ntoa (clientAddress sreq)) - -stopAccessLogger :: AccessLoggerHandle -> IO () -stopAccessLogger l = stopLogger l - -mkAccessLogRequest :: ServerRequest -> Response -> HostEntry -> TimeDiff -> IO AccessLogRequest -mkAccessLogRequest req resp host delay = - do time <- getClockTime - return $ AccessLogRequest - { - log_request = req, - log_response = resp, - log_server_host = host, - log_time = time, - log_delay = delay - } - -logAccessLogRequest :: AccessLoggerHandle -> AccessLogRequest -> IO () -logAccessLogRequest l r = logMessage l r diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,116 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module Config where - -import LogLevel - ------------------------------------------------------------------------------ --- Config info - -data Config = Config { - user :: String, - group :: String, - - listen :: [(Maybe String,Int)], - - requestTimeout :: Int, - keepAliveTimeout :: Int, - maxClients :: Int, - - serverAdmin :: String, -- "" indicates no admin - serverName :: String, -- "" indicates no canon name - serverAlias :: [String], - useCanonicalName :: Bool, - hostnameLookups :: Bool, - - documentRoot :: String, - userDir :: String, - directoryIndex :: String, - accessFileName :: String, - indexes :: Bool, - followSymLinks :: Bool, - - typesConfig :: String, - defaultType :: String, - - addLanguage :: [(String,String)], - languagePriority :: [String], - - customLogs :: [(FilePath, String)], - - errorLogFile :: String, - logLevel :: LogLevel - } - deriving Show - -defaultConfig :: Config -defaultConfig = Config{ - user = "nobody", - group = "nobody", - - listen = [(Nothing,80)], - - requestTimeout = 300, - keepAliveTimeout = 15, - maxClients = 150, - - serverAdmin = "", - serverName = "", - serverAlias = [], - useCanonicalName = False, - hostnameLookups = False, - - documentRoot = ".", - userDir = "", - directoryIndex = "index.html", - accessFileName = ".htaccess", - indexes = False, - followSymLinks = False, - - typesConfig = "/etc/mime.types", - defaultType = "text/plain", - - addLanguage = [], - languagePriority = [], - - customLogs = [("http-access.log", - "%h %l %u %t \"%r\" %s %b \"%{Referer}i\" \"%{User-Agent}i\"")], - - errorLogFile = "httpd-error.log", - logLevel = LogWarn - } - --- not user-definable... -serverSoftware, serverVersion :: String -serverSoftware = "HWS" -serverVersion = "0.1" diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs deleted file mode 100644 --- a/src/ConfigParser.hs +++ /dev/null @@ -1,177 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module ConfigParser (parseConfig) where - -import Config -import Parse -import Util - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Language -import Text.ParserCombinators.Parsec.Token - - -type ConfigBuilder = Config -> Config - -p :: TokenParser st -p = makeTokenParser tokenDef - -tokenDef :: LanguageDef st -tokenDef = emptyDef { - commentLine = "#", - nestedComments = False, - reservedOpNames = [], - reservedNames = [], - caseSensitive = False - } - - -parseConfig :: String -> IO (Either ParseError ConfigBuilder) -parseConfig fname - = parseFromFile configParser fname - -configParser :: Parser ConfigBuilder -configParser = do - whiteSpace p - cs <- many configLine - eof - return (fixConfig . foldr (.) id cs) - -fixConfig :: Config -> Config -fixConfig conf = conf { listen = f (listen conf) } - where f xs | length xs > 1 = init xs - | otherwise = xs - -configLine :: Parser ConfigBuilder -configLine - = do (reserved p "user" >> p_user) - <|> (reserved p "group" >> p_group) - <|> (reserved p "timeout" >> p_timeout) - <|> (reserved p "keepalivetimeout" >> p_keepAliveTimeout) - <|> (reserved p "maxclients" >> p_maxClients) - <|> (reserved p "listen" >> p_listen) - <|> (reserved p "serveradmin" >> p_serverAdmin) - <|> (reserved p "servername" >> p_serverName) - <|> (reserved p "serveralias" >> p_serverAlias) - <|> (reserved p "usecanonicalname" >> p_useCanonicalName) - <|> (reserved p "documentroot" >> p_documentRoot) - <|> (reserved p "userdir" >> p_userDir) - <|> (reserved p "directoryindex" >> p_directoryIndex) - <|> (reserved p "accessfilename" >> p_accessFileName) - <|> (reserved p "typesconfig" >> p_typesConfig) - <|> (reserved p "defaulttype" >> p_defaultType) - <|> (reserved p "hostnamelookups" >> p_hostnameLookups) - <|> (reserved p "errorlog" >> p_errorLog) - <|> (reserved p "loglevel" >> p_logLevel) - <|> (reserved p "customlog" >> p_customLog) - <|> (reserved p "listen" >> p_listen) - <|> (reserved p "addlanguage" >> p_addlanguage) - <|> (reserved p "languagepriority" >> p_languagepriority) - -p_user :: GenParser Char st (Config -> Config) -p_user = do str <- stringLiteral p; return (\c -> c{user = str}) -p_group :: GenParser Char st (Config -> Config) -p_group = do str <- stringLiteral p; return (\c -> c{group = str}) -p_timeout :: GenParser Char () (Config -> Config) -p_timeout = do i <- int; return (\c -> c{requestTimeout = i}) -p_keepAliveTimeout :: GenParser - Char () (Config -> Config) -p_keepAliveTimeout = do i <- int; return (\c -> c{keepAliveTimeout = i}) -p_maxClients :: GenParser Char () (Config -> Config) -p_maxClients = do i <- int; return (\c -> c{maxClients = i}) -p_serverAdmin :: GenParser Char st (Config -> Config) -p_serverAdmin = do str <- stringLiteral p; return (\c -> c{serverAdmin = str}) -p_serverName :: GenParser Char st (Config -> Config) -p_serverName = do str <- stringLiteral p; return (\c -> c{serverName = str}) -p_serverAlias :: GenParser Char st (Config -> Config) -p_serverAlias = do str <- stringLiteral p - return (\c -> c{serverAlias = str : serverAlias c}) -p_useCanonicalName :: GenParser Char st (Config -> Config) -p_useCanonicalName = do b <- bool; return (\c -> c{useCanonicalName = b}) -p_documentRoot :: GenParser Char st (Config -> Config) -p_documentRoot = do str <- stringLiteral p; return (\c -> c{documentRoot = str}) -p_userDir :: GenParser Char st (Config -> Config) -p_userDir = do str <- stringLiteral p; return (\c -> c{userDir = str}) -p_directoryIndex :: GenParser Char st (Config -> Config) -p_directoryIndex = do str <- stringLiteral p; return (\c -> c{directoryIndex = str}) -p_accessFileName :: GenParser Char st (Config -> Config) -p_accessFileName = do str <- stringLiteral p; return (\c -> c{accessFileName = str}) -p_typesConfig :: GenParser Char st (Config -> Config) -p_typesConfig = do str <- stringLiteral p; return (\c -> c{typesConfig = str}) -p_defaultType :: GenParser Char st (Config -> Config) -p_defaultType = do str <- stringLiteral p; return (\c -> c{defaultType = str}) - -p_hostnameLookups :: GenParser Char st (Config -> Config) -p_hostnameLookups = do b <- bool; return (\c -> c{hostnameLookups = b}) -p_errorLog :: GenParser Char st (Config -> Config) -p_errorLog = do str <- stringLiteral p; return (\c -> c{errorLogFile = str}) - -p_logLevel :: GenParser Char st (Config -> Config) -p_logLevel = do i <- identifier p >>= readM - return (\c -> c{logLevel = i}) - -p_customLog :: GenParser Char st (Config -> Config) -p_customLog = do file <- stringLiteral p - format <- stringLiteral p - return (\c -> c { customLogs = (file,format) : customLogs c}) - -p_listen :: GenParser Char () (Config -> Config) -p_listen = do maddr <- p_addr - port <- int - return (\c -> c{ listen = (maddr,port) : listen c}) - where - p_addr = option Nothing $ try $ do addr <- p_ip_addr - char ':' - return $ Just addr - p_ip_addr = do b1 <- p_dec_byte - char '.' - b2 <- p_dec_byte - char '.' - b3 <- p_dec_byte - char '.' - b4 <- p_dec_byte - return (b1++"."++b2++"."++b3++"."++b4) - p_dec_byte = countBetween 1 3 digit - -p_addlanguage :: GenParser Char st (Config -> Config) -p_addlanguage = do lang <- stringLiteral p; ext <- stringLiteral p; return (\c -> c{addLanguage = (lang,ext) : addLanguage c}) -p_languagepriority :: GenParser Char st (Config -> Config) -p_languagepriority = do langs <- many (stringLiteral p); return (\c -> c{languagePriority = langs}) - -bool :: GenParser Char st Bool -bool = do { reserved p "On"; return True } - <|> do { reserved p "Off"; return False } - -int :: Parser Int -int = do i <- integer p; return (fromInteger i) - diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs deleted file mode 100644 --- a/src/ErrorLogger.hs +++ /dev/null @@ -1,82 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module ErrorLogger ( - ErrorLoggerHandle, - startErrorLogger, - stopErrorLogger, - logErrorMessage - ) where - -import Logger -import LogLevel -import Util - -import System.IO -import System.Time - -data ErrorLoggerHandle = ErrorLoggerHandle - { - errorLogger ::LoggerHandle ErrorLoggerMessage, - errorMinLevel :: LogLevel - } - -data ErrorLoggerMessage = ErrorLoggerMessage - { - errorTime :: ClockTime, - errorString :: String - } - - -startErrorLogger :: FilePath -> LogLevel -> IO ErrorLoggerHandle -startErrorLogger file level = - do l <- startLogger format file - let h = ErrorLoggerHandle { - errorLogger = l, - errorMinLevel = level - } - logErrorMessage h LogWarn $ "Starting error logger with log level " - ++ show level ++ "..." - return h - where format m = formatTimeSensibly (toUTCTime (errorTime m)) - ++ " " ++ errorString m - -stopErrorLogger :: ErrorLoggerHandle -> IO () -stopErrorLogger l = do logErrorMessage l LogWarn "Stopping error logger..." - stopLogger (errorLogger l) - -logErrorMessage :: ErrorLoggerHandle -> LogLevel -> String -> IO () -logErrorMessage l level s - | level < errorMinLevel l = return () - | otherwise = do time <- getClockTime - logMessage (errorLogger l) (ErrorLoggerMessage time s) diff --git a/src/Headers.hs b/src/Headers.hs deleted file mode 100644 --- a/src/Headers.hs +++ /dev/null @@ -1,317 +0,0 @@ --- Copyright 2002 Warrick Gray --- Copyright 2001,2002 Peter Thiemann --- Copyright 2003-2006 Bjorn Bringert -module Headers (Headers(..), - mkHeaders, - Header(..), - HeaderName(..), - HasHeaders(..), - -- * Header parsing - pHeaders, mkHeaderName, - -- * Header manipulation - insertHeader, - insertHeaderIfMissing, - replaceHeader, insertHeaders, - lookupHeaders, lookupHeader, - -- * Constructing headers - contentLengthHeader, - contentTypeHeader, - lastModifiedHeader, - TransferCoding, - transferCodingHeader, - -- * Getting values of specific headers - getContentType, getContentLength - ) where - -import Parse -import Util - -import Control.Monad (liftM) -import Data.Char (toLower) -import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) -import Data.Maybe (listToMaybe) -import System.Time (ClockTime, toUTCTime) -import Text.ParserCombinators.Parsec - -newtype Headers = Headers { unHeaders :: [Header] } - -mkHeaders :: [Header] -> Headers -mkHeaders = Headers - -instance Show Headers where - showsPrec _ - = foldr (.) id . map (\x -> shows x . showString crLf) . unHeaders - -instance HasHeaders Headers where - getHeaders = id - setHeaders _ = id - - --- | This class allows us to write generic header manipulation functions --- for both 'Request' and 'Response' data types. -class HasHeaders x where - getHeaders :: x -> Headers - setHeaders :: x -> Headers -> x - listHeaders :: x -> [Header] - listHeaders = unHeaders . getHeaders - modifyHeaders :: ([Header] -> [Header]) -> x -> x - modifyHeaders f x = setHeaders x $ mkHeaders $ f $ listHeaders x - --- | The Header data type pairs header names & values. -data Header = Header HeaderName String - -instance Show Header where - showsPrec _ (Header key value) - = shows key . showString ": " . showString value - - --- | HTTP Header Name type: --- Why include this at all? I have some reasons --- 1) prevent spelling errors of header names, --- 2) remind everyone of what headers are available, --- 3) might speed up searches for specific headers. --- --- Arguments against: --- 1) makes customising header names laborious --- 2) increases code volume. --- -data HeaderName = - -- Generic Headers -- - HdrCacheControl - | HdrConnection - | HdrDate - | HdrPragma - | HdrTrailer - | HdrTransferEncoding - | HdrUpgrade - | HdrVia - - -- Request Headers -- - | HdrAccept - | HdrAcceptCharset - | HdrAcceptEncoding - | HdrAcceptLanguage - | HdrAuthorization - | HdrCookie - | HdrExpect - | HdrFrom - | HdrHost - | HdrIfModifiedSince - | HdrIfMatch - | HdrIfNoneMatch - | HdrIfRange - | HdrIfUnmodifiedSince - | HdrMaxForwards - | HdrProxyAuthorization - | HdrRange - | HdrReferer - | HdrTE - | HdrUserAgent - - -- Response Headers - | HdrAge - | HdrLocation - | HdrProxyAuthenticate - | HdrPublic - | HdrRetryAfter - | HdrServer - | HdrSetCookie - | HdrVary - | HdrWarning - | HdrWWWAuthenticate - - -- Entity Headers - | HdrAllow - | HdrContentBase - | HdrContentEncoding - | HdrContentLanguage - | HdrContentLength - | HdrContentLocation - | HdrContentMD5 - | HdrContentRange - | HdrContentType - | HdrETag - | HdrExpires - | HdrLastModified - - -- Mime entity headers (for sub-parts) - | HdrContentTransferEncoding - - -- | Allows for unrecognised or experimental headers. - | HdrCustom String -- not in header map below. - deriving (Eq,Ord) - - --- Translation between header names and values, -headerNames :: [ (String,HeaderName) ] -headerNames - = [ ("Cache-Control" ,HdrCacheControl ) - , ("Connection" ,HdrConnection ) - , ("Date" ,HdrDate ) - , ("Pragma" ,HdrPragma ) - , ("Trailer" ,HdrTrailer ) - - , ("Transfer-Encoding" ,HdrTransferEncoding ) - , ("Upgrade" ,HdrUpgrade ) - , ("Via" ,HdrVia ) - , ("Accept" ,HdrAccept ) - , ("Accept-Charset" ,HdrAcceptCharset ) - , ("Accept-Encoding" ,HdrAcceptEncoding ) - , ("Accept-Language" ,HdrAcceptLanguage ) - , ("Authorization" ,HdrAuthorization ) - , ("From" ,HdrFrom ) - , ("Host" ,HdrHost ) - , ("If-Modified-Since" ,HdrIfModifiedSince ) - , ("If-Match" ,HdrIfMatch ) - , ("If-None-Match" ,HdrIfNoneMatch ) - , ("If-Range" ,HdrIfRange ) - , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince ) - , ("Max-Forwards" ,HdrMaxForwards ) - , ("Proxy-Authorization" ,HdrProxyAuthorization) - , ("Range" ,HdrRange ) - , ("Referer" ,HdrReferer ) - , ("TE" ,HdrTE ) - , ("User-Agent" ,HdrUserAgent ) - , ("Age" ,HdrAge ) - , ("Location" ,HdrLocation ) - , ("Proxy-Authenticate" ,HdrProxyAuthenticate ) - , ("Public" ,HdrPublic ) - , ("Retry-After" ,HdrRetryAfter ) - , ("Server" ,HdrServer ) - , ("Vary" ,HdrVary ) - , ("Warning" ,HdrWarning ) - , ("WWW-Authenticate" ,HdrWWWAuthenticate ) - , ("Allow" ,HdrAllow ) - , ("Content-Base" ,HdrContentBase ) - , ("Content-Encoding" ,HdrContentEncoding ) - , ("Content-Language" ,HdrContentLanguage ) - , ("Content-Length" ,HdrContentLength ) - , ("Content-Location" ,HdrContentLocation ) - , ("Content-MD5" ,HdrContentMD5 ) - , ("Content-Range" ,HdrContentRange ) - , ("Content-Type" ,HdrContentType ) - , ("ETag" ,HdrETag ) - , ("Expires" ,HdrExpires ) - , ("Last-Modified" ,HdrLastModified ) - , ("Set-Cookie" ,HdrSetCookie ) - , ("Cookie" ,HdrCookie ) - , ("Expect" ,HdrExpect ) ] - -toHeaderNameMap :: Map String HeaderName -toHeaderNameMap = Map.fromList [(map toLower x, y) | (x,y) <- headerNames] - -fromHeaderNameMap :: Map HeaderName String -fromHeaderNameMap = Map.fromList [(y,x) | (x,y) <- headerNames] - -instance Show HeaderName where - show (HdrCustom s) = s - show x = case Map.lookup x fromHeaderNameMap of - Nothing -> error "headerNames incomplete" - Just h -> h - -mkHeaderName :: String -> HeaderName -mkHeaderName s = - case Map.lookup (map toLower s) toHeaderNameMap of - Just n -> n - Nothing -> HdrCustom s - - --- * Header manipulation functions - --- | Inserts a header with the given name and value. --- Allows duplicate header names. -insertHeader :: HasHeaders a => HeaderName -> String -> a -> a -insertHeader name value = modifyHeaders (Header name value:) - --- | Adds the new header only if no previous header shares --- the same name. -insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a -insertHeaderIfMissing name value x = setHeaders x $ mkHeaders hs' - where hs' = case lookupHeader name x of - Nothing -> Header name value : hs - Just _ -> hs - hs = listHeaders (getHeaders x) - --- | Removes old headers with the same name. -replaceHeader :: HasHeaders a => HeaderName -> String -> a -> a -replaceHeader name value = modifyHeaders f - where f hs = Header name value : [ x | x@(Header n _) <- hs, name /= n ] - --- | Inserts multiple headers. -insertHeaders :: HasHeaders a => [Header] -> a -> a -insertHeaders hdrs = modifyHeaders (hdrs++) - -lookupHeaders :: HasHeaders a => HeaderName -> a -> [String] -lookupHeaders name x = [ v | Header n v <- listHeaders x, name == n ] - -lookupHeader :: HasHeaders a => HeaderName -> a -> Maybe String -lookupHeader n x = listToMaybe $ lookupHeaders n x - - --- * Constructing specific headers - -contentLengthHeader :: Integer -> Header -contentLengthHeader i = Header HdrContentLength (show i) - -contentTypeHeader :: String -> Header -contentTypeHeader t = Header HdrContentType t - -lastModifiedHeader :: ClockTime -> Header -lastModifiedHeader t = Header HdrLastModified (formatTimeSensibly (toUTCTime t)) - -transferCodingHeader :: TransferCoding -> Header -transferCodingHeader te = Header HdrTransferEncoding (transferCodingStr te) - -data TransferCoding - = ChunkedTransferCoding - | GzipTransferCoding - | CompressTransferCoding - | DeflateTransferCoding - deriving Eq - -transferCodingStr :: TransferCoding -> String -transferCodingStr ChunkedTransferCoding = "chunked" -transferCodingStr GzipTransferCoding = "gzip" -transferCodingStr CompressTransferCoding = "compress" -transferCodingStr DeflateTransferCoding = "deflate" - --- validTransferCoding :: [TransferCoding] -> Bool --- validTransferCoding codings --- | null codings --- || last codings == ChunkedTransferCoding --- && ChunkedTransferCoding `notElem` init codings = True --- | otherwise = False -; - --- * Values of specific headers - -getContentType :: HasHeaders a => a -> Maybe String -getContentType x = lookupHeader HdrContentType x - -getContentLength :: HasHeaders a => a -> Maybe Integer -getContentLength x = lookupHeader HdrContentLength x >>= readM - - --- * Parsing - -pHeaders :: Parser Headers -pHeaders = liftM Headers $ many pHeader - -pHeader :: Parser Header -pHeader = - do name <- pToken - char ':' - many pWS1 - line <- lineString - pCRLF - extraLines <- many extraFieldLine - return $ Header (mkHeaderName name) (concat (line:extraLines)) - -extraFieldLine :: Parser String -extraFieldLine = - do sp <- pWS1 - line <- lineString - pCRLF - return (sp:line) - diff --git a/src/LogLevel.hs b/src/LogLevel.hs deleted file mode 100644 --- a/src/LogLevel.hs +++ /dev/null @@ -1,32 +0,0 @@ -module LogLevel (LogLevel(..)) where - -import Data.Maybe (fromMaybe) - -data LogLevel = LogDebug - | LogInfo - | LogNotice - | LogWarn - | LogError - | LogCrit - | LogAlert - | LogEmerg - deriving (Eq,Ord,Enum,Bounded) - -logLevelNames :: [(LogLevel,String)] -logLevelNames = [ - (LogDebug, "debug"), - (LogInfo, "info"), - (LogNotice,"notice"), - (LogWarn, "warn"), - (LogError, "error"), - (LogCrit, "crit"), - (LogAlert, "alert"), - (LogEmerg, "emerg") - ] - -instance Show LogLevel where - show l = fromMaybe (error $ "logLevelNames is incomplete") $ - lookup l logLevelNames - -instance Read LogLevel where - readsPrec _ s = [ (l,"") | (l,n) <- logLevelNames, n == s ] diff --git a/src/Logger.hs b/src/Logger.hs deleted file mode 100644 --- a/src/Logger.hs +++ /dev/null @@ -1,124 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module Logger ( - LoggerHandle, - startLogger, - stopLogger, - logMessage - ) where - -import Util - -import Control.Exception as Exception -import Control.Concurrent -import System.Directory -import System.IO - - -data LoggerHandle a = LoggerHandle - { - loggerHandleChan :: Chan (LoggerCommand a), - loggerHandleThreadId :: ThreadId - } - -data Logger a = Logger - { - loggerChan :: Chan (LoggerCommand a), - loggerFormat :: (a -> String), - loggerFile :: FilePath - } - -data LoggerCommand a = StopLogger - | LogMessage a - -startLogger :: (a -> String) -- ^ Message formatting function - -> FilePath -- ^ log file path - -> IO (LoggerHandle a) -startLogger format file = - do chan <- newChan - createDirectoryIfMissing True (dirname file) - let l = Logger { - loggerChan = chan, - loggerFormat = format, - loggerFile = file - } - t <- forkIO (runLogger l - `Exception.catch` - (\e -> hPutStrLn stderr - ("Error starting logger: " ++ show e))) - return $ LoggerHandle { - loggerHandleChan = chan, - loggerHandleThreadId = t - } - -stopLogger :: LoggerHandle a -> IO () -stopLogger l = writeChan (loggerHandleChan l) StopLogger - -logMessage :: LoggerHandle a -> a -> IO () -logMessage l x = writeChan (loggerHandleChan l) (LogMessage x) - --- Internals - -runLogger :: Logger a -> IO () -runLogger l = runLogger1 l - `Exception.catch` - (\e -> do hPutStrLn stderr ("Logger died: " ++ show e) - runLogger l) - -runLogger1 :: Logger a -> IO () -runLogger1 l = - Exception.bracket - (openLogFile (loggerFile l)) - (\hdl -> hClose hdl) - (\hdl -> handleLogCommands l hdl) - where - openLogFile :: FilePath -> IO Handle - openLogFile f = - openFile f AppendMode - `Exception.catch` - (\e -> do hPutStrLn stderr ("Failed to open log file: " ++ show e) - Exception.throw e) - -handleLogCommands :: Logger a -> Handle -> IO () -handleLogCommands l hdl = - do comm <- readChan (loggerChan l) - case comm of - StopLogger -> do return () - LogMessage x -> do let str = (loggerFormat l) x - writeLogLine hdl str - handleLogCommands l hdl - where - writeLogLine :: Handle -> String -> IO () - writeLogLine hndl str = do hPutStrLn hndl str - hFlush hndl diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,490 +1,10 @@ --- ----------------------------------------------------------------------------- --- 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) - --} - +module Main where ------------------------------------------------------------------------------ --- Top-level server +import qualified Network.MoHWS.Server as Server +import qualified Network.MoHWS.Initialization as Init +import qualified Network.MoHWS.Initialization.Standard as Std +import qualified Data.ByteString.Lazy.Char8 as B 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 + Server.main (Std.init :: Init.T B.ByteString Std.Extension) diff --git a/src/MainDynamic.hs b/src/MainDynamic.hs new file mode 100644 --- /dev/null +++ b/src/MainDynamic.hs @@ -0,0 +1,69 @@ +module Main where + +import qualified Network.MoHWS.Server as Server + +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Stream as Stream +import qualified Network.MoHWS.Initialization as Init +import qualified Data.Accessor.Basic as Accessor +import qualified Data.ByteString.Lazy.Char8 as B + +import qualified Network.MoHWS.Part.UserDirectory as UserDir +import qualified Network.MoHWS.Part.VirtualHost as VirtualHost +import qualified Network.MoHWS.Part.AddSlash as AddSlash +import qualified Network.MoHWS.Part.Index as Index +import qualified Network.MoHWS.Part.CGI as CGI +import qualified Network.MoHWS.Part.DynHS as DynHS +import qualified Network.MoHWS.Part.File as File +import qualified Network.MoHWS.Part.Listing as Listing + +import Prelude hiding (init, ) + + +data Extension = + Extension { + userDir :: UserDir.Configuration, + virtualHost :: VirtualHost.Configuration, + addSlash :: AddSlash.Configuration, + index :: Index.Configuration, + cgi :: CGI.Configuration, + file :: File.Configuration, + listing :: Listing.Configuration + } + +lift :: + (partExt -> fullExt -> fullExt) -> (fullExt -> partExt) -> + ModuleDesc.T body partExt -> ModuleDesc.T body fullExt +lift set get = + ModuleDesc.lift (Accessor.fromSetGet set get) + +modules :: (Stream.C body) => [ModuleDesc.T body Extension] +modules = + lift (\x ext -> ext{userDir = x}) userDir UserDir.desc : + lift (\x ext -> ext{virtualHost = x}) virtualHost VirtualHost.desc : + lift (\x ext -> ext{addSlash = x}) addSlash AddSlash.desc : + lift (\x ext -> ext{index = x}) index Index.desc : + lift (\x ext -> ext{cgi = x}) cgi CGI.desc : + DynHS.desc : + lift (\x ext -> ext{file = x}) file File.desc : + lift (\x ext -> ext{listing = x}) listing Listing.desc : + [] + +init :: (Stream.C body) => Init.T body Extension +init = + Init.Cons { + Init.moduleList = modules, + Init.configurationExtensionDefault = + Extension + (error "uninitialized userDir extension") + (error "uninitialized virtualHost extension") + (error "uninitialized addSlash extension") + (error "uninitialized index extension") + (error "uninitialized cgi extension") + (error "uninitialized file extension") + (error "uninitialized listing extension") + } + +main :: IO () +main = + Server.main (init :: Init.T B.ByteString Extension) diff --git a/src/MimeTypes.hs b/src/MimeTypes.hs deleted file mode 100644 --- a/src/MimeTypes.hs +++ /dev/null @@ -1,94 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module MimeTypes ( - MimeTypes, - MimeType(..), - initMimeTypes, - mimeTypeOf, - pMimeType - ) where - -import Parse - -import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) -import Text.ParserCombinators.Parsec - -type MimeTypes = Map String MimeType - -data MimeType = MimeType String String - -instance Show MimeType where - showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2) - -mimeTypeOf :: MimeTypes -> FilePath -> Maybe MimeType -mimeTypeOf mime_types filename = - do let ext = extension filename - if null ext - then Nothing - else Map.lookup ext mime_types - -extension :: String -> String -extension fn = go (reverse fn) "" - where go [] _ = "" - go ('.':_) ext = ext - go (x:s) ext = go s (x:ext) - -initMimeTypes :: FilePath -> IO MimeTypes -initMimeTypes mime_types_file = - do stuff <- readFile mime_types_file - return $ Map.fromList (parseMimeTypes stuff) - -parseMimeTypes :: String -> [(String,MimeType)] -parseMimeTypes file = - [ (ext,val) - | Just (val,exts) <- map (parseMimeLine . takeWhile (/= '#')) (lines file) - , ext <- exts - ] - -parseMimeLine :: String -> Maybe (MimeType, [String]) -parseMimeLine l = case parse pMimeLine "MIME line" l of - Left _ -> Nothing - Right m -> Just m - -pMimeLine :: Parser (MimeType, [String]) -pMimeLine = do t <- pMimeType - es <- (spaces >> sepBy pToken spaces) - return (t, es) - -pMimeType :: Parser MimeType -pMimeType = do part1 <- pToken - char '/' - part2 <- pToken - return $ MimeType part1 part2 diff --git a/src/Module/CGI.hs b/src/Module/CGI.hs deleted file mode 100644 --- a/src/Module/CGI.hs +++ /dev/null @@ -1,207 +0,0 @@ --- Copyright 2006, Bjorn Bringert. -module Module.CGI (desc, - mkCGIEnv, mkCGIResponse - ) where - -import Config -import Headers -import Parse -import Request -import Response -import ServerRequest -import ServerState -import Util - -import Control.Concurrent -import Control.Exception as Exception -import Control.Monad -import Data.Char (toUpper) -import Data.List -import Network.BSD (hostName) -import Network.Socket (inet_ntoa) -import Network.URI -import System.IO -import System.IO.Error -import System.Posix -import System.Process (runInteractiveProcess, waitForProcess) -import Text.ParserCombinators.Parsec - - -desc :: ModuleDesc -desc = emptyModuleDesc { - moduleName = "cgi", - moduleLoad = return funs - } - -funs :: Module -funs = emptyModule { - moduleHandleRequest = cgiHandleRequest - } - -cgiHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response) -cgiHandleRequest st sreq = - do m_prog <- findProg st (serverFilename sreq) - case m_prog of - Nothing -> do debug st $ "CGI: not handling " ++ serverFilename sreq - return Nothing - Just (path_prog, path_info) -> - do if ".cgi" `isSuffixOf` path_prog -- FIXME: add AddHandler mechanism - then do let hndle = cgiHandleRequest2 st sreq path_prog path_info - liftM Just $ case reqCmd (clientRequest sreq) of - GetReq -> hndle False - PostReq -> hndle True - _ -> return $ notImplementedResponse conf - else do debug st $ "CGI: not handling " ++ serverFilename sreq ++ ", wrong suffix" - return Nothing - where conf = serverConfig st - -cgiHandleRequest2 :: ServerState -> ServerRequest -> FilePath -> String -> Bool -> IO Response -cgiHandleRequest2 st sreq path_prog path_info useReqBody = - do let conf = serverConfig st - let req = clientRequest sreq - - env <- mkCGIEnv st sreq path_info - let wdir = dirname path_prog - prog = "./" ++ basename path_prog - - debug st $ "Running CGI program: " ++ prog ++ " in " ++ wdir - - (inp,out,err,pid) - <- runInteractiveProcess prog [] (Just wdir) (Just env) - - - if useReqBody then forkIO (writeBody inp req) >> return () - else hClose inp - - -- log process stderr to the error log - forkIO (logErrorsFromHandle st err) - - -- FIXME: exception handling - -- FIXME: close handle? - output <- hGetContents out - - -- wait in a separate thread, so that this thread can continue. - -- this is needed since output is lazy. - forkIO (waitForProcess pid >> return ()) - - case parseCGIOutput output of - Left errp -> do logError st errp - return $ internalServerErrorResponse conf - Right (outputHeaders, content) -> mkCGIResponse outputHeaders content - -mkCGIResponse :: Headers -> String -> IO Response -mkCGIResponse outputHeaders content = - do let stat = lookupHeader (HdrCustom "Status") outputHeaders - loc = lookupHeader HdrLocation outputHeaders - (code,dsc) <- case stat of - Nothing -> let c = maybe 200 (\_ -> 302) loc - in return (c, responseDescription c) - Just s -> case reads s of - [(c,r)] -> return (c,trimLWS r) - _ -> fail "Bad Status line" - -- FIXME: don't use response constructor directly - return (Response code dsc outputHeaders [] (HereItIs content) True) - --- Split the requested file system path into the path to an --- existing file, and some extra path info -findProg :: ServerState -> FilePath -> IO (Maybe (FilePath,String)) -findProg st filename = case splitPath filename of - [] -> return Nothing -- this should never happen - [""] -> return Nothing -- we got an empty path - "":p -> firstFile st "/" p -- absolute path - p:r -> firstFile st p r -- relative path - -firstFile :: ServerState -> FilePath -> [String] -> IO (Maybe (FilePath,String)) -firstFile st p pis = - do m_lstat <- statSymLink p - checkStat m_lstat - where conf = serverConfig st - - mkPath x y | "/" `isSuffixOf` x = x ++ y - | otherwise = x ++ "/" ++ y - - mkPathInfo [] = "" - mkPathInfo q = "/" ++ glue "/" q - - checkStat Nothing = do debug st $ "findProg: Not found: " ++ show p - return Nothing - checkStat (Just stat) - | isDirectory stat = - case pis of - [] -> do debug st $ "findProg: " ++ show p ++ " is a directory" - return Nothing - f:pis' -> firstFile st (mkPath p f) pis' - | isRegularFile stat = return $ Just (p,mkPathInfo pis) - | isSymbolicLink stat = if followSymLinks conf - then statFile p >>= checkStat - else do debug st $ "findProg: Not following symlink: " ++ show p - return Nothing - | otherwise = do debug st $ "Strange file: " ++ show p - return Nothing - -mkCGIEnv :: ServerState -> ServerRequest -> String -> IO [(String,String)] -mkCGIEnv st sreq path_info - = do let req = clientRequest sreq - remoteAddr <- inet_ntoa (clientAddress sreq) - let scriptName = serverURIPath sreq `dropSuffix` path_info - -- FIXME: use canonical name if there is no ServerName - serverEnv = - [ - ("SERVER_SOFTWARE", serverSoftware - ++ "/" ++ serverVersion), - ("SERVER_NAME", hostName (requestHostName sreq)), - ("GATEWAY_INTERFACE", "CGI/1.1") - ] - requestEnv = - [ - ("SERVER_PROTOCOL", show (reqHTTPVer req)), - ("SERVER_PORT", show (serverPort st)), - ("REQUEST_METHOD", show (reqCmd req)), - ("PATH_TRANSLATED", serverFilename sreq), - ("SCRIPT_NAME", scriptName), - ("QUERY_STRING", uriQuery (reqURI req) `dropPrefix` "?"), - ("REMOTE_ADDR", remoteAddr), - ("PATH_INFO", path_info) - ] - ++ maybeHeader "AUTH_TYPE" Nothing -- FIXME - ++ maybeHeader "REMOTE_USER" Nothing -- FIXME - ++ maybeHeader "REMOTE_IDENT" Nothing -- FIXME - ++ maybeHeader "REMOTE_HOST" (fmap hostName (clientName sreq)) - ++ maybeHeader "CONTENT_TYPE" (getContentType req) - ++ maybeHeader "CONTENT_LENGTH" (fmap show $ getContentLength req) - hs = [] -- FIXME: convert headers to (name,value) pairs - headerEnv = [("HTTP_"++ map toUpper n, v) | (n,v) <- hs] - - return $ serverEnv ++ requestEnv ++ headerEnv - --- Writes the body of a request to a handle. -writeBody :: Handle -> Request -> IO () -writeBody h req = do hPutStr h (reqBody req) - hClose h - --- | Reads lines form the given 'Handle' and log them with 'logError'. -logErrorsFromHandle :: ServerState -> Handle -> IO () -logErrorsFromHandle st h = - (loop `Exception.catch` \e -> - case e of - IOException f | isEOFError f -> return () - _ -> logError st $ "CGI:" ++ show e) - `Exception.finally` hClose h - where loop = do l <- hGetLine h - logError st l - loop - -maybeHeader :: String -> Maybe String -> [(String,String)] -maybeHeader n = maybe [] ((:[]) . (,) n) - -parseCGIOutput :: String -> Either String (Headers,String) -parseCGIOutput s = case parse pCGIOutput "CGI output" s of - Left err -> Left (show err) - Right x -> Right x - -pCGIOutput :: Parser (Headers,String) -pCGIOutput = - do headers <- pHeaders - pCRLF - body <- getInput - return (headers, body) diff --git a/src/Module/DynHS.hs b/src/Module/DynHS.hs deleted file mode 100644 --- a/src/Module/DynHS.hs +++ /dev/null @@ -1,79 +0,0 @@ --- Copyright 2006 Bjorn Bringert -module Module.DynHS where - -import Module.DynHS.GHCUtil - -import Headers -import Response -import ServerRequest -import ServerState - -import Control.Exception as Exception -import Control.Monad -import Data.List -import System.IO - - --- FIXME: keep this in config -packageDirectory :: FilePath -packageDirectory = "/usr/local/lib/ghc-6.6" - - -desc :: ModuleDesc -desc = emptyModuleDesc { - moduleName = "dynhs", - moduleLoad = loadDynHS - } - -loadDynHS :: IO Module -loadDynHS = - do s <- initGHC packageDirectory - return $ emptyModule { - moduleLoadConfig = dynhsLoadConfig s, - moduleHandleRequest = dynhsHandleRequest s - } - -dynhsLoadConfig :: Session -> ServerState -> IO () -dynhsLoadConfig s st = setLogAction s (logError st) - -dynhsHandleRequest :: Session -> ServerState -> ServerRequest -> IO (Maybe Response) -dynhsHandleRequest s st sreq = - do if ".hs" `isSuffixOf` serverFilename sreq - then dynhsHandleRequest2 s st sreq - else return Nothing - -dynhsHandleRequest2 :: Session -> ServerState -> ServerRequest -> IO (Maybe Response) -dynhsHandleRequest2 s st sreq = withCleanUp s $ --- FIXME: lots of fake stuff here - do debug st $ "DynHS: Loading " ++ show (serverFilename sreq) - e_cgiMain <- logGHCErrors s st (getCgiMain s (serverFilename sreq)) - case e_cgiMain of - Left resp -> return $ Just resp - Right cgiMain -> liftM Just $ runCgiMain st sreq cgiMain - -type CGIMain = [(String,String)] -> [(String,String)] -> IO ([(String,String)], String) - -getCgiMain :: Session -> FilePath -> IO CGIMain -getCgiMain s file = getFileValue s file "cgiMain" - -runCgiMain :: ServerState -> ServerRequest -> CGIMain -> IO Response -runCgiMain st sreq cgiMain = - -- FIXME: lots of fake stuff here - do let env = [] - inputs = [] - (hs,content) <- cgiMain env inputs - let headers = mkHeaders [Header (mkHeaderName n) v | (n,v) <- hs] - let code = 200 - desc = "OK" - return $ Response code desc headers [] (HereItIs content) True - --- GHC utilities - -logGHCErrors :: Session -> ServerState -> IO a -> IO (Either Response a) -logGHCErrors s st f - = liftM Right f - `Exception.catch` - (\e -> do logError st (show e) - -- FIXME: include error message in response - return $ Left $ internalServerErrorResponse (serverConfig st)) - diff --git a/src/Module/DynHS/CGI.hs b/src/Module/DynHS/CGI.hs deleted file mode 100644 --- a/src/Module/DynHS/CGI.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Module.DynHS.CGI where - -import Module.CGI - -import Response -import Request -import ServerRequest -import ServerState - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.Map as Map -import Data.Maybe (isJust) - -import Network.CGI.Monad -import Network.CGI.Protocol - - -hwsRunCGI :: ServerState -> ServerRequest -> CGI CGIResult -> IO Response -hwsRunCGI st sreq cgi = - do let path_info = "" -- FIXME: do the path walk - env <- mkCGIEnv st sreq path_info - let input = BS.pack $ reqBody $ clientRequest sreq - (hs,body) <- runCGI_ env input (runCGIT cgi) - mkCGIResponse hs (BS.unpack body) - --- | Run a CGI action. This is what runCGIEnvFPS really should look like. -runCGI_ :: Monad m => - [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. - -> m (Headers, ByteString) -- ^ Response (headers and content). -runCGI_ vars inp f - = do (hs,outp) <- f $ CGIRequest { - cgiVars = Map.fromList vars, - cgiInputs = decodeInput vars inp, - cgiRequestBody = inp - } - return $ case outp of - CGIOutput c -> (hs',c) - where hs' = if isJust (lookup ct hs) - then hs else hs ++ [(ct,defaultContentType)] - ct = HeaderName "Content-type" - CGINothing -> (hs, BS.empty) - -defaultContentType :: String -defaultContentType = "text/html; charset=ISO-8859-1" diff --git a/src/Module/DynHS/GHCUtil.hs b/src/Module/DynHS/GHCUtil.hs deleted file mode 100644 --- a/src/Module/DynHS/GHCUtil.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Module.DynHS.GHCUtil - (Session, - initGHC, - setLogAction, - withCleanUp, - getFileValue, - -- * Error logging - Severity(..), SrcSpan, PprStyle, Message, - mkLocMessage - ) where - --- GHC API stuff -import DynFlags -import ErrUtils -import GHC hiding (Module, Session, moduleName) -import qualified GHC (Module, Session) -import HscMain (newHscEnv) -import HscTypes (Session(..)) -import Outputable (PprStyle) -import SrcLoc (SrcSpan) -import SysTools (initSysTools) - -import Data.Dynamic -import Data.IORef -import System.IO - -initGHC :: FilePath -> IO Session -initGHC pkgDir - = do s <- newSession' Interactive (Just pkgDir) - modifySessionDynFlags s (\flags -> flags{ hscTarget = HscInterpreted }) - return s - - - --- Like newSesion, but does not install signal handlers -newSession' :: GhcMode -> Maybe FilePath -> IO Session -newSession' mode mb_top_dir = do - dflags0 <- initSysTools mb_top_dir defaultDynFlags - dflags <- initDynFlags dflags0 - env <- newHscEnv dflags{ ghcMode=mode } - ref <- newIORef env - return (Session ref) - -setLogAction :: Session -> (String -> IO ()) -> IO () -setLogAction s f = - modifySessionDynFlags s (\flags -> flags { log_action = mkLogAction f }) - -mkLogAction :: (String -> IO ()) - -> Severity -> SrcSpan -> PprStyle -> Message -> IO () -mkLogAction f severity srcSpan style msg = - case severity of - SevInfo -> f (show (msg style)) - SevFatal -> f (show (msg style)) - _ -> f (show ((mkLocMessage srcSpan msg) style)) - - -modifySessionDynFlags :: Session -> (DynFlags -> DynFlags) -> IO () -modifySessionDynFlags s f = - do flags <- getSessionDynFlags s - setSessionDynFlags s (f flags) - return () - -withCleanUp :: Session -> IO a -> IO a -withCleanUp s f = do flags <- getSessionDynFlags s - defaultCleanupHandler flags f - -loadFile :: Session -> FilePath -> IO GHC.Module -loadFile s file = - do let t = Target (TargetFile file Nothing) Nothing - setTargets s [t] - succ <- load s LoadAllTargets - case succ of - Succeeded -> do m <- fileModule s file - setContext s [] [m] - return m - Failed -> fail $ "Failed to load " ++ show file - -fileModule :: Session -> FilePath -> IO GHC.Module -fileModule s f = - do gr <- getModuleGraph s - case [ms_mod ms | ms <- gr, ml_hs_file (ms_location ms) == Just f] of - [m] -> return m - _ -> fail $ "File " ++ f ++ " does not correspond to a module" - -getValue :: Typeable a => Session -> String -> IO a -getValue s x = - do mdyn <- dynCompileExpr s x - case mdyn of - Nothing -> fail $ "dynCompileExpr " ++ show x ++ " failed" - Just dyn -> case fromDynamic dyn of - Nothing -> fail $ "Type error: " ++ x - ++ " is an " ++ show dyn - Just x -> return x - -getFileValue :: Typeable a => Session -> FilePath -> String -> IO a -getFileValue s file x = - do m <- loadFile s file - getValue s x diff --git a/src/Module/File.hs b/src/Module/File.hs deleted file mode 100644 --- a/src/Module/File.hs +++ /dev/null @@ -1,70 +0,0 @@ --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. -module Module.File (desc) where - -import Config -import Headers -import Request -import Response -import ServerRequest -import ServerState -import Util - -import Control.Monad -import System.Posix - -desc :: ModuleDesc -desc = emptyModuleDesc { - moduleName = "file", - moduleLoad = return funs - } - -funs :: Module -funs = emptyModule { - moduleHandleRequest = fileHandler - } - -fileHandler :: ServerState -> ServerRequest -> IO (Maybe Response) -fileHandler st (ServerRequest { clientRequest = req, - serverFilename = filename }) = - do m_lstat <- statSymLink filename - checkStat m_lstat - where - conf = serverConfig st - checkStat (Just stat) - | isRegularFile stat = - liftM Just $ case reqCmd req of - GetReq -> serveFile st filename stat False - HeadReq -> serveFile st filename stat True - _ -> return (notImplementedResponse conf) - | isSymbolicLink stat = - if followSymLinks conf - then statFile filename >>= checkStat - else do debug st $ "findProg: Not following symlink: " ++ show filename - return Nothing - | otherwise = do debug st $ "Strange file: " ++ show filename - return Nothing - checkStat Nothing = do debug st $ "File not found: " ++ show filename - return Nothing - -serveFile :: ServerState -> FilePath -> FileStatus -> Bool -> IO Response -serveFile st filename stat is_head = - do -- check we can actually read this file - access <- fileAccess filename True{-read-} False False - case access of - False -> return (notFoundResponse conf); - -- not "permission denied", we're being paranoid - -- about security. - True -> - do let content_type = getMimeType st filename - - let last_modified = epochTimeToClockTime (modificationTime stat) - - let size = toInteger (fileSize stat) - - return (okResponse conf - (FileBody size filename) - (mkHeaders [contentTypeHeader content_type, - lastModifiedHeader last_modified]) - (not is_head) {- send body -}) - where conf = serverConfig st diff --git a/src/Module/Index.hs b/src/Module/Index.hs deleted file mode 100644 --- a/src/Module/Index.hs +++ /dev/null @@ -1,40 +0,0 @@ --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. -module Module.Index (desc) where - -import Config -import ServerRequest -import ServerState -import Util - -import System.Posix - - - -desc :: ModuleDesc -desc = emptyModuleDesc { - moduleName = "index", - moduleLoad = return funs - } - -funs :: Module -funs = emptyModule { - moduleTweakRequest = indexTweakRequest - } - -indexTweakRequest :: ServerState -> ServerRequest -> IO ServerRequest -indexTweakRequest = tweakFilename indexFixPath - -indexFixPath :: ServerState -> FilePath -> IO FilePath -indexFixPath st filename = - do stat <- statFile filename - case stat of - Just state | isDirectory state -> do - let index_filename = filename ++ '/': directoryIndex conf - debug st $ "index_filename = " ++ show index_filename - stt <- statFile index_filename - case stt of - Nothing -> return filename - Just _ -> return index_filename - _ -> return filename - where conf = serverConfig st diff --git a/src/Module/Userdir.hs b/src/Module/Userdir.hs deleted file mode 100644 --- a/src/Module/Userdir.hs +++ /dev/null @@ -1,35 +0,0 @@ --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. -module Module.Userdir (desc) where - -import Config -import ServerState - -import Control.Exception -import System.Posix - - -desc :: ModuleDesc -desc = emptyModuleDesc { - moduleName = "userdir", - moduleLoad = return funs - } - -funs :: Module -funs = emptyModule { - moduleTranslatePath = userdirTranslatePath - } - -userdirTranslatePath :: ServerState -> String -> IO (Maybe FilePath) -userdirTranslatePath st ('/':'~':userpath) | not (null (userDir conf)) = - do let (usr, path) = break (=='/') userpath - debug st $ "looking for user: " ++ show usr - u_ent <- tryJust ioErrors (getUserEntryForName usr) - case u_ent of - Left _ -> return Nothing - Right ent -> - do let p = '/': homeDirectory ent ++ '/':userDir conf ++ path - debug st $ "userdir path: " ++ p - return $ Just p - where conf = serverConfig st -userdirTranslatePath _ _ = return Nothing diff --git a/src/Network/MoHWS/ByteString.hs b/src/Network/MoHWS/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/ByteString.hs @@ -0,0 +1,54 @@ +module Network.MoHWS.ByteString where + +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified System.IO as IO +import Control.Monad (liftM2, ) +import System.IO.Unsafe (unsafeInterleaveIO, ) + + +{- | +Like 'L.hGetContents' but it does not try to close the file when reaching the end. +Since you may abort reading before reaching the end, +or the run-time system reads more than necessary +(you don't know how unsafeInterleaveIO works), +you never know, whether 'L.hGetContents' has already closed the file or not. +With this function however it is always sure, +that the file is not closed and you are responsible for closing it. +-} +hGetContentsN :: Int -> IO.Handle -> IO L.ByteString +hGetContentsN k h = + let loop = unsafeInterleaveIO $ do + eof <- IO.hIsEOF h + if eof + then return L.empty + else + do liftM2 + (\c -> L.append (L.fromChunks [c])) + (S.hGet h k) loop + in loop + +{- | +Variant of 'hGetContentsN' that may choose smaller chunks +when currently no more data is available. +The chunk size may however become arbitrarily small, +making the whole process inefficient. +But when real-time fetching counts, it is the better choice. +-} +hGetContentsNonBlockingN :: Int -> IO.Handle -> IO L.ByteString +hGetContentsNonBlockingN k h = + let lazyRead = unsafeInterleaveIO loop + + loop = do + c <- S.hGetNonBlocking h k + if S.null c + then do eof <- IO.hIsEOF h + if eof + then return L.empty + else IO.hWaitForInput h (-1) >> loop + else fmap (L.append $ L.fromChunks [c]) lazyRead + in lazyRead + +-- | Read the given number of bytes from a Handle +hGetChars :: IO.Handle -> Int -> IO String +hGetChars h n = fmap L.unpack $ L.hGet h n diff --git a/src/Network/MoHWS/Configuration.hs b/src/Network/MoHWS/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Configuration.hs @@ -0,0 +1,172 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Configuration where + +import qualified Data.Set as Set +import qualified Network.MoHWS.Logger.Level as LogLevel +import qualified Data.Accessor.Basic as Accessor +import Network.Socket (PortNumber, ) + +import qualified Data.List as List +import qualified Data.Version as Ver +import qualified Paths_mohws as Global + + +----------------------------------------------------------------------------- +-- Config info + +data T ext = Cons { + user :: String, + group :: String, + + listen :: [(Maybe String, PortNumber)], + + requestTimeout :: Int, + keepAliveTimeout :: Int, + maxClients :: Int, + + serverAdmin :: String, -- "" indicates no admin + serverName :: String, -- "" indicates no canon name + serverAlias :: Set.Set String, + useCanonicalName :: Bool, + hostnameLookups :: Bool, + + documentRoot :: FilePath, + accessFileName :: FilePath, + indexes :: Bool, + followSymbolicLinks :: Bool, + chunkSize :: Int, + + typesConfig :: String, + defaultType :: String, + + addLanguage :: [(String,String)], + languagePriority :: [String], + + customLogs :: [(FilePath, String)], + + errorLogFile :: FilePath, + logLevel :: LogLevel.T, + + extension :: ext + } + deriving Show + +deflt :: ext -> T ext +deflt ext = Cons { + user = "nobody", + group = "nobody", + + listen = [(Nothing,80)], + + requestTimeout = 300, + keepAliveTimeout = 15, + maxClients = 150, + + serverAdmin = "", + serverName = "", + serverAlias = Set.empty, + useCanonicalName = False, + hostnameLookups = False, + + documentRoot = ".", + accessFileName = ".htaccess", + indexes = False, + followSymbolicLinks = False, + chunkSize = 4096, + + 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 = LogLevel.Warn, + + extension = ext + } + +-- not user-definable... +serverSoftware, serverVersion :: String +serverSoftware = "MoHWS" +serverVersion = + concat $ List.intersperse "." $ map show $ + Ver.versionBranch Global.version + + +extensionAcc :: Accessor.T (T ext) ext +extensionAcc = + Accessor.fromSetGet (\e c -> c{extension=e}) extension + + +instance Functor T where + fmap f c = Cons { + user = user c, + group = group c, + + listen = listen c, + + requestTimeout = requestTimeout c, + keepAliveTimeout = keepAliveTimeout c, + maxClients = maxClients c, + + serverAdmin = serverAdmin c, + serverName = serverName c, + serverAlias = serverAlias c, + useCanonicalName = useCanonicalName c, + hostnameLookups = hostnameLookups c, + + documentRoot = documentRoot c, + accessFileName = accessFileName c, + indexes = indexes c, + followSymbolicLinks = followSymbolicLinks c, + chunkSize = chunkSize c, + + typesConfig = typesConfig c, + defaultType = defaultType c, + + addLanguage = addLanguage c, + languagePriority = languagePriority c, + + customLogs = customLogs c, + + errorLogFile = errorLogFile c, + logLevel = logLevel c, + + extension = f $ extension c + } diff --git a/src/Network/MoHWS/Configuration/Accessor.hs b/src/Network/MoHWS/Configuration/Accessor.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Configuration/Accessor.hs @@ -0,0 +1,122 @@ +{- | +Copyright: 2009, Henning Thielemann +-} +module Network.MoHWS.Configuration.Accessor where + +import qualified Network.MoHWS.Configuration as Config +import qualified Data.Set as Set +import qualified Data.Accessor.Basic as Accessor + +import qualified Network.MoHWS.Logger.Level as LogLevel +import Network.Socket (PortNumber, ) + +{- +(\w+)( *):: (.+) +\1 :: Accessor.T (Config.T ext) \3\n\1 =\n Accessor.fromSetGet (\\x c -> c{Config.\1 = x}) Config.\1\n +-} + +user :: Accessor.T (Config.T ext) String +user = + Accessor.fromSetGet (\x c -> c{Config.user = x}) Config.user + +group :: Accessor.T (Config.T ext) String +group = + Accessor.fromSetGet (\x c -> c{Config.group = x}) Config.group + + +listen :: Accessor.T (Config.T ext) [(Maybe String, PortNumber)] +listen = + Accessor.fromSetGet (\x c -> c{Config.listen = x}) Config.listen + + +requestTimeout :: Accessor.T (Config.T ext) Int +requestTimeout = + Accessor.fromSetGet (\x c -> c{Config.requestTimeout = x}) Config.requestTimeout + +keepAliveTimeout :: Accessor.T (Config.T ext) Int +keepAliveTimeout = + Accessor.fromSetGet (\x c -> c{Config.keepAliveTimeout = x}) Config.keepAliveTimeout + +maxClients :: Accessor.T (Config.T ext) Int +maxClients = + Accessor.fromSetGet (\x c -> c{Config.maxClients = x}) Config.maxClients + + +serverAdmin :: Accessor.T (Config.T ext) String +serverAdmin = + Accessor.fromSetGet (\x c -> c{Config.serverAdmin = x}) Config.serverAdmin + +serverName :: Accessor.T (Config.T ext) String +serverName = + Accessor.fromSetGet (\x c -> c{Config.serverName = x}) Config.serverName + +serverAlias :: Accessor.T (Config.T ext) (Set.Set String) +serverAlias = + Accessor.fromSetGet (\x c -> c{Config.serverAlias = x}) Config.serverAlias + +useCanonicalName :: Accessor.T (Config.T ext) Bool +useCanonicalName = + Accessor.fromSetGet (\x c -> c{Config.useCanonicalName = x}) Config.useCanonicalName + +hostnameLookups :: Accessor.T (Config.T ext) Bool +hostnameLookups = + Accessor.fromSetGet (\x c -> c{Config.hostnameLookups = x}) Config.hostnameLookups + + +documentRoot :: Accessor.T (Config.T ext) FilePath +documentRoot = + Accessor.fromSetGet (\x c -> c{Config.documentRoot = x}) Config.documentRoot + +accessFileName :: Accessor.T (Config.T ext) FilePath +accessFileName = + Accessor.fromSetGet (\x c -> c{Config.accessFileName = x}) Config.accessFileName + +indexes :: Accessor.T (Config.T ext) Bool +indexes = + Accessor.fromSetGet (\x c -> c{Config.indexes = x}) Config.indexes + +followSymbolicLinks :: Accessor.T (Config.T ext) Bool +followSymbolicLinks = + Accessor.fromSetGet (\x c -> c{Config.followSymbolicLinks = x}) Config.followSymbolicLinks + +chunkSize :: Accessor.T (Config.T ext) Int +chunkSize = + Accessor.fromSetGet (\x c -> c{Config.chunkSize = x}) Config.chunkSize + + +typesConfig :: Accessor.T (Config.T ext) String +typesConfig = + Accessor.fromSetGet (\x c -> c{Config.typesConfig = x}) Config.typesConfig + +defaultType :: Accessor.T (Config.T ext) String +defaultType = + Accessor.fromSetGet (\x c -> c{Config.defaultType = x}) Config.defaultType + + +addLanguage :: Accessor.T (Config.T ext) [(String,String)] +addLanguage = + Accessor.fromSetGet (\x c -> c{Config.addLanguage = x}) Config.addLanguage + +languagePriority :: Accessor.T (Config.T ext) [String] +languagePriority = + Accessor.fromSetGet (\x c -> c{Config.languagePriority = x}) Config.languagePriority + + +customLogs :: Accessor.T (Config.T ext) [(FilePath, String)] +customLogs = + Accessor.fromSetGet (\x c -> c{Config.customLogs = x}) Config.customLogs + + +errorLogFile :: Accessor.T (Config.T ext) FilePath +errorLogFile = + Accessor.fromSetGet (\x c -> c{Config.errorLogFile = x}) Config.errorLogFile + +logLevel :: Accessor.T (Config.T ext) LogLevel.T +logLevel = + Accessor.fromSetGet (\x c -> c{Config.logLevel = x}) Config.logLevel + + +extension :: Accessor.T (Config.T ext) ext +extension = + Accessor.fromSetGet (\x c -> c{Config.extension = x}) Config.extension + diff --git a/src/Network/MoHWS/Configuration/Parser.hs b/src/Network/MoHWS/Configuration/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Configuration/Parser.hs @@ -0,0 +1,233 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Configuration.Parser ( + T, lift, run, field, set, addToList, + stringLiteral, bool, int, + ) where + +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration as Config +import Network.MoHWS.ParserUtility (countBetween, ) +import Control.Monad (liftM2, ) +import Network.MoHWS.Utility (readM, ) + +import Text.ParserCombinators.Parsec + (GenParser, ParseError, parseFromFile, + (<|>), choice, many, option, try, + char, digit, eof, ) +import Text.ParserCombinators.Parsec.Language + (LanguageDef, emptyDef, commentLine, nestedComments, + reservedOpNames, reservedNames, caseSensitive, ) +import qualified Text.ParserCombinators.Parsec.Token as Token + +import qualified Data.Set as Set +import qualified Data.Accessor.Basic as Accessor + + +type T st ext = GenParser Char st (Builder ext) + +type Builder ext = Config.T ext -> Config.T ext + + +{- +lift :: + Accessor.T fullExt partExt -> + GenParser Char st (partExt -> partExt) -> T st fullExt +lift act = + fmap (Accessor.modify Config.extensionAcc . Accessor.modify act) +-} + +lift :: + Accessor.T fullExt partExt -> + T st partExt -> T st fullExt +lift act = + fmap (\build c -> + fmap (flip (Accessor.set act) (Config.extension c)) $ + build $ + fmap (Accessor.get act) c) + + +field :: String -> T st ext -> T st ext +field keyword parser = + Token.reserved p keyword >> parser + +p :: Token.TokenParser st +p = Token.makeTokenParser tokenDef + + +stringLiteral :: GenParser Char st String +stringLiteral = Token.stringLiteral p + +bool :: GenParser Char st Bool +bool = ( Token.reserved p "On" >> return True ) + <|> ( Token.reserved p "Off" >> return False ) + +int :: GenParser Char st Int +int = fmap fromInteger $ Token.integer p + +tokenDef :: LanguageDef st +tokenDef = + emptyDef { + commentLine = "#", + nestedComments = False, + reservedOpNames = [], + reservedNames = [], + caseSensitive = False + } + + +run :: T () ext -> String -> IO (Either ParseError (Builder ext)) +run parseExt fname = + parseFromFile (configParser parseExt) fname + +configParser :: T st ext -> T st ext +configParser parseExt = do + Token.whiteSpace p + cs <- many $ parseExt <|> configLine + eof + return (fixConfig . foldr (.) id cs) + +fixConfig :: Builder ext +fixConfig conf = + let f xs = if length xs > 1 then init xs else xs + in Accessor.modify ConfigA.listen f conf + +configLine :: T st ext +configLine = + choice $ + (field "user" p_user) : + (field "group" p_group) : + (field "timeout" p_timeout) : + (field "keepalivetimeout" p_keepAliveTimeout) : + (field "maxclients" p_maxClients) : + (field "listen" p_listen) : + (field "serveradmin" p_serverAdmin) : + (field "servername" p_serverName) : + (field "serveralias" p_serverAlias) : + (field "usecanonicalname" p_useCanonicalName) : + (field "documentroot" p_documentRoot) : + (field "accessfilename" p_accessFileName) : + (field "followsymboliclinks" p_followSymbolicLinks) : + (field "chunksize" p_chunkSize) : + (field "typesconfig" p_typesConfig) : + (field "defaulttype" p_defaultType) : + (field "hostnamelookups" p_hostnameLookups) : + (field "errorlog" p_errorLog) : + (field "loglevel" p_logLevel) : + (field "customlog" p_customLog) : + (field "listen" p_listen) : + (field "addlanguage" p_addLanguage) : + (field "languagepriority" p_languagePriority) : + [] + +set :: Accessor.T r a -> GenParser Char st a -> GenParser Char st (r -> r) +set acc = fmap (Accessor.set acc) + +addToList :: Accessor.T r [a] -> GenParser Char st a -> GenParser Char st (r -> r) +addToList acc = fmap (Accessor.modify acc . (:)) + + +p_user :: T st ext +p_user = set ConfigA.user $ stringLiteral +p_group :: T st ext +p_group = set ConfigA.group $ stringLiteral +p_timeout :: T st ext +p_timeout = set ConfigA.requestTimeout $ int +p_keepAliveTimeout :: T st ext +p_keepAliveTimeout = set ConfigA.keepAliveTimeout $ int +p_maxClients :: T st ext +p_maxClients = set ConfigA.maxClients $ int +p_serverAdmin :: T st ext +p_serverAdmin = set ConfigA.serverAdmin $ stringLiteral +p_serverName :: T st ext +p_serverName = set ConfigA.serverName $ stringLiteral +p_serverAlias :: T st ext +p_serverAlias = fmap (Accessor.modify ConfigA.serverAlias . Set.insert) $ stringLiteral +p_useCanonicalName :: T st ext +p_useCanonicalName = set ConfigA.useCanonicalName $ bool +p_documentRoot :: T st ext +p_documentRoot = set ConfigA.documentRoot $ stringLiteral + +p_accessFileName :: T st ext +p_accessFileName = set ConfigA.accessFileName $ stringLiteral +p_followSymbolicLinks :: T st ext +p_followSymbolicLinks = set ConfigA.followSymbolicLinks $ bool +p_chunkSize :: T st ext +p_chunkSize = set ConfigA.chunkSize $ int +p_typesConfig :: T st ext +p_typesConfig = set ConfigA.typesConfig $ stringLiteral +p_defaultType :: T st ext +p_defaultType = set ConfigA.defaultType $ stringLiteral + +p_hostnameLookups :: T st ext +p_hostnameLookups = set ConfigA.hostnameLookups $ bool +p_errorLog :: T st ext +p_errorLog = set ConfigA.errorLogFile $ stringLiteral + +p_logLevel :: T st ext +p_logLevel = set ConfigA.logLevel $ Token.identifier p >>= readM + +p_customLog :: T st ext +p_customLog = + addToList ConfigA.customLogs $ + liftM2 (,) stringLiteral stringLiteral + +p_listen :: T st ext +p_listen = + let 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 + + in addToList ConfigA.listen $ + liftM2 (,) p_addr (fmap fromInteger $ Token.integer p) + + +p_addLanguage :: T st ext +p_addLanguage = + addToList ConfigA.addLanguage $ + liftM2 (,) stringLiteral stringLiteral + +p_languagePriority :: T st ext +p_languagePriority = set ConfigA.languagePriority $ many stringLiteral diff --git a/src/Network/MoHWS/HTTP/Header.hs b/src/Network/MoHWS/HTTP/Header.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/HTTP/Header.hs @@ -0,0 +1,289 @@ +-- Copyright 2002 Warrick Gray +-- Copyright 2001,2002 Peter Thiemann +-- Copyright 2003-2006 Bjorn Bringert +-- Copyright 2009 Henning Thielemann +module Network.MoHWS.HTTP.Header ( + Group, group, ungroup, + setGroup, + getGroup, + list, + modifyMany, + T, Hdrs.Header(..), make, + getName, getValue, name, value, + Name, Hdrs.HeaderName(..), + HasHeaders, + -- * Header parsing + pGroup, makeName, + -- * Header manipulation + insert, + insertIfMissing, + replace, insertMany, + lookupMany, lookup, + -- * Constructing headers + makeContentLength, + makeContentType, + makeLocation, + makeLastModified, + TransferCoding(..), + makeTransferCoding, + -- * Getting values of specific headers + getContentType, + getContentLength, +-- getHost, + ) where + +import qualified Network.HTTP.Headers as Hdrs +import Network.HTTP.Headers (HasHeaders, ) + +import Network.MoHWS.ParserUtility +import Network.MoHWS.Utility + +-- import Network.Socket (HostName, ) +import Network.URI (URI, ) + +import Control.Monad (liftM, ) +import Data.Char (toLower, ) +import Data.Map (Map, ) +import qualified Data.Map as Map hiding (Map) +import System.Time (ClockTime, toUTCTime, ) +import Text.ParserCombinators.Parsec + +import qualified Data.Accessor.Basic as Accessor + +import Prelude hiding (lookup, ) + + +-- * Header + +type T = Hdrs.Header +type Name = Hdrs.HeaderName + + +make :: Name -> String -> T +make = Hdrs.Header + +getName :: T -> Name +getName (Hdrs.Header n _v) = n + +getValue :: T -> String +getValue (Hdrs.Header _n v) = v + +name :: Accessor.T T Name +name = + Accessor.fromSetGet + (\n (Hdrs.Header _ v) -> Hdrs.Header n v) + getName + +value :: Accessor.T T String +value = + Accessor.fromSetGet + (\v (Hdrs.Header n _) -> Hdrs.Header n v) + getValue + + +-- Translation between header names and values, +nameList :: [ (String, Name) ] +nameList = + ("Cache-Control" , Hdrs.HdrCacheControl ) : + ("Connection" , Hdrs.HdrConnection ) : + ("Date" , Hdrs.HdrDate ) : + ("Pragma" , Hdrs.HdrPragma ) : +-- ("Trailer" , Hdrs.HdrTrailer ) : + + ("Transfer-Encoding" , Hdrs.HdrTransferEncoding ) : + ("Upgrade" , Hdrs.HdrUpgrade ) : + ("Via" , Hdrs.HdrVia ) : + ("Accept" , Hdrs.HdrAccept ) : + ("Accept-Charset" , Hdrs.HdrAcceptCharset ) : + ("Accept-Encoding" , Hdrs.HdrAcceptEncoding ) : + ("Accept-Language" , Hdrs.HdrAcceptLanguage ) : + ("Authorization" , Hdrs.HdrAuthorization ) : + ("From" , Hdrs.HdrFrom ) : + ("Host" , Hdrs.HdrHost ) : + ("If-Modified-Since" , Hdrs.HdrIfModifiedSince ) : + ("If-Match" , Hdrs.HdrIfMatch ) : + ("If-None-Match" , Hdrs.HdrIfNoneMatch ) : + ("If-Range" , Hdrs.HdrIfRange ) : + ("If-Unmodified-Since" , Hdrs.HdrIfUnmodifiedSince ) : + ("Max-Forwards" , Hdrs.HdrMaxForwards ) : + ("Proxy-Authorization" , Hdrs.HdrProxyAuthorization) : + ("Range" , Hdrs.HdrRange ) : + ("Referer" , Hdrs.HdrReferer ) : +-- ("TE" , Hdrs.HdrTE ) : + ("User-Agent" , Hdrs.HdrUserAgent ) : + ("Age" , Hdrs.HdrAge ) : + ("Location" , Hdrs.HdrLocation ) : + ("Proxy-Authenticate" , Hdrs.HdrProxyAuthenticate ) : + ("Public" , Hdrs.HdrPublic ) : + ("Retry-After" , Hdrs.HdrRetryAfter ) : + ("Server" , Hdrs.HdrServer ) : + ("Vary" , Hdrs.HdrVary ) : + ("Warning" , Hdrs.HdrWarning ) : + ("WWW-Authenticate" , Hdrs.HdrWWWAuthenticate ) : + ("Allow" , Hdrs.HdrAllow ) : + ("Content-Base" , Hdrs.HdrContentBase ) : + ("Content-Encoding" , Hdrs.HdrContentEncoding ) : + ("Content-Language" , Hdrs.HdrContentLanguage ) : + ("Content-Length" , Hdrs.HdrContentLength ) : + ("Content-Location" , Hdrs.HdrContentLocation ) : + ("Content-MD5" , Hdrs.HdrContentMD5 ) : + ("Content-Range" , Hdrs.HdrContentRange ) : + ("Content-Type" , Hdrs.HdrContentType ) : + ("ETag" , Hdrs.HdrETag ) : + ("Expires" , Hdrs.HdrExpires ) : + ("Last-Modified" , Hdrs.HdrLastModified ) : + ("Set-Cookie" , Hdrs.HdrSetCookie ) : + ("Cookie" , Hdrs.HdrCookie ) : + ("Expect" , Hdrs.HdrExpect ) : + [] + +toNameMap :: Map String Name +toNameMap = + Map.fromList [(map toLower x, y) | (x,y) <- nameList] + +{- +fromHeaderNameMap :: Map Name String +fromHeaderNameMap = Map.fromList [(y,x) | (x,y) <- headerNames] +-} + +makeName :: String -> Name +makeName s = + Map.findWithDefault (Hdrs.HdrCustom s) (map toLower s) toNameMap + + +-- * Header group + +newtype Group = Group { ungroup :: [T] } + +group :: [T] -> Group +group = Group + +instance Show Group where + showsPrec _ = + foldr (.) id . map shows . ungroup +-- foldr (.) id . map (\x -> shows x . showString crLf) . unGroup + +instance HasHeaders Group where + getHeaders = ungroup + setHeaders _ = group + + +getGroup :: HasHeaders x => x -> Group +getGroup = group . Hdrs.getHeaders + +setGroup :: HasHeaders x => x -> Group -> x +setGroup x = Hdrs.setHeaders x . ungroup + +list :: HasHeaders x => x -> [T] +list = Hdrs.getHeaders + +modifyMany :: HasHeaders x => ([T] -> [T]) -> x -> x +modifyMany f x = Hdrs.setHeaders x $ f $ Hdrs.getHeaders x + + +-- * Header manipulation functions + +-- Header manipulation functions +insert, replace, insertIfMissing :: HasHeaders a => + Name -> String -> a -> a +insert = Hdrs.insertHeader +insertIfMissing = Hdrs.insertHeaderIfMissing +replace = Hdrs.replaceHeader + +insertMany :: HasHeaders a => [T] -> a -> a +insertMany = Hdrs.insertHeaders + + +lookupMany :: HasHeaders a => Name -> a -> [String] +lookupMany searchName x = + [ v | Hdrs.Header n v <- list x, searchName == n ] + +lookup :: HasHeaders a => Name -> a -> Maybe String +lookup n = Hdrs.lookupHeader n . list +-- lookup n x = listToMaybe $ lookupMany n x + + +-- * Constructing specific headers + +makeContentLength :: Integer -> T +makeContentLength i = Hdrs.Header Hdrs.HdrContentLength (show i) + +makeContentType :: String -> T +makeContentType t = Hdrs.Header Hdrs.HdrContentType t + +makeLocation :: URI -> T +makeLocation t = Hdrs.Header Hdrs.HdrLocation $ show t + +makeLastModified :: ClockTime -> T +makeLastModified t = + Hdrs.Header Hdrs.HdrLastModified (formatTimeSensibly (toUTCTime t)) + +makeTransferCoding :: TransferCoding -> T +makeTransferCoding te = Hdrs.Header Hdrs.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 = lookup Hdrs.HdrContentType x + +getContentLength :: HasHeaders a => a -> Maybe Integer +getContentLength x = lookup Hdrs.HdrContentLength x >>= readM + +{- +getHost :: HasHeaders a => a -> Maybe (HostName, Maybe Int) +getHost x = lookup Hdrs.HdrHost x >>= parseHost +-} + + +-- * Parsing + +pGroup :: Parser Group +pGroup = liftM group $ many pHeader + +pHeader :: Parser T +pHeader = + do n <- pToken + char ':' + many pWS1 + line <- lineString + pCRLF + extraLines <- many extraFieldLine + return $ Hdrs.Header (makeName n) (concat (line:extraLines)) + +extraFieldLine :: Parser String +extraFieldLine = + do sp <- pWS1 + line <- lineString + pCRLF + return (sp:line) + +{- +parseHost :: String -> Maybe (HostName, Maybe Int) +parseHost s = + let (host,prt) = break (==':') s + in case prt of + "" -> Just (host, Nothing) + ':':port -> readM port >>= \p -> Just (host, Just p) + _ -> Nothing +-} diff --git a/src/Network/MoHWS/HTTP/MimeType.hs b/src/Network/MoHWS/HTTP/MimeType.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/HTTP/MimeType.hs @@ -0,0 +1,90 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.HTTP.MimeType ( + Dictionary, + T(Cons), + loadDictionary, + fromFileName, + ) where + +import Network.MoHWS.ParserUtility + +import Data.Map (Map) +import qualified Data.Map as Map +import Text.ParserCombinators.Parsec +import qualified System.FilePath as FilePath +import Control.Monad (liftM2, guard, ) +import Data.Maybe (mapMaybe, ) +import Data.List.HT (viewL, ) + + +type Dictionary = Map String T + +data T = Cons String String + +instance Show T where + showsPrec _ (Cons part1 part2) = showString (part1 ++ '/':part2) + +fromFileName :: Dictionary -> FilePath -> Maybe T +fromFileName mime_types filename = + do (sep,ext) <- viewL $ FilePath.takeExtension filename + guard (FilePath.isExtSeparator sep) + guard (not $ null ext) + Map.lookup ext mime_types + +loadDictionary :: FilePath -> IO Dictionary +loadDictionary mime_types_file = + fmap (Map.fromList . parseDictionary) $ + readFile mime_types_file + +parseDictionary :: String -> [(String,T)] +parseDictionary file = + do (val,exts) <- mapMaybe (parseMimeLine . takeWhile (/= '#')) (lines file) + ext <- exts + return (ext,val) + +parseMimeLine :: String -> Maybe (T, [String]) +parseMimeLine l = + case parse parserLine "MIME line" l of + Left _ -> Nothing + Right m -> Just m + +parserLine :: Parser (T, [String]) +parserLine = + liftM2 (,) parser (spaces >> sepBy pToken spaces) + +parser :: Parser T +parser = + liftM2 Cons pToken (char '/' >> pToken) diff --git a/src/Network/MoHWS/HTTP/Request.hs b/src/Network/MoHWS/HTTP/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/HTTP/Request.hs @@ -0,0 +1,214 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.HTTP.Request ( + T(Cons), command, uri, httpVersion, headers, body, + toHTTPbis, fromHTTPbis, + Command, HTTP.RequestMethod(..), + Connection(..), + Expect(..), + pHeaders, + getHost, + getConnection, + ) where + +import Text.ParserCombinators.Parsec (Parser, many1, many, noneOf, ) +import Network.MoHWS.ParserUtility (pCRLF, pSP, pToken, parseList, ) + +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Version as HTTPVersion +import Network.MoHWS.HTTP.Header (HasHeaders, ) +import Network.MoHWS.Utility (readM, ) + +import qualified Network.HTTP.Base as HTTP +import qualified Network.HTTP.Headers + -- make getHeaders visible for instance declaration + +import Network.Socket (HostName, ) +import Network.URI (URI, nullURI, uriPath, uriQuery, ) + +import qualified Data.Map as Map +import Data.Monoid (Monoid, mempty, ) +import Data.Char (toLower, ) + + +----------------------------------------------------------------------------- +-- Requests + +-- Request-Line = Method SP Request-URI SP HTTP-Version CRLF + +type Command = HTTP.RequestMethod + +data T body = + Cons { + command :: Command, + uri :: URI, + httpVersion :: HTTPVersion.T, + headers :: Header.Group, + body :: body + } + + +toHTTPbis :: T body -> HTTP.Request body +toHTTPbis req = + HTTP.Request { + HTTP.rqURI = uri req, + HTTP.rqMethod = command req, + HTTP.rqHeaders = Header.ungroup $ headers req, + HTTP.rqBody = body req + } + +fromHTTPbis :: HTTP.Request body -> T body +fromHTTPbis req = + Cons { + command = HTTP.rqMethod req, + uri = HTTP.rqURI req, + httpVersion = HTTPVersion.http1_1, + headers = Header.group $ HTTP.rqHeaders req, + body = HTTP.rqBody req + } + + +instance Show (T body) where + showsPrec _ Cons{command = cmd, uri = loc, httpVersion = ver} = + shows cmd . (' ':) . shows loc . (' ':) . shows ver + +instance HasHeaders (T body) where + getHeaders = Header.ungroup . headers + setHeaders req hs = req { headers = Header.group hs} + +instance Functor T where + fmap f req = + Cons { + command = command req, + uri = uri req, + httpVersion = httpVersion req, + headers = headers req, + body = f $ body req + } + + + +-- Request parsing + +-- Parse the request line and the headers, but not the body. +pHeaders :: Monoid body => Parser (T body) +pHeaders = + do (cmd,loc,ver) <- pCommandLine + hdrs <- Header.pGroup + pCRLF + return $ Cons cmd loc ver hdrs mempty + +pCommandLine :: Parser (Command, URI, HTTPVersion.T) +pCommandLine = + do cmd <- pCommand + many1 pSP + loc <- pURI + many1 pSP + ver <- HTTPVersion.pInRequest + pCRLF + return (cmd,loc,ver) + +commandDictionary :: Map.Map String Command +commandDictionary = + Map.fromList $ + ("HEAD", HTTP.HEAD) : + ("PUT", HTTP.PUT) : + ("GET", HTTP.GET) : + ("POST", HTTP.POST) : + ("DELETE", HTTP.DELETE) : + ("OPTIONS", HTTP.OPTIONS) : + ("TRACE", HTTP.TRACE) : +-- ("CONNECT", HTTP.CONNECT) : + [] + +pCommand :: Parser Command +pCommand = + fmap (\tok -> Map.findWithDefault (HTTP.Custom tok) tok commandDictionary) $ + pToken + +pURI :: Parser URI +pURI = + do u <- many (noneOf [' ']) + -- FIXME: this does not handle authority Request-URIs + -- maybe (fail "Bad Request-URI") return $ parseURIReference u + return $ laxParseURIReference u + +-- also accepts characters [ ] " in queries, which is sometimes quite handy +laxParseURIReference :: String -> URI +laxParseURIReference u = + let (p,q) = break ('?'==) u + in nullURI{uriPath=p, uriQuery=q} + +----------------------------------------------------------------------------- +-- Getting specific request headers + + +data Connection = + ConnectionClose + | ConnectionKeepAlive -- non-std? Netscape generates it. + | ConnectionOther String + deriving (Eq, Show) + +parseConnection :: String -> [Connection] +parseConnection = + let fn "close" = ConnectionClose + fn "keep-alive" = ConnectionKeepAlive + fn other = ConnectionOther other + in map (fn . map toLower) . parseList + +getConnection :: HasHeaders a => a -> [Connection] +getConnection = + concatMap parseConnection . Header.lookupMany Header.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 (HostName, Maybe Int) +getHost x = Header.lookup Header.HdrHost x >>= parseHost + +parseHost :: String -> Maybe (HostName, Maybe Int) +parseHost s = + let (host,prt) = break (==':') s + in case prt of + "" -> Just (host, Nothing) + ':':port -> readM port >>= \p -> Just (host, Just p) + _ -> Nothing diff --git a/src/Network/MoHWS/HTTP/Response.hs b/src/Network/MoHWS/HTTP/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/HTTP/Response.hs @@ -0,0 +1,413 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.HTTP.Response where + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.Stream as Stream +import Network.MoHWS.HTTP.Header (HasHeaders, ) +import Network.MoHWS.ParserUtility (crLf, ) +import Network.MoHWS.Utility (formatTimeSensibly, hPutStrCrLf, ) + +import Control.Monad.Trans.State (state, evalState, get, ) +import Data.Tuple.HT (swap, ) + +import qualified Network.HTTP.Base as HTTP +import qualified Network.HTTP.Headers + -- make getHeaders visible for instance declaration +import Network.URI (URI, ) + +import qualified Data.Map as Map + +import qualified Control.Exception as Exception +import qualified System.IO as IO +import System.Time (getClockTime, toUTCTime, ) +import qualified Text.Html as Html +import Text.Html (Html, renderHtml, toHtml, noHtml, (+++), (<<), ) + + +----------------------------------------------------------------------------- +-- Responses + +data Body body = + Body { + -- e.g. filename of content + source :: String, + size :: Maybe Integer, + close :: IO (), + content :: body + } + +data T body = + Cons { + code :: Int, + description :: String, + headers :: Header.Group, + coding :: [Header.TransferCoding], + {- either empty or terminated with ChunkedTransferEncoding + (RFC2616, sec 3.6) -} + doSendBody :: Bool, + {- actually send the body? + (False for HEAD requests) -} + body :: Body body + } + +instance Functor Body where + fmap f bdy = + Body { + source = source bdy, + size = size bdy, + close = close bdy, + content = f $ content bdy + } + +instance Functor T where + fmap f resp = + Cons { + code = code resp, + description = description resp, + headers = headers resp, + coding = coding resp, + doSendBody = doSendBody resp, + body = fmap f $ body resp + } + +decomposeCode :: Int -> HTTP.ResponseCode +decomposeCode = + let getDigit = state $ swap . flip divMod 10 + in evalState $ + do c <- getDigit + b <- getDigit + a <- get + return (a,b,c) + +toHTTPbis :: T body -> HTTP.Response body +toHTTPbis resp = + HTTP.Response { + HTTP.rspCode = decomposeCode (code resp), + HTTP.rspReason = description resp, + HTTP.rspHeaders = Header.ungroup $ headers resp, + HTTP.rspBody = content $ body resp + } + +fromHTTPbis :: HTTP.Response body -> T body +fromHTTPbis resp = + Cons { + code = + let (a,b,c) = HTTP.rspCode resp + in (a*10+b)*10+c, + description = HTTP.rspReason resp, + headers = Header.group $ HTTP.rspHeaders resp, + coding = [], + doSendBody = True, + body = + Body { + source = "HTTPbis response", + size = Nothing, + close = return (), + content = HTTP.rspBody resp + } + } + + +instance Show (T body) where + showsPrec _ r = + showString (showStatusLine r) . showString crLf . + shows (headers r) + +instance HasHeaders (T body) where + getHeaders = Header.ungroup . headers + setHeaders resp hs = resp { headers = Header.group hs} + +showStatusLine :: T body -> String +showStatusLine (Cons s desc _ _ _ _) = show s ++ " " ++ desc + + +hasBody :: (Stream.C body) => Body body -> Bool +hasBody = not . Stream.isEmpty . content + +getFileName :: Body body -> String +getFileName = source + +sendBody :: (Stream.C body) => IO.Handle -> Body body -> IO () +sendBody h b = + Exception.finally + (do Stream.write h $ content b + IO.hFlush h) + {- + It is only safe to close the source + after all lazily read data is written. + -} + (close b) + +sendBodyChunked :: (Stream.C body) => + Int -> IO.Handle -> Body body -> IO () +sendBodyChunked chunkSize h b = + Exception.finally + (do Stream.writeChunked chunkSize h $ content b + hPutStrCrLf h "0" + hPutStrCrLf h "" + IO.hFlush h) + {- + It is only safe to close the source + after all lazily read data is written. + -} + (close b) + + +-- only allowed in chunked coding +bodyFromString :: (Stream.C body) => body -> Body body +bodyFromString str = + Body { + source = "", + size = Nothing, + close = return (), + content = str + } + +bodyWithSizeFromString :: (Stream.C body) => body -> Body body +bodyWithSizeFromString str = + Body { + source = "", + size = Just $ Stream.length str, + close = return (), + content = str + } + +statusLine :: Int -> String -> String +statusLine cde desc = httpVersion ++ ' ': show cde ++ ' ': desc + +httpVersion :: String +httpVersion = "HTTP/1.1" + + +----------------------------------------------------------------------------- +-- Response Header.Group + +dateHeader :: IO Header.T +dateHeader = do + -- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC + fmap + (Header.make Header.HdrDate . + formatTimeSensibly . + toUTCTime) + getClockTime + +serverHeader :: Header.T +serverHeader = + Header.make Header.HdrServer $ + Config.serverSoftware ++ '/':Config.serverVersion + + +----------------------------------------------------------------------------- +-- Response codes + +makeCont :: (Stream.C body) => Config.T ext -> T body +makeCont = makeError 100 +makeSwitchingProtocols :: (Stream.C body) => Config.T ext -> T body +makeSwitchingProtocols = makeError 101 +makeOk :: Config.T ext -> Bool -> Header.Group -> Body body -> T body +makeOk = makeWithBody 200 +makeCreated :: (Stream.C body) => Config.T ext -> T body +makeCreated = makeError 201 +makeAccepted :: (Stream.C body) => Config.T ext -> T body +makeAccepted = makeError 202 +makeNonAuthoritiveInformation :: (Stream.C body) => Config.T ext -> T body +makeNonAuthoritiveInformation = makeError 203 +makeNoContent :: (Stream.C body) => Config.T ext -> T body +makeNoContent = makeError 204 +makeResetContent :: (Stream.C body) => Config.T ext -> T body +makeResetContent = makeError 205 +makePartialContent :: (Stream.C body) => Config.T ext -> T body +makePartialContent = makeError 206 +makeMultipleChoices :: (Stream.C body) => Config.T ext -> T body +makeMultipleChoices = makeError 300 +makeMovedPermanently :: Config.T ext -> Header.Group -> Body body -> URI -> T body +makeMovedPermanently conf hdrs bdy uri = + makeWithBody 301 conf True + (Header.modifyMany (Header.makeLocation uri :) hdrs) bdy +makeFound :: (Stream.C body) => Config.T ext -> T body +makeFound = makeError 302 +makeSeeOther :: (Stream.C body) => Config.T ext -> T body +makeSeeOther = makeError 303 +makeNotModified :: (Stream.C body) => Config.T ext -> T body +makeNotModified = makeError 304 +makeUseProxy :: (Stream.C body) => Config.T ext -> T body +makeUseProxy = makeError 305 +makeTemporaryRedirect :: (Stream.C body) => Config.T ext -> T body +makeTemporaryRedirect = makeError 307 +makeBadRequest :: (Stream.C body) => Config.T ext -> T body +makeBadRequest = makeError 400 +makeUnauthorized :: (Stream.C body) => Config.T ext -> T body +makeUnauthorized = makeError 401 +makePaymentRequired :: (Stream.C body) => Config.T ext -> T body +makePaymentRequired = makeError 402 +makeForbidden :: (Stream.C body) => Config.T ext -> T body +makeForbidden = makeError 403 +makeNotFound :: (Stream.C body) => Config.T ext -> T body +makeNotFound = makeError 404 +makeMethodNotAllowed :: (Stream.C body) => Config.T ext -> T body +makeMethodNotAllowed = makeError 405 +makeNotAcceptable :: (Stream.C body) => Config.T ext -> T body +makeNotAcceptable = makeError 406 +makeProxyAuthenticationRequired :: (Stream.C body) => Config.T ext -> T body +makeProxyAuthenticationRequired = makeError 407 +makeRequestTimeOut :: (Stream.C body) => Config.T ext -> T body +makeRequestTimeOut = makeError 408 +makeConflict :: (Stream.C body) => Config.T ext -> T body +makeConflict = makeError 409 +makeGone :: (Stream.C body) => Config.T ext -> T body +makeGone = makeError 410 +makeLengthRequired :: (Stream.C body) => Config.T ext -> T body +makeLengthRequired = makeError 411 +makePreconditionFailed :: (Stream.C body) => Config.T ext -> T body +makePreconditionFailed = makeError 412 +makeRequestEntityTooLarge :: (Stream.C body) => Config.T ext -> T body +makeRequestEntityTooLarge = makeError 413 +makeRequestURITooLarge :: (Stream.C body) => Config.T ext -> T body +makeRequestURITooLarge = makeError 414 +makeUnsupportedMediaType :: (Stream.C body) => Config.T ext -> T body +makeUnsupportedMediaType = makeError 415 +makeRequestedRangeNotSatisfiable :: (Stream.C body) => Config.T ext -> T body +makeRequestedRangeNotSatisfiable = makeError 416 +makeExpectationFailed :: (Stream.C body) => Config.T ext -> T body +makeExpectationFailed = makeError 417 +makeInternalServerError :: (Stream.C body) => Config.T ext -> T body +makeInternalServerError = makeError 500 +makeNotImplemented :: (Stream.C body) => Config.T ext -> T body +makeNotImplemented = makeError 501 +makeBadGateway :: (Stream.C body) => Config.T ext -> T body +makeBadGateway = makeError 502 +makeServiceUnavailable :: (Stream.C body) => Config.T ext -> T body +makeServiceUnavailable = makeError 503 +makeGatewayTimeOut :: (Stream.C body) => Config.T ext -> T body +makeGatewayTimeOut = makeError 504 +makeVersionNotSupported :: (Stream.C body) => Config.T ext -> T body +makeVersionNotSupported = makeError 505 + +descriptionDictionary :: Map.Map Int String +descriptionDictionary = + Map.fromList $ + + (100, "Continue") : + (101, "Switching Protocols") : + + (200, "OK") : + (201, "Created") : + (202, "Accepted") : + (203, "Non-Authoritative Information") : + (204, "No Content") : + (205, "Reset Content") : + (206, "Partial Content") : + + (300, "Multiple Choices") : + (301, "Moved Permanently") : + (302, "Found") : + (303, "See Other") : + (304, "Not Modified") : + (305, "Use Proxy") : + (307, "Temporary Redirect") : + + (400, "Bad Request") : + (401, "Unauthorized") : + (402, "Payment Required") : + (403, "Forbidden") : + (404, "Not Found") : + (405, "Method Not Allowed") : + (406, "Not Acceptable") : + (407, "Proxy Authentication Required") : + (408, "Request Time-out") : + (409, "Conflict") : + (410, "Gone") : + (411, "Length Required") : + (412, "Precondition Failed") : + (413, "Request Entity Too Large") : + (414, "Request-URI Too Large") : + (415, "Unsupported Media Type") : + (416, "Requested range not satisfiable") : + (417, "Expectation Failed") : + + (500, "Internal Server Error") : + (501, "Not Implemented") : + (502, "Bad Gateway") : + (503, "Service Unavailable") : + (504, "Gateway Time-out") : + (505, "HTTP Version not supported") : + [] + +descriptionFromCode :: Int -> String +descriptionFromCode c = + Map.findWithDefault "Unknown response" c descriptionDictionary + +makeError :: (Stream.C body) => + Int -> Config.T ext -> T body +makeError cde conf = + makeWithBody cde conf True + (Header.group [Header.makeContentType "text/html"]) + (generateErrorPage cde conf) + +makeWithBody :: Int -> Config.T ext -> Bool -> Header.Group -> Body body -> T body +makeWithBody cde _conf doSend hdrs bdy = + Cons cde (descriptionFromCode cde) hdrs [] doSend bdy + +----------------------------------------------------------------------------- +-- Error pages + +-- We generate some html for the client to display on an error. + +generateErrorPage :: (Stream.C body) => + Int -> Config.T ext -> Body body +generateErrorPage cde conf = + bodyWithSizeFromString $ Stream.fromString (Config.chunkSize conf) $ + renderHtml $ genErrorHtml cde conf + +genErrorHtml :: Int -> Config.T ext -> Html +genErrorHtml cde conf = + let statusLn = + show cde +++ ' ' +++ descriptionFromCode cde + in Html.header << Html.thetitle << statusLn + +++ Html.body << + (Html.h1 << statusLn + +++ Html.hr + +++ Config.serverSoftware +++ '/' +++ Config.serverVersion + -- ToDo: use real hostname if we don't have a serverName + +++ case Config.serverName conf of + "" -> noHtml + me -> " on " +++ me +++ Html.br + +++ case Config.serverAdmin conf of + "" -> noHtml + her -> "Server Admin: " +++ + Html.hotlink ("mailto:"++her) [toHtml her] + ) diff --git a/src/Network/MoHWS/HTTP/Version.hs b/src/Network/MoHWS/HTTP/Version.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/HTTP/Version.hs @@ -0,0 +1,65 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.HTTP.Version ( + T(Cons), major, minor, + http1_1, http1_0, + pInRequest, + ) where + +import Text.ParserCombinators.Parsec (Parser, string, digit, many1, char, ) +import Network.MoHWS.Utility (readM, ) +import Control.Monad (liftM2, ) + + +data T = Cons {major, minor :: Int} + deriving (Eq,Ord) + +instance Show T where + showsPrec _ v = + showString "HTTP/" . shows (major v) . + showString "." . shows (minor v) + +http1_1, http1_0 :: T +http1_1 = Cons 1 1 +http1_0 = Cons 1 0 + +pInRequest :: Parser T +pInRequest = + liftM2 Cons + (string "HTTP/" >> int) + (char '.' >> int) + +int :: Parser Int +int = many1 digit >>= readM diff --git a/src/Network/MoHWS/Initialization.hs b/src/Network/MoHWS/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Initialization.hs @@ -0,0 +1,9 @@ +module Network.MoHWS.Initialization where + +import qualified Network.MoHWS.Module.Description as ModuleDesc + +data T body ext = + Cons { + moduleList :: [ModuleDesc.T body ext], + configurationExtensionDefault :: ext + } diff --git a/src/Network/MoHWS/Initialization/Standard.hs b/src/Network/MoHWS/Initialization/Standard.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Initialization/Standard.hs @@ -0,0 +1,64 @@ +{- | +Copyright: 2006, Bjorn Bringert +Copyright: 2009, Henning Thielemann +-} +module Network.MoHWS.Initialization.Standard (Extension, init, ) where + +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Initialization as Init +import qualified Network.MoHWS.Stream as Stream +import qualified Data.Accessor.Basic as Accessor + +import qualified Network.MoHWS.Part.UserDirectory as UserDir +import qualified Network.MoHWS.Part.VirtualHost as VirtualHost +import qualified Network.MoHWS.Part.AddSlash as AddSlash +import qualified Network.MoHWS.Part.Index as Index +import qualified Network.MoHWS.Part.CGI as CGI +import qualified Network.MoHWS.Part.File as File +import qualified Network.MoHWS.Part.Listing as Listing + +import Prelude hiding (init, ) + + +data Extension = + Extension { + userDir :: UserDir.Configuration, + virtualHost :: VirtualHost.Configuration, + addSlash :: AddSlash.Configuration, + index :: Index.Configuration, + cgi :: CGI.Configuration, + file :: File.Configuration, + listing :: Listing.Configuration + } + +lift :: + (partExt -> fullExt -> fullExt) -> (fullExt -> partExt) -> + ModuleDesc.T body partExt -> ModuleDesc.T body fullExt +lift set get = + ModuleDesc.lift (Accessor.fromSetGet set get) + +moduleList :: (Stream.C body) => [ModuleDesc.T body Extension] +moduleList = + lift (\x ext -> ext{userDir = x}) userDir UserDir.desc : + lift (\x ext -> ext{virtualHost = x}) virtualHost VirtualHost.desc : + lift (\x ext -> ext{addSlash = x}) addSlash AddSlash.desc : + lift (\x ext -> ext{index = x}) index Index.desc : + lift (\x ext -> ext{cgi = x}) cgi CGI.desc : + lift (\x ext -> ext{file = x}) file File.desc : + lift (\x ext -> ext{listing = x}) listing Listing.desc : + [] + +init :: (Stream.C body) => Init.T body Extension +init = + Init.Cons { + Init.moduleList = moduleList, + Init.configurationExtensionDefault = + Extension + (error "uninitialized userDir extension") + (error "uninitialized virtualHost extension") + (error "uninitialized addSlash extension") + (error "uninitialized index extension") + (error "uninitialized cgi extension") + (error "uninitialized file extension") + (error "uninitialized listing extension") + } diff --git a/src/Network/MoHWS/Logger.hs b/src/Network/MoHWS/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Logger.hs @@ -0,0 +1,130 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Logger ( + Handle, + start, + stop, + log, + ) where + +import Network.MoHWS.Utility (dirname, ) + +import qualified Control.Exception as Exception +import Control.Concurrent (Chan, ThreadId, newChan, forkIO, writeChan, readChan, ) +import System.Directory (createDirectoryIfMissing, ) +import System.IO (IOMode(AppendMode), hPutStrLn, stderr, hClose, hFlush, ) +import qualified System.IO as IO + +import Prelude hiding (log, ) + + +data Handle a = Handle + { + handleChan :: Chan (Command a), + handleThreadId :: ThreadId + } + +data T a = Cons + { + chan :: Chan (Command a), + format :: (a -> IO String), + file :: FilePath + } + +data Command a = Stop | Log a + +start :: + (a -> IO String) -- ^ Message formatting function + -> FilePath -- ^ log file path + -> IO (Handle a) +start format0 file0 = + do chan0 <- newChan + createDirectoryIfMissing True (dirname file0) + let l = Cons { + chan = chan0, + format = format0, + file = file0 + } + t <- forkIO (run l + `Exception.catch` + (\e -> hPutStrLn stderr + ("Error starting logger: " ++ show e))) + return $ + Handle { + handleChan = chan0, + handleThreadId = t + } + +stop :: Handle a -> IO () +stop l = writeChan (handleChan l) Stop + +log :: Handle a -> a -> IO () +log l x = writeChan (handleChan l) (Log x) + +-- Internals + +run :: T a -> IO () +run l = run1 l + `Exception.catch` + (\e -> do hPutStrLn stderr ("Logger died: " ++ show e) + run l) + +run1 :: T a -> IO () +run1 l = + Exception.bracket + (openFile (file l)) + (\hdl -> hClose hdl) + (\hdl -> handleCommands l hdl) + where + openFile :: FilePath -> IO IO.Handle + openFile f = + IO.openFile f AppendMode + `Exception.catch` + (\e -> do hPutStrLn stderr ("Failed to open log file: " ++ show e) + Exception.throw e) + +handleCommands :: T a -> IO.Handle -> IO () +handleCommands l hdl = + do comm <- readChan (chan l) + case comm of + Stop -> return () + Log x -> + do writeLine hdl =<< format l x + handleCommands l hdl + where + writeLine :: IO.Handle -> String -> IO () + writeLine hndl str = + do hPutStrLn hndl str + hFlush hndl diff --git a/src/Network/MoHWS/Logger/Access.hs b/src/Network/MoHWS/Logger/Access.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Logger/Access.hs @@ -0,0 +1,156 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Logger.Access ( + Handle, + Request(..), + start, + stop, + mkRequest, + log, + ) where + +import qualified Network.MoHWS.Logger as Logger +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Server.Request as ServerRequest +import Network.MoHWS.Utility (formatTimeSensibly, ) + +import Network.BSD (HostEntry, hostName, ) +import qualified Network.Socket as Socket +import System.Time (ClockTime, toUTCTime, getClockTime, TimeDiff, timeDiffToString, ) +import Control.Monad (liftM, liftM2, ) + +import Prelude hiding (log, ) + + +type Handle = Logger.Handle Request + +{- +FIXME: +Instead of using body type () +we should have data structures for the Response and Request headers +without the body, +like ResponseData and RequestData that are internally used in Network.HTTP. +-} +data Request = Request + { + request :: ServerRequest.T (), + response :: Response.T (), + serverHost :: HostEntry, + time :: ClockTime, + delay :: TimeDiff + } + + +start :: String -> FilePath -> IO Handle +start format file = Logger.start (mkLine format) file + +{- +Instead of the class we could just use IO monad, +but I like to make explicit, +what are the functions that force us to do IO. +-} +class Monad m => Help m where + inet_ntoa :: Socket.HostAddress -> m String + +instance Help IO where + inet_ntoa = Socket.inet_ntoa + +infixr 5 +^+, ^: + +(+^+) :: Monad m => m [a] -> m [a] -> m [a] +(+^+) = liftM2 (++) + +(^:) :: Monad m => a -> m [a] -> m [a] +(^:) x = liftM (x:) + +mkLine :: Help m => String -> Request -> m String +mkLine "" _ = return "" +mkLine ('%':'{':rest) r = + case span (/= '}') rest of + (str, '}':c:rest1) -> expand (Just str) c r +^+ mkLine rest1 r + _ -> '%' ^: '{' ^: mkLine rest r +mkLine ('%':c:rest) r = expand Nothing c r +^+ mkLine rest r +mkLine (c:rest) r = c ^: mkLine rest r + +expand :: Help m => Maybe String -> Char -> Request -> m String +expand arg c info = + let resp = response info + sreq = request info + req = ServerRequest.clientRequest sreq + -- host = clientName (log_request info) + header _ Nothing = "" + header x (Just n) = unwords (Header.lookupMany (Header.makeName n) x) + addr = inet_ntoa (ServerRequest.clientAddress sreq) + in case c of + 'b' -> return $ maybe "unknown" show $ Response.size (Response.body resp) + 'f' -> return $ ServerRequest.serverFilename sreq + + -- %h is the hostname if hostnameLookups is on, otherwise the + -- IP address. + 'h' -> maybe addr (return . hostName) (ServerRequest.clientName sreq) + 'a' -> addr + 'l' -> return "-" -- FIXME: does anyone use identd these days? + 'r' -> return $ show req + -- ToDo: 'p' -> canonical port number of server + 's' -> return $ show (Response.code resp) + 't' -> return $ formatTimeSensibly (toUTCTime (time info)) + 'T' -> return $ timeDiffToString (delay info) + 'v' -> return $ hostName (serverHost info) + 'u' -> return "-" -- FIXME: implement HTTP auth + + 'i' -> return $ header req arg + 'o' -> return $ header resp arg + + -- ToDo: other stuff + _ -> return ['%',c] + +stop :: Handle -> IO () +stop l = Logger.stop l + +mkRequest :: ServerRequest.T body -> Response.T body -> HostEntry -> TimeDiff -> IO Request +mkRequest req resp host delay0 = + do time0 <- getClockTime + return $ + Request { + request = fmap (const ()) req, + response = fmap (const ()) resp, + serverHost = host, + time = time0, + delay = delay0 + } + +log :: Handle -> Request -> IO () +log l r = Logger.log l r diff --git a/src/Network/MoHWS/Logger/Error.hs b/src/Network/MoHWS/Logger/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Logger/Error.hs @@ -0,0 +1,138 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Logger.Error ( + Handle, + start, + stop, + log, + + HasHandle(getHandle), + debug, + abort, + debugOnAbort, + logError, + logInfo, + logDebug, + ) where + +import qualified Network.MoHWS.Logger as Logger +import qualified Network.MoHWS.Logger.Level as LogLevel +import Network.MoHWS.Utility (formatTimeSensibly, ) + +import System.Time (ClockTime, toUTCTime, getClockTime, ) + +import Control.Concurrent (myThreadId, ) +import Control.Monad.Trans (lift, MonadIO, liftIO, ) +import Control.Monad (mzero, ) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, ) + + +import Prelude hiding (log, ) + + +data Handle = Handle + { + logger ::Logger.Handle Message, + minLevel :: LogLevel.T + } + +data Message = Message + { + time :: ClockTime, + string :: String + } + + +start :: FilePath -> LogLevel.T -> IO Handle +start file level = + do l <- Logger.start (return . format) file + let h = Handle { + logger = l, + minLevel = level + } + log h LogLevel.Warn $ "Starting error logger with log level " + ++ show level ++ "..." + return h + where format m = formatTimeSensibly (toUTCTime (time m)) + ++ " " ++ string m + +stop :: Handle -> IO () +stop l = + do log l LogLevel.Warn "Stopping error logger..." + Logger.stop (logger l) + +log :: Handle -> LogLevel.T -> String -> IO () +log l level s = + if level < minLevel l + then return () + else do t <- getClockTime + Logger.log (logger l) (Message t s) + + +-- * logging in more general contexts + +class HasHandle h where + getHandle :: h -> Handle + +instance HasHandle Handle where + getHandle = id + + +debug :: (HasHandle h, MonadIO io) => h -> String -> io () +debug h s = + liftIO $ + do t <- myThreadId + logDebug h $ show t ++ ": " ++ s + +abort :: (HasHandle h) => h -> String -> MaybeT IO a +abort h s = lift (debug h s) >> mzero + +debugOnAbort :: (HasHandle h) => h -> String -> MaybeT IO a -> MaybeT IO a +debugOnAbort h s act = + MaybeT $ + do x <- runMaybeT act + case x of + Nothing -> debug h s + _ -> return () + return x + +logError :: (HasHandle h) => h -> String -> IO () +logError h = log (getHandle h) LogLevel.Error + +logInfo :: (HasHandle h) => h -> String -> IO () +logInfo h = log (getHandle h) LogLevel.Info + +logDebug :: (HasHandle h) => h -> String -> IO () +logDebug h = log (getHandle h) LogLevel.Debug diff --git a/src/Network/MoHWS/Logger/Level.hs b/src/Network/MoHWS/Logger/Level.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Logger/Level.hs @@ -0,0 +1,37 @@ +module Network.MoHWS.Logger.Level (T(..)) where + +import qualified Data.Map as Map + + +data T = + Debug + | Info + | Notice + | Warn + | Error + | Crit + | Alert + | Emerg + deriving (Eq,Ord,Enum,Bounded) + + +names :: Map.Map T String +names = + Map.fromList $ + (Debug, "debug") : + (Info, "info") : + (Notice, "notice") : + (Warn, "warn") : + (Error, "error") : + (Crit, "crit") : + (Alert, "alert") : + (Emerg, "emerg") : + [] + +instance Show T where + show l = + Map.findWithDefault + (error $ "LogLevel.names is incomplete") l names + +instance Read T where + readsPrec _ s = [ (l,"") | (l,n) <- Map.toList names, n == s ] diff --git a/src/Network/MoHWS/Module.hs b/src/Network/MoHWS/Module.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Module.hs @@ -0,0 +1,46 @@ +{- | +Copyright: 2006, Bjorn Bringert +Copyright: 2009, Henning Thielemann +-} +module Network.MoHWS.Module where + +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Server.Request as ServerRequest +import Control.Monad.Trans.Maybe (MaybeT, ) +import Control.Monad (mzero, ) +import Network.Socket (HostName, ) + + +{- | +'isServerHost' allows for advanced checks of the appropriate domain, +e.g. we can catch all subdomains of a certain domain. +-} +data T body = Cons + { + isServerHost :: HostName -> Bool, + translatePath :: String -> String -> MaybeT IO FilePath, + tweakRequest :: ServerRequest.T body -> IO (ServerRequest.T body), + handleRequest :: ServerRequest.T body -> MaybeT IO (Response.T body) + } + +empty :: T body +empty = + Cons { + isServerHost = \_ -> False, + translatePath = \_ _ -> mzero, + tweakRequest = \r -> return r, + handleRequest = \_ -> mzero + } + +{- | +We use the type variable 'server' +although it will be always instantiated with 'ServerContext.T'. +However, with this type variable we avoid mutual recursive Haskell modules +for Module and ServerContext. +-} +tweakFilename :: + (server -> FilePath -> IO FilePath) -> + server -> ServerRequest.T body -> IO (ServerRequest.T body) +tweakFilename f conf req = + do filename <- f conf (ServerRequest.serverFilename req) + return $ req { ServerRequest.serverFilename = filename } diff --git a/src/Network/MoHWS/Module/Description.hs b/src/Network/MoHWS/Module/Description.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Module/Description.hs @@ -0,0 +1,37 @@ +{- | +Copyright: 2006, Bjorn Bringert +Copyright: 2009, Henning Thielemann +-} +module Network.MoHWS.Module.Description where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Data.Accessor.Basic as Accessor + + +data T body ext = Cons + { + name :: String, + load :: ServerContext.T ext -> IO (Module.T body), + configParser :: ConfigParser.T () ext, + setDefltConfig :: ext -> ext + } + +empty :: T body ext +empty = Cons + { + name = "", + load = const $ return Module.empty, + configParser = fail "no parser available", -- identity element for 'Parsec.choice' + setDefltConfig = id + } + +lift :: Accessor.T fullExt partExt -> T body partExt -> T body fullExt +lift acc desc = Cons + { + name = name desc, + load = load desc . fmap (Accessor.get acc), + configParser = ConfigParser.lift acc $ configParser desc, + setDefltConfig = Accessor.modify acc (setDefltConfig desc) + } diff --git a/src/Network/MoHWS/ParserUtility.hs b/src/Network/MoHWS/ParserUtility.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/ParserUtility.hs @@ -0,0 +1,85 @@ +-- HTTP parsing utilities +-- Copyright : (c) Peter Thiemann 2001,2002 +-- (c) Bjorn Bringert 2005-2006 +module Network.MoHWS.ParserUtility where + +import Network.MoHWS.Utility (splitBy, ) + +import Control.Monad (liftM2, ) +import Data.Char (chr, ) +import Data.List ((\\), ) +import Data.List.HT (dropWhileRev, ) +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 = dropWhileRev isLWSChar . dropLeadingLWS + +isLWSChar :: Char -> Bool +isLWSChar c = c == ' ' || c == '\t' + + +-- Read input up to the first empty line +getUntilEmptyLine :: Handle -> IO String +getUntilEmptyLine h = + do l <- hGetLine h + if emptyLine l + then return "\n" + else getUntilEmptyLine h >>= return . ((l++) . ('\n':)) + +emptyLine :: String -> Bool +emptyLine "\r" = True +emptyLine "" = True +emptyLine _ = False + + +countBetween :: Int -> Int -> GenParser tok st a -> GenParser tok st [a] +countBetween 0 0 _ = return [] +countBetween 0 ma p = option [] (liftM2 (:) p (countBetween 0 (ma-1) p)) +countBetween mi ma p = liftM2 (:) p (countBetween (mi-1) (ma-1) p) diff --git a/src/Network/MoHWS/Part/AddSlash.hs b/src/Network/MoHWS/Part/AddSlash.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/AddSlash.hs @@ -0,0 +1,94 @@ +{- | +Copyright: 2009, Henning Thielemann + +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/. +E.g. look at http://www.haskell.org/happy/. +-} +module Network.MoHWS.Part.AddSlash (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Stream as Stream +import qualified Network.URI as URI + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) + +import Control.Monad.Trans.Maybe (MaybeT, ) +import Control.Monad (guard, ) +import Network.MoHWS.Utility (hasTrailingSlash, statFile, ) + +import System.Posix (isDirectory, ) + + +desc :: (Stream.C body) => ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "add slash", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + addSlash_ :: Bool + } + +defltConfig :: Configuration +defltConfig = + Configuration { + addSlash_ = True + } + +addSlash :: Accessor.T Configuration Bool +addSlash = + Accessor.fromSetGet (\x c -> c{addSlash_ = x}) addSlash_ + +parser :: ConfigParser.T st Configuration +parser = + ConfigParser.field "addslash" p_addSlash + +p_addSlash :: ConfigParser.T st Configuration +p_addSlash = + ConfigParser.set (ConfigA.extension .> addSlash) $ ConfigParser.bool + +funs :: (Stream.C body) => + ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.handleRequest = handleRequest st + } + +handleRequest :: (Stream.C body) => + ServerContext.T Configuration -> ServerRequest.T body -> MaybeT IO (Response.T body) +handleRequest st req = + let conf = ServerContext.config st + uri = Request.uri $ ServerRequest.clientRequest req + path = URI.uriPath uri + in do guard $ addSlash_ $ Config.extension conf + guard =<< (fmap isDirectory $ statFile $ ServerRequest.serverFilename req) + guard $ not $ hasTrailingSlash $ path + return $ redirectResponse conf $ uri{URI.uriPath=path++"/"} + +redirectResponse :: (Stream.C body) => + Config.T Configuration -> URI.URI -> Response.T body +redirectResponse conf = + Response.makeMovedPermanently + conf + (Header.group [Header.makeContentType "text/plain"]) + (Response.bodyWithSizeFromString $ + Stream.fromString 100 "add trailing slash to directory path") diff --git a/src/Network/MoHWS/Part/CGI.hs b/src/Network/MoHWS/Part/CGI.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/CGI.hs @@ -0,0 +1,302 @@ +{- | +Copyright: 2006, Bjorn Bringert. +Copyright: 2009, Henning Thielemann. +-} +module Network.MoHWS.Part.CGI ( + Configuration, desc, + mkCGIEnv, mkCGIResponse, + ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Stream as Stream +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import Network.MoHWS.Logger.Error (debug, abort, debugOnAbort, logError, ) +import qualified Network.MoHWS.Utility as Util + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) +import qualified Text.ParserCombinators.Parsec as Parsec +import Network.MoHWS.ParserUtility (trimLWS, ) + +import Data.Tuple.HT (mapFst, ) +import Data.Bool.HT (if', ) +import Control.Monad.Trans.Maybe (MaybeT, ) +import Control.Concurrent (forkIO, ) +import qualified Control.Exception as Exception +import Control.Monad.Trans (lift, ) +import Control.Monad (when, mzero, ) +import Data.Char (toUpper, ) +import Data.List (isSuffixOf, ) +import Network.BSD (hostName, ) +import Network.Socket (inet_ntoa, ) +import Network.URI (uriQuery, ) +import qualified System.IO as IO +import System.IO.Error (isEOFError, ) +import System.Posix (isDirectory, isRegularFile, isSymbolicLink, ) +import System.Process (runInteractiveProcess, waitForProcess, ) +import Text.ParserCombinators.Parsec (parse, ) + + +desc :: (Stream.C body) => ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "cgi", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + suffixes_ :: [String] + } + +defltConfig :: Configuration +defltConfig = + Configuration { + suffixes_ = [".cgi"] + } + +suffixes :: Accessor.T Configuration [String] +suffixes = + Accessor.fromSetGet (\x c -> c{suffixes_ = x}) suffixes_ + +parser :: ConfigParser.T st Configuration +parser = + ConfigParser.field "cgisuffixes" p_suffixes + +p_suffixes :: ConfigParser.T st Configuration +p_suffixes = + ConfigParser.set (ConfigA.extension .> suffixes) $ + Parsec.many ConfigParser.stringLiteral + +funs :: (Stream.C body) => + ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.handleRequest = handleRequest st + } + +handleRequest :: (Stream.C body) => + ServerContext.T Configuration -> ServerRequest.T body -> MaybeT IO (Response.T body) +handleRequest st sreq = + do let conf = ServerContext.config st + (pathProg, pathInfo) <- + debugOnAbort st ("CGI: not handling " ++ ServerRequest.serverFilename sreq) $ + findProg st (ServerRequest.serverFilename sreq) + let sufs = suffixes_ $ Config.extension conf + when (not $ any (flip isSuffixOf pathProg) sufs) + (abort st $ "CGI: not handling " ++ ServerRequest.serverFilename sreq ++ ", wrong suffix") + let hndle = handleRequest2 st sreq pathProg pathInfo + lift $ + case Request.command (ServerRequest.clientRequest sreq) of + Request.GET -> hndle False + Request.POST -> hndle True + _ -> return $ Response.makeNotImplemented conf + +handleRequest2 :: (Stream.C body) => + ServerContext.T ext -> ServerRequest.T body -> FilePath -> String -> Bool -> IO (Response.T body) +handleRequest2 st sreq pathProg pathInfo useReqBody = + do let conf = ServerContext.config st + let req = ServerRequest.clientRequest sreq + + env <- mkCGIEnv st sreq pathInfo + let wdir = Util.dirname pathProg + prog = "./" ++ Util.basename pathProg + + 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 IO.hClose inp + + -- log process stderr to the error log + forkIO (logErrorsFromHandle st err) + + -- FIXME: exception handling + -- FIXME: close handle? + output <- Stream.readAll (Config.chunkSize conf) 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 $ Response.makeInternalServerError conf + Right (outputHeaders, content) -> + mkCGIResponse outputHeaders content out + +mkCGIResponse :: Header.Group -> body -> IO.Handle -> IO (Response.T body) +mkCGIResponse outputHeaders content h = + do let stat = Header.lookup (Header.HdrCustom "Status") outputHeaders + loc = Header.lookup Header.HdrLocation outputHeaders + (code,dsc) <- + case stat of + Nothing -> let c = maybe 200 (\_ -> 302) loc + in return (c, Response.descriptionFromCode c) + Just s -> case reads s of + [(c,r)] -> return (c, trimLWS r) + _ -> fail "Bad Status line" + + let body = + Response.Body { + Response.size = Nothing, + Response.source = "CGI script", + Response.close = IO.hClose h, + Response.content = content + } + + -- FIXME: don't use response constructor directly + return $ + Response.Cons code dsc outputHeaders [Header.ChunkedTransferCoding] True body + +-- Split the requested file system path into the path to an +-- existing file, and some extra path info +findProg :: ServerContext.T ext -> FilePath -> MaybeT IO (FilePath,String) +findProg st filename = + case Util.splitPath filename of + [] -> mzero -- this should never happen + [""] -> mzero -- we got an empty path + "":p -> firstFile st "/" p -- absolute path + p:r -> firstFile st p r -- relative path + +-- similar to Module.File.handleRequest +firstFile :: ServerContext.T ext -> FilePath -> [String] -> MaybeT IO (FilePath,String) +firstFile st p pis = + let conf = ServerContext.config st + + mkPath x y = + if Util.hasTrailingSlash x + then x ++ y + else x ++ "/" ++ y + + mkPathInfo [] = "" + mkPathInfo q = "/" ++ Util.glue "/" q + + checkStat stat = + if' (isDirectory stat) + (case pis of + [] -> abort st $ "findProg: " ++ show p ++ " is a directory" + f:pis' -> firstFile st (mkPath p f) pis') $ + if' (isRegularFile stat) (return (p,mkPathInfo pis)) $ + if' (isSymbolicLink stat) + (if Config.followSymbolicLinks conf + then Util.statFile p >>= checkStat + else abort st ("findProg: Not following symlink: " ++ show p)) $ + (abort st $ "Strange file: " ++ show p) + in debugOnAbort st ("findProg: Not found: " ++ show p) (Util.statSymLink p) >>= + checkStat + +mkCGIEnv :: ServerContext.T ext -> ServerRequest.T body -> String -> IO [(String,String)] +mkCGIEnv _st sreq pathInfo = + do let req = ServerRequest.clientRequest sreq + remoteAddr <- inet_ntoa (ServerRequest.clientAddress sreq) + let scriptName = ServerRequest.serverURIPath sreq `Util.dropSuffix` pathInfo + -- FIXME: use canonical name if there is no ServerName + serverEnv = + [ + ("SERVER_SOFTWARE", Config.serverSoftware + ++ "/" ++ Config.serverVersion), + ("SERVER_NAME", hostName (ServerRequest.requestHostName sreq)), + ("GATEWAY_INTERFACE", "CGI/1.1") + ] + requestEnv = + [ + ("SERVER_PROTOCOL", show (Request.httpVersion req)), + ("SERVER_PORT", show (ServerRequest.serverPort sreq)), + ("REQUEST_METHOD", show (Request.command req)), + ("PATH_TRANSLATED", ServerRequest.serverFilename sreq), + ("SCRIPT_NAME", scriptName), + ("QUERY_STRING", uriQuery (Request.uri req) `Util.dropPrefix` "?"), + ("REMOTE_ADDR", remoteAddr), + ("PATH_INFO", pathInfo), + ("PATH", "/usr/local/bin:/usr/bin:/bin") + ] + ++ maybeHeader "AUTH_TYPE" Nothing -- FIXME + ++ maybeHeader "REMOTE_USER" Nothing -- FIXME + ++ maybeHeader "REMOTE_IDENT" Nothing -- FIXME + ++ maybeHeader "REMOTE_HOST" (fmap hostName (ServerRequest.clientName sreq)) + ++ maybeHeader "CONTENT_TYPE" (Header.getContentType req) + ++ maybeHeader "CONTENT_LENGTH" (fmap show $ Header.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 :: (Stream.C body) => + IO.Handle -> Request.T body -> IO () +writeBody h req = + Stream.write h (Request.body req) + `Exception.finally` + IO.hClose h + +-- | Reads lines form the given 'Handle' and log them with 'logError'. +logErrorsFromHandle :: ServerContext.T ext -> IO.Handle -> IO () +logErrorsFromHandle st h = + (loop `Exception.catch` \e -> + case e of + Exception.IOException f | isEOFError f -> return () + _ -> logError st $ "CGI:" ++ show e) + `Exception.finally` IO.hClose h + where loop = do l <- IO.hGetLine h + logError st l + loop + +maybeHeader :: String -> Maybe String -> [(String,String)] +maybeHeader n = maybe [] ((:[]) . (,) n) + +{- +expects CRLF line endings, which is too strict + +parseCGIOutput :: B.ByteString -> Either String (Header.Group, B.ByteString) +parseCGIOutput s = + let (hdrsStr, body) = breakHeaders s + in case parse Header.pGroup "CGI output" hdrsStr of + Left err -> Left (show err) + Right hdrs -> Right (hdrs, body) + +breakHeaders :: B.ByteString -> (String, B.ByteString) +breakHeaders = + (\(hdrs, body) -> + mapFst (map B.head hdrs ++) $ + if B.null $ head body + then ("", B.empty) + else (crLf, body!!4)) . + break (\suffix -> B.isPrefixOf (B.pack (crLf++crLf)) suffix || B.null suffix) . + B.tails +-} + +parseCGIOutput :: (Stream.C body) => body -> Either String (Header.Group, body) +parseCGIOutput s = + let (hdrLines, body) = breakHeaders s + in -- parse headers in one go in order to handle multi-line headers correctly + case parse Header.pGroup "CGI output" $ unlines hdrLines of + Left err -> Left (show err) + Right hdrs -> Right (hdrs, body) + +breakHeaders :: (Stream.C body) => body -> ([String], body) +breakHeaders str = + let (hdr,rest0) = Stream.break (\c -> c=='\r' || c=='\n') str + skip = + if Stream.isPrefixOf (Stream.fromString 2 "\r\n") rest0 || + Stream.isPrefixOf (Stream.fromString 2 "\n\r") rest0 + then 2 else 1 + rest1 = Stream.drop skip rest0 + in if Stream.isEmpty hdr + then ([], rest1) + else mapFst (Stream.toString hdr :) $ breakHeaders rest1 diff --git a/src/Network/MoHWS/Part/DynHS.hs b/src/Network/MoHWS/Part/DynHS.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/DynHS.hs @@ -0,0 +1,103 @@ +-- Copyright 2006 Bjorn Bringert +module Network.MoHWS.Part.DynHS where + +import Network.MoHWS.Part.DynHS.GHCUtil + (Session, initGHC, setLogAction, withCleanUp, getFileValue, ) + +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Network.MoHWS.Stream as Stream +import Network.MoHWS.Server.Request (serverFilename, ) +import Network.MoHWS.Logger.Error (debug, logError, ) + +import Network.MoHWS.Configuration as Config + +import Control.Exception as Exception +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) +import Control.Monad (liftM, mzero, ) +import Data.List (isSuffixOf, ) +import Data.Tuple.HT (mapFst, ) + + +-- FIXME: keep this in config +packageDirectory :: FilePath +packageDirectory = "/usr/lib/ghc-6.8.2" -- last working version was 6.6 + + +desc :: (Stream.C body) => ModuleDesc.T body ext +desc = + ModuleDesc.empty { + ModuleDesc.name = "dynhs", + ModuleDesc.load = loadDynHS + } + +loadDynHS :: (Stream.C body) => + ServerContext.T ext -> IO (Module.T body) +loadDynHS st = + do s <- initGHC packageDirectory + dynhsLoadConfig s st + return $ + Module.empty { + Module.handleRequest = dynhsHandleRequest s st + } + +dynhsLoadConfig :: Session -> ServerContext.T ext -> IO () +dynhsLoadConfig s st = setLogAction s (logError st) + +dynhsHandleRequest :: (Stream.C body) => + Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) +dynhsHandleRequest s st sreq = + if ".hs" `isSuffixOf` serverFilename sreq + then dynhsHandleRequest2 s st sreq + else mzero + +dynhsHandleRequest2 :: (Stream.C body) => + Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) +dynhsHandleRequest2 s st sreq = + MaybeT $ 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 -> + do debug st $ "DynHS: Loaded successfully: " ++ show (serverFilename sreq) + 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 :: (Stream.C body) => + ServerContext.T ext -> ServerRequest.T body -> CGIMain -> IO (Response.T body) +runCgiMain st _sreq cgiMain = + -- FIXME: lots of fake stuff here + do let env = [] + inputs = [] + (hs,content) <- cgiMain env inputs + let headers = + Header.group $ + map (uncurry Header.make . mapFst Header.makeName) hs + let code = 200 + descr = "OK" + return $ + Response.Cons code descr headers [] True $ + Response.bodyWithSizeFromString $ + Stream.fromString (Config.chunkSize (ServerContext.config st)) content + +-- GHC utilities + +logGHCErrors :: (Stream.C body) => + Session -> ServerContext.T ext -> IO a -> IO (Either (Response.T body) a) +logGHCErrors _s st f = + liftM Right f + `Exception.catch` + (\e -> do logError st (show e) + -- FIXME: include error message in response + return $ Left $ Response.makeInternalServerError (ServerContext.config st)) + diff --git a/src/Network/MoHWS/Part/DynHS/CGI.hs b/src/Network/MoHWS/Part/DynHS/CGI.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/DynHS/CGI.hs @@ -0,0 +1,48 @@ +module Network.MoHWS.Part.DynHS.CGI where + +import Network.MoHWS.Part.CGI (mkCGIEnv, mkCGIResponse, ) + +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import ServerRequest (clientRequest, ) + +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 (CGI, runCGIT, ) +import Network.CGI.Protocol + + +hwsRunCGI :: ServerContext.T ext -> ServerRequest.T -> CGI CGIResult -> IO (Response.T String) +hwsRunCGI st sreq cgi = + do let path_info = "" -- FIXME: do the path walk + env <- mkCGIEnv st sreq path_info + let input = BS.pack $ Request.body $ 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 (Header.Group, CGIResult)) -- ^ CGI action. + -> m (Header.Group, ByteString) -- ^ (Response.T String) (headers and content). +runCGI_ vars inp f + = do (hs,outp) <- f $ CGIRequest { + cgiVars = Map.fromList vars, + cgiInputs = decodeInput vars inp, + cgiRequestBody = inp + } + return $ case outp of + CGIOutput c -> (hs',c) + where hs' = if isJust (lookup ct hs) + then hs else hs ++ [(ct,defaultContentType)] + ct = HeaderName "Content-type" + CGINothing -> (hs, BS.empty) + +defaultContentType :: String +defaultContentType = "text/html; charset=ISO-8859-1" diff --git a/src/Network/MoHWS/Part/DynHS/GHCUtil.hs b/src/Network/MoHWS/Part/DynHS/GHCUtil.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/DynHS/GHCUtil.hs @@ -0,0 +1,98 @@ +module Network.MoHWS.Part.DynHS.GHCUtil + (Session, + initGHC, + setLogAction, + withCleanUp, + getFileValue, + -- * Error logging + Severity(..), SrcSpan, PprStyle, Message, + mkLocMessage + ) where + +-- GHC API stuff +import DynFlags (initDynFlags, defaultDynFlags, ) +import ErrUtils (Message, mkLocMessage, ) +import GHC +import HscMain (newHscEnv, ) +import HscTypes (Session(..), ) +import Outputable (PprStyle, ) +import SrcLoc (SrcSpan, ) +import SysTools (initSysTools, ) + +import Data.Dynamic (Typeable, fromDynamic, ) +import Data.IORef (newIORef, ) + + +initGHC :: FilePath -> IO Session +initGHC pkgDir = + do s <- newSession' CompManager (Just pkgDir) + modifySessionDynFlags s (\dflags -> dflags{ hscTarget = HscInterpreted }) + return s + + + +-- Like newSession, 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 (\dflags -> dflags { 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 dflags <- getSessionDynFlags s + setSessionDynFlags s (f dflags) + return () + +withCleanUp :: Session -> IO a -> IO a +withCleanUp s f = + do dflags <- getSessionDynFlags s + defaultCleanupHandler dflags f + +loadFile :: Session -> FilePath -> IO GHC.Module +loadFile s file = + do let t = Target (TargetFile file Nothing) Nothing + setTargets s [t] + success <- load s LoadAllTargets + case success 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 y -> return y + +getFileValue :: Typeable a => Session -> FilePath -> String -> IO a +getFileValue s file x = + do loadFile s file + getValue s x diff --git a/src/Network/MoHWS/Part/File.hs b/src/Network/MoHWS/Part/File.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/File.hs @@ -0,0 +1,117 @@ +{- | +Copyright: 2002, Simon Marlow. +Copyright: 2006, Bjorn Bringert. +Copyright: 2009, Henning Thielemann. +-} +module Network.MoHWS.Part.File (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Stream as Stream +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import Network.MoHWS.Logger.Error (abort, debugOnAbort, ) +import Network.MoHWS.Utility (statFile, statSymLink, epochTimeToClockTime, ) +import qualified System.IO as IO + +import Data.Bool.HT (if', ) +import Control.Monad.Trans.Maybe (MaybeT, ) +import Control.Monad.Trans (lift, ) +import System.Posix (isRegularFile, isSymbolicLink, + FileStatus, fileAccess, modificationTime, fileSize, ) + +desc :: (Stream.C body) => ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "file", + ModuleDesc.load = return . funs, + ModuleDesc.setDefltConfig = const defltConfig + } + +{- | +Dummy Configuration that forces users +to use the lifting mechanism, +which in turn asserts that future extensions are respected. +-} +data Configuration = + Configuration { + } + +defltConfig :: Configuration +defltConfig = + Configuration { + } + + +funs :: (Stream.C body) => + ServerContext.T ext -> Module.T body +funs st = + Module.empty { + Module.handleRequest = handleRequest st + } + +handleRequest :: (Stream.C body) => + ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) +handleRequest st + (ServerRequest.Cons { + ServerRequest.clientRequest = req, + ServerRequest.serverFilename = filename + }) = + let conf = ServerContext.config st + processFile = + do fstat <- statFile filename + lift $ + case Request.command req of + Request.GET -> serveFile st filename fstat False + Request.HEAD -> serveFile st filename fstat True + _ -> return (Response.makeNotImplemented conf) + checkStat stat = + if' (isRegularFile stat) processFile $ + if' (isSymbolicLink stat) + (if Config.followSymbolicLinks conf + then processFile + else abort st $ "findProg: Not following symlink: " ++ show filename) $ + (abort st $ "Strange file: " ++ show filename) + in debugOnAbort st ("File not found: " ++ show filename) + (statSymLink filename) >>= + checkStat + +serveFile :: (Stream.C body) => + ServerContext.T ext -> FilePath -> FileStatus -> Bool -> IO (Response.T body) +serveFile st filename stat is_head = + do + let conf = ServerContext.config st + -- check we can actually read this file + access <- fileAccess filename True{-read-} False False + case access of + False -> return (Response.makeNotFound conf) + -- not "permission denied", we're being paranoid about security. + True -> + do let contentType = ServerContext.getMimeType st filename + + let lastModified = epochTimeToClockTime (modificationTime stat) + + let size = toInteger (fileSize stat) + + h <- IO.openFile filename IO.ReadMode + content <- Stream.readAll (Config.chunkSize conf) h + + let body = + Response.Body { + Response.size = Just size, + Response.source = filename, + Response.close = IO.hClose h, + Response.content = content + } + + return $ + Response.makeOk conf + (not is_head) {- send body -} + (Header.group + [Header.makeContentType contentType, + Header.makeLastModified lastModified]) + body diff --git a/src/Network/MoHWS/Part/Index.hs b/src/Network/MoHWS/Part/Index.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/Index.hs @@ -0,0 +1,91 @@ +{- | +Copyright: 2002, Simon Marlow. +Copyright: 2006, Bjorn Bringert. +Copyright: 2009, Henning Thielemann. + +Show @index.html@ or another configured file +whenever the URI path is a directory. +However, this module gets only active +if the directory path is terminated with a slash. +Without a slash the relative paths will not be processed correct by the web clients +(they will consider relative paths as relative to the superdirectory). +See also "Network.MoHWS.Part.AddSlash". +-} +module Network.MoHWS.Part.Index (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import Network.MoHWS.Logger.Error (debug, ) + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) + +import Network.MoHWS.Utility (statFile, hasTrailingSlash, ) +import Data.Maybe (fromMaybe, ) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT, ) +import Control.Monad.Trans (lift, ) +import Control.Monad (guard, ) + +import qualified System.FilePath as FilePath +import System.Posix (isDirectory, ) + + + +desc :: ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "index", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + index_ :: String + } + +defltConfig :: Configuration +defltConfig = + Configuration { + index_ = "index.html" + } + +index :: Accessor.T Configuration String +index = + Accessor.fromSetGet (\x c -> c{index_ = x}) index_ + +parser :: ConfigParser.T st Configuration +parser = + ConfigParser.field "directoryindex" p_index + +p_index :: ConfigParser.T st Configuration +p_index = + ConfigParser.set (ConfigA.extension .> index) $ ConfigParser.stringLiteral + +funs :: ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.tweakRequest = tweakRequest st + } + +tweakRequest :: ServerContext.T Configuration -> ServerRequest.T body -> IO (ServerRequest.T body) +tweakRequest = Module.tweakFilename fixPath + +fixPath :: ServerContext.T Configuration -> FilePath -> IO FilePath +fixPath st filename = + let conf = ServerContext.config st + in fmap (fromMaybe filename) $ + runMaybeT $ + do guard (hasTrailingSlash filename) + stat <- statFile filename + guard (isDirectory stat) + let indexFilename = FilePath.combine filename $ index_ $ Config.extension conf + lift $ debug st $ "indexFilename = " ++ show indexFilename + statFile indexFilename -- check whether file exists + return indexFilename diff --git a/src/Network/MoHWS/Part/Listing.hs b/src/Network/MoHWS/Part/Listing.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/Listing.hs @@ -0,0 +1,114 @@ +{- | +Copyright: 2009, Henning Thielemann + +Deliver a HTML document containing the contents of a directory. +-} +module Network.MoHWS.Part.Listing (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Stream as Stream + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) + +import qualified Text.Html as Html +import Text.Html((<<), (+++)) +import qualified Network.URI as URI +import Control.Monad.Trans (liftIO, ) +import Control.Monad (guard, ) +import Data.List (sort, ) +import Control.Monad.Trans.Maybe (MaybeT, ) +import Network.MoHWS.Utility (hasTrailingSlash, statFile, ) + +import qualified System.Directory as Dir +import System.Posix (isDirectory, ) + + + +desc :: (Stream.C body) => ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "directorylisting", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + listing_ :: Bool + } + +defltConfig :: Configuration +defltConfig = + Configuration { + listing_ = True + } + +listing :: Accessor.T Configuration Bool +listing = + Accessor.fromSetGet (\x c -> c{listing_ = x}) listing_ + +parser :: ConfigParser.T st Configuration +parser = + ConfigParser.field "directorylisting" p_listing + +p_listing :: ConfigParser.T st Configuration +p_listing = + ConfigParser.set (ConfigA.extension .> listing) $ ConfigParser.bool + +funs :: (Stream.C body) => ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.handleRequest = handleRequest st + } + +handleRequest :: (Stream.C body) => + ServerContext.T Configuration -> ServerRequest.T body -> MaybeT IO (Response.T body) +handleRequest st req = + let conf = ServerContext.config st + dir = ServerRequest.serverFilename req + uri = Request.uri $ ServerRequest.clientRequest req + in do -- liftIO $ print dir + guard $ listing_ $ Config.extension conf + guard =<< (fmap isDirectory $ statFile $ dir) + guard $ hasTrailingSlash $ URI.uriPath uri + files <- liftIO $ Dir.getDirectoryContents dir + return $ htmlResponse conf uri $ htmlList $ + sort $ filter (not . flip elem [".", ".."]) $ files + +htmlList :: [String] -> Html.Html +htmlList = + Html.unordList . + map (\s -> (Html.anchor << s) Html.! [Html.href s]) + +htmlResponse :: (Stream.C body) => + Config.T ext -> URI.URI -> Html.Html -> Response.T body +htmlResponse conf addr body = + Response.makeOk + conf + True + (Header.group [Header.makeContentType "text/html"]) + (Response.bodyWithSizeFromString $ + Stream.fromString (Config.chunkSize conf) $ + Html.renderHtml $ + htmlDoc ("Directory listing of " ++ show addr) body) + +htmlDoc :: String -> Html.Html -> Html.Html +htmlDoc title body = + Html.header + (Html.meta Html.! [Html.httpequiv "content-type", + Html.content "text/html; charset=ISO-8859-1"] + +++ + Html.thetitle << title) + +++ + Html.body body diff --git a/src/Network/MoHWS/Part/UserDirectory.hs b/src/Network/MoHWS/Part/UserDirectory.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/UserDirectory.hs @@ -0,0 +1,77 @@ +{- | +Copyright: 2002, Simon Marlow. +Copyright: 2006, Bjorn Bringert. +Copyright: 2009, Henning Thielemann. +-} +module Network.MoHWS.Part.UserDirectory (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Server.Context as ServerContext +import Network.MoHWS.Logger.Error (debug, ) + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) + +import Control.Monad (mzero, guard, ) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) + +import Control.Exception (tryJust, ioErrors, ) +import System.Posix (homeDirectory, getUserEntryForName, ) + + +desc :: ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "userdirectory", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + userDir_ :: String + } + +defltConfig :: Configuration +defltConfig = + Configuration { + userDir_ = "" + } + +userDir :: Accessor.T Configuration String +userDir = + Accessor.fromSetGet (\x c -> c{userDir_ = x}) userDir_ + +parser :: ConfigParser.T st Configuration +parser = + ConfigParser.field "userdirectory" p_userDir + +p_userDir :: ConfigParser.T st Configuration +p_userDir = + ConfigParser.set (ConfigA.extension .> userDir) $ ConfigParser.stringLiteral + +funs :: ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.translatePath = translatePath st + } + +translatePath :: ServerContext.T Configuration -> String -> String -> MaybeT IO FilePath +translatePath st _host ('/':'~':userpath) = + do let conf = ServerContext.config st + (usr, path) = break (=='/') userpath + dir = userDir_ $ Config.extension conf + guard $ not $ null $ dir + debug st $ "looking for user: " ++ show usr + ent <- + MaybeT $ fmap (either (const Nothing) Just) $ + tryJust ioErrors (getUserEntryForName usr) + let p = '/': homeDirectory ent ++ '/':dir ++ path + debug st $ "userdir path: " ++ p + return p +translatePath _ _ _ = mzero diff --git a/src/Network/MoHWS/Part/VirtualHost.hs b/src/Network/MoHWS/Part/VirtualHost.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Part/VirtualHost.hs @@ -0,0 +1,109 @@ +-- Copyright 2009, Henning Thielemann +module Network.MoHWS.Part.VirtualHost (Configuration, desc, ) where + +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified System.FilePath as FilePath + +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Configuration.Accessor as ConfigA +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import qualified Data.Accessor.Basic as Accessor +import Data.Accessor.Basic ((.>)) +import qualified Text.ParserCombinators.Parsec as Parsec + +import Network.Socket (HostName, ) + +import qualified Data.Map as Map +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) +import Control.Monad (mplus, ) + + +desc :: ModuleDesc.T body Configuration +desc = + ModuleDesc.empty { + ModuleDesc.name = "virtualhost", + ModuleDesc.load = return . funs, + ModuleDesc.configParser = parser, + ModuleDesc.setDefltConfig = const defltConfig + } + +data Configuration = + Configuration { + virtualDocumentRoot_ :: Map.Map HostName FilePath, + virtualFile_ :: Map.Map HostName (Map.Map String FilePath) + } + +defltConfig :: Configuration +defltConfig = + Configuration { + virtualDocumentRoot_ = Map.empty, + virtualFile_ = Map.empty + } + +virtualDocumentRoot :: Accessor.T Configuration (Map.Map HostName FilePath) +virtualDocumentRoot = + Accessor.fromSetGet (\x c -> c{virtualDocumentRoot_ = x}) virtualDocumentRoot_ + +virtualFile :: Accessor.T Configuration (Map.Map HostName (Map.Map String FilePath)) +virtualFile = + Accessor.fromSetGet (\x c -> c{virtualFile_ = x}) virtualFile_ + +parser :: ConfigParser.T st Configuration +parser = + Parsec.choice $ + (ConfigParser.field "virtualdocumentroot" p_virtualDocumentRoot) : + (ConfigParser.field "virtualfile" p_virtualFile) : + [] + +p_virtualDocumentRoot :: ConfigParser.T st Configuration +p_virtualDocumentRoot = + do host <- ConfigParser.stringLiteral + root <- ConfigParser.stringLiteral + return $ + Accessor.modify (ConfigA.extension .> virtualDocumentRoot) + (Map.insert host root) + +p_virtualFile :: ConfigParser.T st Configuration +p_virtualFile = + do host <- ConfigParser.stringLiteral + virtualPath <- ConfigParser.stringLiteral + realPath <- ConfigParser.stringLiteral + return $ + Accessor.modify (ConfigA.extension .> virtualFile) + (Map.insertWith Map.union host (Map.singleton virtualPath realPath)) + +funs :: ServerContext.T Configuration -> Module.T body +funs st = + Module.empty { + Module.isServerHost = isServerHost st, + Module.translatePath = translatePath st + } + +{- | +In earlier versions we did just add the virtual hosts to the ServerAliases +in the configuration step. +I think this solution is cleaner. +-} +isServerHost :: ServerContext.T Configuration -> HostName -> Bool +isServerHost st host = + let ext = Config.extension $ ServerContext.config st + in Map.member host (virtualFile_ ext) || + Map.member host (virtualDocumentRoot_ ext) + +translatePath :: ServerContext.T Configuration -> String -> String -> MaybeT IO FilePath +translatePath st host path = +-- (\x -> print (host,path) >> print x >> return x) $ + MaybeT $ return $ + let conf = ServerContext.config st + ext = Config.extension conf + in mplus + (fmap (FilePath.combine (Config.documentRoot conf)) $ + Map.lookup path =<< Map.lookup host (virtualFile_ ext)) + (case path of + '/':_ -> + fmap (++path) $ +-- fmap (flip FilePath.combine path) $ this omits the trailing slash when path=="/" + Map.lookup host (virtualDocumentRoot_ ext) + _ -> Nothing) diff --git a/src/Network/MoHWS/Server.hs b/src/Network/MoHWS/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Server.hs @@ -0,0 +1,555 @@ +-- ----------------------------------------------------------------------------- +-- Copyright 2002, Simon Marlow. +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +-- 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 Network.MoHWS.Server (main, mainWithOptions, ) where + +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Environment as ServerEnv +import qualified Network.MoHWS.Server.Context as ServerContext +import Network.MoHWS.Logger.Error (debug, logError, logInfo, ) +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Logger.Access as AccessLogger +import qualified Network.MoHWS.Logger.Error as ErrorLogger +import qualified Network.MoHWS.Configuration.Parser as ConfigParser +import Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Initialization as Init +import qualified Network.MoHWS.HTTP.MimeType as MimeType +import qualified Network.MoHWS.Server.Options as Options +import Network.MoHWS.ParserUtility (getUntilEmptyLine, ) +import qualified Network.MoHWS.HTTP.Version as Version +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Stream as Stream +import qualified Network.MoHWS.Utility as Util + +import Data.Monoid (mempty, ) +import Data.Maybe (catMaybes, ) +import Data.Tuple.HT (swap, ) +import Data.List.HT (viewR, ) +import qualified Data.Set as Set + +import Control.Monad.Trans.State (StateT, runStateT, modify, ) +import qualified Control.Monad.Exception.Synchronous as Exc +import qualified Control.Exception as Exception +import Control.Monad.Trans (lift, ) + +import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, ) + +import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, ) +import Control.Exception (Exception(ErrorCall), finally, catchJust, ioErrors, block, unblock, ) +import Control.Monad (liftM, when, ) +import Network.BSD +import Network.Socket hiding (listen) +import qualified Network.Socket as Socket +import Network.URI (uriPath, ) +import System.Environment (getArgs, ) +import System.IO +import System.IO.Error (isAlreadyInUseError, isEOFError, ) +import System.Posix +import Text.ParserCombinators.Parsec (parse, choice, ) + + +{- ----------------------------------------------------------------------------- +ToDo: + +- MAJOR: + +- deal with http version numbers +- timeouts (partly done) +- languages +- per-directory permissions (ala apache) +- error logging levels +- 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) + +- MAYBE: + +- throttling if too many open connections (config: MaxClients) + +-} + + +----------------------------------------------------------------------------- +-- Top-level server + +main :: (Stream.C body) => + Init.T body ext -> IO () +main initExt = + do args <- getArgs + case Options.parse args of + Left err -> Util.die err + Right opts -> mainWithOptions initExt opts + +mainWithOptions :: (Stream.C body) => + Init.T body ext -> Options.T -> IO () +mainWithOptions initExt opts = + do main_thread <- myThreadId + installHandler sigPIPE Ignore Nothing + installHandler sigHUP (Catch (hupHandler main_thread)) Nothing + block $ readConfig initExt 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 :: (Stream.C body) => + Init.T body ext -> Options.T -> IO () +readConfig initExt opts = do + blockSignals sigsToBlock + r <- ConfigParser.run + (choice $ map ModuleDesc.configParser $ Init.moduleList initExt) + (Options.configPath opts) + case r of + Left err -> + Util.die $ unlines $ + "Failed to parse configuration file" : show err : [] + Right b -> do + let updates = map ModuleDesc.setDefltConfig $ Init.moduleList initExt + confExtDeflt = + foldl (flip ($)) (Init.configurationExtensionDefault initExt) updates + conf = b (Config.deflt confExtDeflt) + st <- initServerState opts conf + mods <- fmap catMaybes $ mapM (loadModule st) $ Init.moduleList initExt + topServer st mods initExt + +rereadConfig :: (Stream.C body) => + ServerContext.T ext -> Init.T body ext -> IO () +rereadConfig st initExt = + do mapM_ AccessLogger.stop (ServerContext.accessLoggers st) + ErrorLogger.stop (ServerContext.errorLogger st) + readConfig initExt (ServerContext.options st) + + +initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext) +initServerState opts conf = + do host <- do ent <- getHostEntry + case serverName conf of + "" -> return ent + n -> return ent { hostName = n } + mimeTypes + <- MimeType.loadDictionary (Options.inServerRoot opts (typesConfig conf)) + errorLogger + <- ErrorLogger.start (Options.inServerRoot opts (errorLogFile conf)) (logLevel conf) + accessLoggers + <- sequence [AccessLogger.start format (Options.inServerRoot opts file) + | (file,format) <- customLogs conf] + + let st = ServerContext.Cons + { + ServerContext.options = opts, + ServerContext.config = conf, + ServerContext.hostName = host, + ServerContext.mimeTypes = mimeTypes, + ServerContext.errorLogger = errorLogger, + ServerContext.accessLoggers = accessLoggers + } + + return st + +loadModule :: (Stream.C body) => + ServerContext.T ext -> ModuleDesc.T body ext -> IO (Maybe (Module.T body)) +loadModule st md = + (do logInfo st $ "Loading module " ++ ModuleDesc.name md ++ "..." + fmap Just $ ModuleDesc.load md st) + `Exception.catch` + \e -> do logError st $ unlines ["Error loading module " ++ ModuleDesc.name md, + show e] + return Nothing + +-- 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 :: (Stream.C body) => + ServerContext.T ext -> [Module.T body] -> Init.T body ext -> IO () +topServer st mods initExt = + let startServers = + do ts <- servers st mods + (Util.wait `Exception.catch` + (\e -> case e of + ErrorCall "**restart**" -> + do mapM_ killThread ts + rereadConfig st initExt + _ -> Exception.throw e)) + loop = + (do unblockSignals sigsToBlock + unblock startServers) + `Exception.catch` + (\e -> do logError st ("server: " ++ show e) + loop) + in loop + +servers :: (Stream.C body) => + ServerContext.T ext -> [Module.T body] -> IO [ThreadId] +servers st mods = + let mkEnv port = + ServerEnv.Cons { + ServerEnv.context = st, + ServerEnv.modules = mods, + ServerEnv.port = port + } + + mkAddr (maddr,port) = + do addr <- case maddr of + Nothing -> return iNADDR_ANY + Just ip -> inet_addr ip + return (mkEnv port, SockAddrInet port addr) + + in do addrs <- mapM mkAddr (listen (ServerContext.config st)) + mapM (\ (env,addr) -> forkIO (server env addr)) addrs + + +-- open the server socket and start accepting connections +server :: (Stream.C body) => + ServerEnv.T body ext -> 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 <- Util.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 :: (Stream.C body) => + ServerEnv.T body ext -> 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 :: (Stream.C body) => + ServerEnv.T body ext -> Handle -> HostAddress -> IO () +talk st h haddr = do + debug st "Started" + hSetBuffering h LineBuffering + run st True h haddr + debug st "Done" + +run :: (Stream.C body) => + ServerEnv.T body ext -> Bool -> Handle -> HostAddress -> IO () +run st first h haddr = do + let conf = ServerEnv.config 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 = + if first + then requestTimeout conf + else 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 (Response.makeRequestTimeOut 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 Request.pHeaders "Request" r of + + -- close the connection after a badly formatted request + Left err -> do + debug st (show err) + response st h (Response.makeBadRequest 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 = Request.getConnection (Request.headers reqt) + if Request.ConnectionClose `elem` connection_headers + || (Request.httpVersion reqt < Version.http1_1 + && Request.ConnectionKeepAlive `notElem` connection_headers) + then return () + else run st False h haddr + } + + +getBody :: (Stream.C body) => + Handle -> Request.T body -> IO (Request.T body) +getBody h req = + let -- FIXME: handled chunked input + readBody = + case Header.getContentLength req of + Nothing -> return mempty + -- FIXME: what if input is huge? + Just len -> Stream.read h len + in do b <- readBody + return $ req { Request.body = b} + +----------------------------------------------------------------------------- +-- Dealing with requests + +request :: (Stream.C body) => + ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (Response.T body) +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 (Response.showStatusLine resp) + ServerEnv.logAccess st sreq resp (error "noTimeDiff"){-FIXME-} + return resp + +serverRequest :: (Stream.C body) => + ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (ServerRequest.T body, Maybe (Response.T body)) +serverRequest st req haddr = + let conf = ServerEnv.config st + sreq = + ServerRequest.Cons { + ServerRequest.clientRequest = req, + ServerRequest.clientAddress = haddr, + ServerRequest.clientName = Nothing, + ServerRequest.requestHostName = ServerEnv.hostName st, + ServerRequest.serverURIPath = "-", + ServerRequest.serverFilename = "-", + ServerRequest.serverPort = ServerEnv.port st + } + maybeExc x = + case x of + Exc.Success _ -> Nothing + Exc.Exception e -> Just e + in fmap swap (runStateT + (fmap maybeExc $ runExceptionalT $ serverRequestExc st req haddr) sreq) + `Exception.catch` + ( \exception -> do + logError st ("request: " ++ show exception) + return (sreq, Just (Response.makeInternalServerError conf)) + ) + +serverRequestExc :: (Stream.C body) => + ServerEnv.T body ext -> Request.T body -> HostAddress -> ExceptionalT (Response.T body) (StateT (ServerRequest.T body) IO) () +serverRequestExc st req haddr = + let conf = ServerEnv.config st + use = Exc.mapExceptionalT lift + update = lift . modify + in do remoteName <- use $ lift $ maybeLookupHostname conf haddr + update $ \sreq -> sreq { ServerRequest.clientName = remoteName } + host <- use $ getServerHostName st req + update $ \sreq -> sreq { ServerRequest.requestHostName = host } + path <- use $ requestAbsPath st req + update $ \sreq -> sreq { ServerRequest.serverURIPath = path } + file <- use $ translatePath st (hostName host) path + update $ \sreq -> sreq { ServerRequest.serverFilename = file } + + + +maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry) +maybeLookupHostname conf haddr = + if hostnameLookups conf + then catchJust ioErrors (liftM Just (getHostByAddr AF_INET haddr)) + (\_ -> return Nothing) + else return Nothing + +type EIO body = ExceptionalT (Response.T body) IO + +-- make sure we've got a host field +-- if the request version is >= HTTP/1.1 +getServerHostName :: (Stream.C body) => + ServerEnv.T body ext -> Request.T body -> EIO body HostEntry +getServerHostName st req = + let conf = ServerEnv.config st + isServerHost host = + host `Set.member` (Set.insert (serverName conf) $ serverAlias conf) || + any (flip Module.isServerHost host) (ServerEnv.modules st) + in case Request.getHost req of + Nothing -> + if Request.httpVersion req < Version.http1_1 + then return $ ServerEnv.hostName st + else Exc.throwT $ Response.makeBadRequest conf + Just (host,_) -> + if isServerHost host + then return $ (ServerEnv.hostName st) { hostName = host } + else do lift $ logError st ("Unknown host: " ++ show host) + Exc.throwT $ Response.makeNotFound conf + + +-- | Get the absolute path from the request. +requestAbsPath :: (Stream.C body) => + ServerEnv.T body ext -> Request.T body -> EIO body String +requestAbsPath _ req = return $ uriPath $ Request.uri req + + +-- Path translation + +translatePath :: (Stream.C body) => + ServerEnv.T body ext -> String -> String -> EIO body FilePath +translatePath st host pth = + do m_file <- lift $ ServerEnv.tryModules st (\m -> Module.translatePath m host pth) + case m_file of + Just file -> return $ file + Nothing -> defaultTranslatePath st pth + +defaultTranslatePath :: (Stream.C body) => + ServerEnv.T body ext -> String -> EIO body FilePath +defaultTranslatePath st pth = + let conf = ServerEnv.config st + in case pth of + '/':_ -> return $ documentRoot conf ++ pth + _ -> Exc.throwT $ Response.makeNotFound conf + +-- Request tweaking + +tweakRequest :: (Stream.C body) => + ServerEnv.T body ext -> ServerRequest.T body -> IO (ServerRequest.T body) +tweakRequest st = + ServerEnv.foldModules st (\m r -> Module.tweakRequest m r) + +-- Request handling + +handleRequest :: (Stream.C body) => + ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body) +handleRequest st req = + do m_resp <- ServerEnv.tryModules st (\m -> Module.handleRequest m req) + case m_resp of + Just resp -> return resp + Nothing -> defaultHandleRequest st req + +defaultHandleRequest :: (Stream.C body) => + ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body) +defaultHandleRequest st _ = + return $ Response.makeNotFound $ ServerEnv.config st + +-- Sending response + + +response :: (Stream.C body) => + ServerEnv.T body ext -> + Handle -> + Response.T body -> + IO () + +response env h + (Response.Cons { + Response.code = code, + Response.description = desc, + Response.headers = headers, + Response.coding = tes, + Response.body = body, + Response.doSendBody = sendBody + }) = + do + Util.hPutStrCrLf h (Response.statusLine code desc) + hPutHeader h Response.serverHeader + + -- Date Header: required on all messages + date <- Response.dateHeader + hPutHeader h date + + mapM_ (hPutHeader h) (Header.list 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 contentLength = Response.size body + + when (Response.hasBody body && null tes) + (maybe (return ()) (hPutHeader h . Header.makeContentLength) contentLength) + + mapM_ (hPutHeader h . Header.makeTransferCoding) tes + + Util.hPutStrCrLf h "" + -- ToDo: implement transfer codings + + let conf = ServerEnv.config env + + when sendBody $ + case viewR tes of + Just (_, Header.ChunkedTransferCoding) -> + Response.sendBodyChunked (Config.chunkSize conf) h body + _ -> Response.sendBody h body + +hPutHeader :: Handle -> Header.T -> IO () +hPutHeader h = + hPutStr h . show +-- Util.hPutStrCrLf h . show diff --git a/src/Network/MoHWS/Server/Context.hs b/src/Network/MoHWS/Server/Context.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Server/Context.hs @@ -0,0 +1,57 @@ +{- | +Copyright: 2006, Bjorn Bringert +Copyright: 2009, Henning Thielemann +-} +module Network.MoHWS.Server.Context where + +import qualified Network.MoHWS.Server.Options as Options +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Logger.Access as AccessLogger +import qualified Network.MoHWS.Logger.Error as ErrorLogger +import qualified Network.MoHWS.HTTP.MimeType as MimeType +import qualified Network.MoHWS.HTTP.Response as Response + +import Network.BSD (HostEntry, ) +import System.Time (TimeDiff, ) + + +-- * ServerContext + +data T ext = Cons + { + options :: Options.T, + config :: Config.T ext, + hostName :: HostEntry, + mimeTypes :: MimeType.Dictionary, + errorLogger :: ErrorLogger.Handle, + accessLoggers :: [AccessLogger.Handle] + } + +instance Functor T where + fmap f st = Cons { + options = options st, + config = fmap f $ config st, + hostName = hostName st, + mimeTypes = mimeTypes st, + errorLogger = errorLogger st, + accessLoggers = accessLoggers st + } + + +-- * MIME types + +getMimeType :: T ext -> FilePath -> String +getMimeType st filename = + let def = Config.defaultType (config st) + in maybe def show (MimeType.fromFileName (mimeTypes st) filename) + +-- * Logging + +instance ErrorLogger.HasHandle (T ext) where + getHandle = errorLogger + +logAccess :: T ext -> ServerRequest.T body -> Response.T body -> TimeDiff -> IO () +logAccess st req resp delay = + do msg <- AccessLogger.mkRequest req resp (hostName st) delay + mapM_ (\l -> AccessLogger.log l msg) (accessLoggers st) diff --git a/src/Network/MoHWS/Server/Environment.hs b/src/Network/MoHWS/Server/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Server/Environment.hs @@ -0,0 +1,76 @@ +{- | +Copyright: 2006, Bjorn Bringert +Copyright: 2009, Henning Thielemann + +This is an extension of ServerContext, +which is used privately in the Server. +In addition to ServerContext it holds the module list, +which is not accessible by modules. +-} +module Network.MoHWS.Server.Environment where + +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Network.MoHWS.Server.Options as Options +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Configuration as Config +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.Logger.Access as AccessLogger +import qualified Network.MoHWS.Logger.Error as ErrorLogger +import qualified Network.MoHWS.HTTP.MimeType as MimeType +import qualified Network.MoHWS.HTTP.Response as Response + +import Control.Monad (foldM, msum, ) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT, ) +import Network.BSD (HostEntry, ) +import Network.Socket (PortNumber, ) +import System.Time (TimeDiff, ) + + +data T body ext = Cons + { + context :: ServerContext.T ext, + port :: PortNumber, + modules :: [Module.T body] + } + +-- * Read accessors + +options :: T body ext -> Options.T +options = ServerContext.options . context + +config :: T body ext -> Config.T ext +config = ServerContext.config . context + +hostName :: T body ext -> HostEntry +hostName = ServerContext.hostName . context + +mimeTypes :: T body ext -> MimeType.Dictionary +mimeTypes = ServerContext.mimeTypes . context + +errorLogger :: T body ext -> ErrorLogger.Handle +errorLogger = ServerContext.errorLogger . context + +accessLoggers :: T body ext -> [AccessLogger.Handle] +accessLoggers = ServerContext.accessLoggers . context + + +-- * Loggers + +instance ErrorLogger.HasHandle (T body ext) where + getHandle = errorLogger + +logAccess :: T body ext -> ServerRequest.T body -> Response.T body -> TimeDiff -> IO () +logAccess = ServerContext.logAccess . context + + + +-- * Modules + +mapModules_ :: T body ext -> (Module.T body -> IO ()) -> IO () +mapModules_ st f = mapM_ f (modules st) + +foldModules :: T body ext -> (Module.T body -> a -> IO a) -> a -> IO a +foldModules st f x = foldM (flip f) x (modules st) + +tryModules :: T body ext -> (Module.T body -> MaybeT IO a) -> IO (Maybe a) +tryModules st f = runMaybeT $ msum $ map f $ modules st diff --git a/src/Network/MoHWS/Server/Options.hs b/src/Network/MoHWS/Server/Options.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Server/Options.hs @@ -0,0 +1,58 @@ +module Network.MoHWS.Server.Options ( + T(Cons), + serverRoot, configPath, inServerRoot, + parse, + ) where + +import System.Console.GetOpt + (getOpt, usageInfo, + OptDescr(Option), ArgDescr(ReqArg), ArgOrder(Permute), ) +import qualified System.FilePath as FilePath + + +data T = + Cons { + configFile :: FilePath, + serverRoot :: FilePath + } + + +options :: [OptDescr (T -> T)] +options = + Option ['f'] ["config"] (ReqArg (\path opt -> opt{configFile=path}) "filename") + ("default: \n" ++ show ("/" ++ defltConfigFile)) : + Option ['d'] ["server-root"] (ReqArg (\path opt -> opt{serverRoot=path}) "directory") + ("default: " ++ show defltServerRoot) : + [] + +usage :: String +usage = "usage: hws [option...]" + +defltConfigFile :: FilePath +defltConfigFile = "conf/httpd.conf" + +defltServerRoot :: FilePath +defltServerRoot = "." + +deflt :: T +deflt = + Cons { + configFile = defltConfigFile, + serverRoot = defltServerRoot + } + +configPath :: T -> FilePath +configPath opts = + inServerRoot opts (configFile opts) + +inServerRoot :: T -> FilePath -> FilePath +inServerRoot opts = + FilePath.combine (serverRoot opts) + +-- returns error message or options +parse :: [String] -> Either String T +parse args = + case getOpt Permute options args of + (flags, [], []) -> Right $ foldl (flip ($)) deflt flags + (_, _, errs) -> Left (concat errs ++ "\n" + ++ usageInfo usage options) diff --git a/src/Network/MoHWS/Server/Request.hs b/src/Network/MoHWS/Server/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Server/Request.hs @@ -0,0 +1,33 @@ +-- Copyright 2006, Bjorn Bringert. +-- Copyright 2009, Henning Thielemann. +module Network.MoHWS.Server.Request where + +import qualified Network.MoHWS.HTTP.Request as Request + +import Network.BSD (HostEntry, ) +import Network.Socket (HostAddress, PortNumber, ) + +-- | All the server's information about a request +data T body = Cons + { + clientRequest :: Request.T body, + clientAddress :: HostAddress, + clientName :: Maybe HostEntry, + requestHostName :: HostEntry, + serverURIPath :: String, + serverFilename :: FilePath, + serverPort :: PortNumber + } + deriving Show + +instance Functor T where + fmap f req = + Cons { + clientAddress = clientAddress req, + clientName = clientName req, + requestHostName = requestHostName req, + serverURIPath = serverURIPath req, + serverFilename = serverFilename req, + serverPort = serverPort req, + clientRequest = fmap f $ clientRequest req + } diff --git a/src/Network/MoHWS/Stream.hs b/src/Network/MoHWS/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Stream.hs @@ -0,0 +1,83 @@ +{- | +Copyright: 2009, Henning Thielemann + +Unified interface to String and ByteStrings. +-} +module Network.MoHWS.Stream where + +import Network.MoHWS.ParserUtility (crLf, ) + +import qualified System.IO as IO +import Numeric (showHex, ) + +import qualified Network.MoHWS.ByteString as BU +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS + +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Monoid (Monoid, ) + +import Prelude hiding (length, drop, ) + + +class Monoid stream => C stream where + fromString :: Int -> String -> stream + toString :: stream -> String + isEmpty :: stream -> Bool + length :: stream -> Integer + isPrefixOf :: stream -> stream -> Bool + break :: (Char -> Bool) -> stream -> (stream, stream) + drop :: Int -> stream -> stream + read :: IO.Handle -> Integer -> IO stream + readAll :: Int -> IO.Handle -> IO stream + write :: IO.Handle -> stream -> IO () + writeChunked :: Int -> IO.Handle -> stream -> IO () + +class Eq char => CharType char where + fromChar :: Char -> char + toChar :: char -> Char + +instance CharType Char where + fromChar = id + toChar = id + +instance CharType char => C [char] where + fromString _chunkSize = map fromChar + toString = map toChar + isEmpty = null + length = fromIntegral . List.length + isPrefixOf = List.isPrefixOf + break p = List.break (p . toChar) + drop = List.drop + read h n = fmap (map fromChar) $ BU.hGetChars h (fromInteger n) + readAll _chunkSize = fmap (map fromChar) . IO.hGetContents + write h = IO.hPutStr h . map toChar + writeChunked chunkSize h = + IO.hPutStr h . + foldr ($) "" . + map (\chunk -> + showHex (length chunk) . showString crLf . + showString (map toChar chunk) . showString crLf) . + ListHT.sliceVertical chunkSize + +instance C BL.ByteString where +-- fromString = BL.pack + fromString chunkSize = + BL.fromChunks . + map BS.pack . + ListHT.sliceVertical chunkSize + toString = BL.unpack + isEmpty = BL.null + length = fromIntegral . BL.length + isPrefixOf = BL.isPrefixOf + break = BL.break + drop = BL.drop . fromIntegral + read h n = BL.hGet h (fromInteger n) + readAll = BU.hGetContentsN + write = BL.hPut + writeChunked _chunkSize h str = + flip mapM_ (BL.toChunks str) $ \chunk -> + do IO.hPutStr h $ showHex (BS.length chunk) crLf + BS.hPut h chunk + IO.hPutStr h $ crLf diff --git a/src/Network/MoHWS/Utility.hs b/src/Network/MoHWS/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoHWS/Utility.hs @@ -0,0 +1,195 @@ +-- ----------------------------------------------------------------------------- +-- 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 Network.MoHWS.Utility where + +import qualified Control.Exception as Exception +import Control.Exception (tryJust, ioErrors, catchJust, Exception(IOException), ) +import Control.Concurrent (newEmptyMVar, takeMVar, ) +import Control.Monad (liftM, ) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, ) +import Data.Maybe (fromMaybe, ) +import Data.Tuple.HT (mapSnd, ) +import Data.List (intersperse, ) +import Data.List.HT (switchL, switchR, maybePrefixOf, dropWhileRev, takeWhileRev, inits, tails, ) +import Data.Ratio (numerator, ) +import Foreign.C.Error (getErrno, eNOENT, eNOTDIR, ) +import Network.Socket as Socket +import System.IO +import System.Exit (exitFailure, ) +import System.Locale (defaultTimeLocale, ) +import System.Posix (EpochTime, FileStatus, + getFileStatus, getSymbolicLinkStatus, isSymbolicLink, ) +import System.Time (CalendarTime, formatCalendarTime, ClockTime(TOD), ) + + + +----------------------------------------------------------------------------- +-- 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 + + +----------------------------------------------------------------------------- +-- List utils + +-- Split a list at some delimiter. +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy f = + let recourse = + uncurry (:) . + mapSnd (switchL [] (const recourse)) . + break f + in recourse + +-- now also known as intercalate +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 = + fromMaybe xs $ maybePrefixOf pref 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 = dropWhileRev (/= '/') + +-- Get the filename component of a path +-- FIXME: probably System.FilePath should be used here. +basename :: FilePath -> FilePath +basename = takeWhileRev (/= '/') + +hasTrailingSlash :: FilePath -> Bool +hasTrailingSlash = + switchR False (\_ -> ('/'==)) + + +----------------------------------------------------------------------------- +-- 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 -> MaybeT IO FileStatus +statFile = stat_ getFileStatus + +statSymLink :: String -> MaybeT IO FileStatus +statSymLink = stat_ getSymbolicLinkStatus + +stat_ :: (FilePath -> IO FileStatus) -> String -> MaybeT IO FileStatus +stat_ f filename = MaybeT $ 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) . runMaybeT . statSymLink + +----------------------------------------------------------------------------- +-- 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 diff --git a/src/Options.hs b/src/Options.hs deleted file mode 100644 --- a/src/Options.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Options (Options, - serverRoot, configPath, inServerRoot, - parseOptions) where - -import Data.List (isPrefixOf) -import System.Console.GetOpt - - -type Options = [CmdLineOpt] - -data CmdLineOpt - = O_ConfigFile FilePath - | O_ServerRoot FilePath - - -options :: [OptDescr CmdLineOpt] -options = [ - Option ['f'] ["config"] (ReqArg O_ConfigFile "filename") - ("default: \n" ++ show ("/" ++ defaultConfigFile)), - Option ['d'] ["server-root"] (ReqArg O_ServerRoot "directory") - ("default: " ++ show defaultServerRoot) - ] - -usage :: String -usage = "usage: hws [option...]" - -defaultConfigFile :: FilePath -defaultConfigFile = "conf/httpd.conf" - -defaultServerRoot :: FilePath -defaultServerRoot = "." - -serverRoot :: Options -> FilePath -serverRoot opts = - case [ s | O_ServerRoot s <- opts] of - [] -> defaultServerRoot - s -> last s - -configPath :: Options -> FilePath -configPath args = inServerRoot args (configFile args) - -configFile :: Options -> FilePath -configFile args = - case [ s | O_ConfigFile s <- args] of - [] -> defaultConfigFile - s -> last s - -inServerRoot :: Options -> FilePath -> FilePath -inServerRoot opts f | "/" `isPrefixOf` f = f - | otherwise = serverRoot opts ++ '/':f - --- returns error message or options -parseOptions :: [String] -> Either String Options -parseOptions args = - case getOpt Permute options args of - (flags, [], []) -> Right flags - (_, _, errs) -> Left (concat errs ++ "\n" - ++ usageInfo usage options) diff --git a/src/Parse.hs b/src/Parse.hs deleted file mode 100644 --- a/src/Parse.hs +++ /dev/null @@ -1,84 +0,0 @@ --- HTTP parsing utilities --- Copyright : (c) Peter Thiemann 2001,2002 --- (c) Bjorn Bringert 2005-2006 -module Parse where - -import Util - -import Control.Monad (liftM2) -import Data.Char -import Data.List -import System.IO (Handle, hGetLine) -import Text.ParserCombinators.Parsec - - -pSP :: Parser Char -pSP = char ' ' - --- | RFC 822 LWSP-char -pWS1 :: Parser Char -pWS1 = oneOf " \t" - -crLf :: String -crLf = "\r\n" - --- | RFC 2616 CRLF -pCRLF :: Parser String -pCRLF = try (string "\r\n" <|> string "\n\r") <|> string "\n" <|> string "\r" - -lexeme :: Parser a -> Parser a -lexeme p = do x <- p; many pWS1; return x - --- | One line -lineString :: Parser String -lineString = many (noneOf "\n\r") - -headerNameChar :: Parser Char -headerNameChar = noneOf "\n\r:" - -especials, tokenchar :: [Char] -especials = "()<>@,;:\\\"/[]?.=" -tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials - -pToken :: Parser String -pToken = many1 (oneOf tokenchar) - -textChars :: [Char] -textChars = map chr ([1..9] ++ [11,12] ++ [14..127]) - -pText :: Parser Char -pText = oneOf textChars - - --- parse the list format described in RFC 2616, section 2.1 -parseList :: String -> [String] -parseList = map trimLWS . splitBy (==',') - -dropLeadingLWS :: String -> String -dropLeadingLWS = dropWhile isLWSChar - -trimLWS :: String -> String -trimLWS = reverse . dropLeadingLWS . reverse . dropLeadingLWS - -isLWSChar :: Char -> Bool -isLWSChar c = c == ' ' || c == '\t' - - --- Read input up to the first empty line -getUntilEmptyLine :: Handle -> IO String -getUntilEmptyLine h = - do l <- hGetLine h - if emptyLine l - then return "\n" - else getUntilEmptyLine h >>= return . ((l++) . ('\n':)) - -emptyLine :: String -> Bool -emptyLine "\r" = True -emptyLine "" = True -emptyLine _ = False - - -countBetween :: Int -> Int -> GenParser tok st a -> GenParser tok st [a] -countBetween 0 0 _ = return [] -countBetween 0 ma p = option [] (liftM2 (:) p (countBetween 0 (ma-1) p)) -countBetween mi ma p = liftM2 (:) p (countBetween (mi-1) (ma-1) p) diff --git a/src/Request.hs b/src/Request.hs deleted file mode 100644 --- a/src/Request.hs +++ /dev/null @@ -1,208 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module Request ( - HTTPVersion(..), - http1_1, http1_0, - Request(..), - RequestCmd(..), - RequestBody, - Connection(..), - Expect(..), - pRequestHeaders, - getHost, - getConnection - ) where - -import Text.ParserCombinators.Parsec - -import Headers -import Parse -import Util - -import Data.Char -import Data.Maybe -import Network.URI - - ------------------------------------------------------------------------------ --- Requests - --- Request-Line = Method SP Request-URI SP HTTP-Version CRLF - -data RequestCmd - = OptionsReq - | GetReq - | HeadReq - | PostReq - | PutReq - | DeleteReq - | TraceReq - | ConnectReq - | ExtensionReq String - -instance Show RequestCmd where - show c = case c of - OptionsReq -> "OPTIONS" - GetReq -> "GET" - HeadReq -> "HEAD" - PostReq -> "POST" - PutReq -> "PUT" - DeleteReq -> "DELETE" - TraceReq -> "TRACE" - ConnectReq -> "CONNECT" - ExtensionReq s -> s - -data Request = Request { - reqCmd :: RequestCmd, - reqURI :: URI, - reqHTTPVer :: HTTPVersion, - reqHeaders :: Headers, - reqBody :: RequestBody - } - -instance Show Request where - showsPrec _ Request{reqCmd = cmd, reqURI = uri, reqHTTPVer = ver} - = shows cmd . (' ':) . shows uri . (' ':) . shows ver - -instance HasHeaders Request where - getHeaders = reqHeaders - setHeaders req hs = req { reqHeaders = hs} - - -data HTTPVersion = HTTPVersion Int Int - deriving (Eq,Ord) - -instance Show HTTPVersion where - showsPrec _ (HTTPVersion maj mini) = - showString "HTTP/" . shows maj . showString "." . shows mini - -http1_1, http1_0 :: HTTPVersion -http1_1 = HTTPVersion 1 1 -http1_0 = HTTPVersion 1 0 - - --- FIXME: use something more efficient -type RequestBody = String - - --- Request parsing - --- Parse the request line and the headers, but not the body. -pRequestHeaders :: Parser Request -pRequestHeaders = - do (cmd,uri,ver) <- pRequestLine - headers <- pHeaders - pCRLF - return $ Request cmd uri ver headers "" - -pRequestLine :: Parser (RequestCmd, URI, HTTPVersion) -pRequestLine = do cmd <- pReqCmd - many1 pSP - uri <- pReqURI - many1 pSP - ver <- pReqHTTPVer - pCRLF - return (cmd,uri,ver) - -pReqCmd :: Parser RequestCmd -pReqCmd = choice [ - c "OPTIONS" OptionsReq, - c "GET" GetReq, - c "HEAD" HeadReq, - c "POST" PostReq, - c "PUT" PutReq, - c "DELETE" DeleteReq, - c "TRACE" TraceReq, - c "CONNECT" ConnectReq, - pToken >>= return . ExtensionReq - ] - where c x y = try (string x >> return y) - -pReqURI :: Parser URI -pReqURI = - do u <- many (noneOf [' ']) - -- FIXME: this does not handle authority Request-URIs - maybe (fail "Bad Request-URI") return $ parseURIReference u - -pReqHTTPVer :: Parser HTTPVersion -pReqHTTPVer = do string "HTTP/"; - major <- int; - char '.'; - minor <- int; - return $ HTTPVersion major minor - -int :: Parser Int -int = many1 digit >>= readM - ------------------------------------------------------------------------------ --- Getting specific request headers - - -data Connection - = ConnectionClose - | ConnectionKeepAlive -- non-std? Netscape generates it. - | ConnectionOther String - deriving (Eq, Show) - -parseConnection :: String -> [Connection] -parseConnection = map (fn . map toLower) . parseList - where fn "close" = ConnectionClose - fn "keep-alive" = ConnectionKeepAlive - fn other = ConnectionOther other - -getConnection :: HasHeaders a => a -> [Connection] -getConnection = concatMap parseConnection . lookupHeaders HdrConnection - -data Expect - = ExpectContinue - deriving Show - --- parseExpect :: String -> Maybe Expect --- parseExpect s = --- case parseList s of --- ["100-continue"] -> Just ExpectContinue --- _ -> Nothing - - -getHost :: HasHeaders a => a -> Maybe (String, Maybe Int) -getHost x = lookupHeader HdrHost x >>= parseHost - -parseHost :: String -> Maybe (String, Maybe Int) -parseHost s = - case prt of - "" -> Just (host, Nothing) - ':':port -> readM port >>= \p -> Just (host, Just p) - _ -> Nothing - where (host,prt) = break (==':') s - diff --git a/src/Response.hs b/src/Response.hs deleted file mode 100644 --- a/src/Response.hs +++ /dev/null @@ -1,304 +0,0 @@ --- ----------------------------------------------------------------------------- --- Copyright 2002, Simon Marlow. --- Copyright 2006, Bjorn Bringert. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name of the copyright holder(s) nor the names of --- contributors may be used to endorse or promote products derived from --- this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ----------------------------------------------------------------------------- - -module Response where - -import Config -import Headers -import Parse -import Util - -import Control.Monad -import Control.Exception as Exception -import Data.List (genericLength) -import System.IO -import System.Time -import Text.Html - - ------------------------------------------------------------------------------ --- Responses - -data ResponseBody - = NoBody - | FileBody Integer{-size-} FilePath - | HereItIs String - -data Response - = Response { - respCode :: Int, - respDesc :: String, - respHeaders :: Headers, - respCoding :: [TransferCoding], -- either empty or terminated with - -- ChunkedTransferEncoding - -- (RFC2616, sec 3.6) - respBody :: ResponseBody, -- filename of body - respSendBody :: Bool -- actually send the body? - -- (False for HEAD requests) - } - - -instance Show Response where - showsPrec _ r - = showString (showResponseLine r) . showString crLf - . shows (respHeaders r) - -instance HasHeaders Response where - getHeaders = respHeaders - setHeaders resp hs = resp { respHeaders = hs} - -showResponseLine :: Response -> String -showResponseLine (Response s desc _ _ _ _) = show s ++ " " ++ desc - - -responseBodyLength :: ResponseBody -> Integer -responseBodyLength bdy = - case bdy of - NoBody -> 0 - HereItIs stuff -> genericLength stuff - FileBody sze _ -> sze - -hasBody :: ResponseBody -> Bool -hasBody NoBody = False -hasBody _ = True - -getFileName :: ResponseBody -> String -getFileName (NoBody) = "" -getFileName (FileBody _size filename) = filename -getFileName (HereItIs _) = "" - -sendBody :: Handle -> ResponseBody -> IO () -sendBody _ NoBody = return () -sendBody h (HereItIs stuff) = do hPutStr h stuff - hFlush h -sendBody h (FileBody _size filename) - = Exception.bracket - (openFile filename ReadMode) - (\hndle -> hClose hndle) - (\hndle -> squirt hndle h >> hFlush h) - - -statusLine :: Int -> String -> String -statusLine cde desc = httpVersion ++ ' ': show cde ++ ' ': desc - -httpVersion :: String -httpVersion = "HTTP/1.1" - - ------------------------------------------------------------------------------ --- Response Headers - -dateHeader :: IO Header -dateHeader = do - -- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC - clock_time <- getClockTime - let utc = toUTCTime clock_time - let time_str = formatTimeSensibly utc - return $ Header HdrDate time_str - -serverHeader :: Header -serverHeader = Header HdrServer (serverSoftware ++ '/':serverVersion) - - ------------------------------------------------------------------------------ --- Response codes - -contResponse :: Config -> Response -contResponse = error_resp 100 -switchingProtocolsResponse :: Config -> Response -switchingProtocolsResponse = error_resp 101 -okResponse :: t -> ResponseBody -> Headers -> Bool -> Response -okResponse = body_resp 200 -createdResponse :: Config -> Response -createdResponse = error_resp 201 -acceptedResponse :: Config -> Response -acceptedResponse = error_resp 202 -nonAuthoritiveInformationResponse :: Config - -> Response -nonAuthoritiveInformationResponse = error_resp 203 -noContentResponse :: Config -> Response -noContentResponse = error_resp 204 -resetContentResponse :: Config -> Response -resetContentResponse = error_resp 205 -partialContentResponse :: Config -> Response -partialContentResponse = error_resp 206 -multipleChoicesResponse :: Config -> Response -multipleChoicesResponse = error_resp 300 -movedPermanentlyResponse :: Config -> Response -movedPermanentlyResponse = error_resp 301 -foundResponse :: Config -> Response -foundResponse = error_resp 302 -seeOtherResponse :: Config -> Response -seeOtherResponse = error_resp 303 -notModifiedResponse :: Config -> Response -notModifiedResponse = error_resp 304 -useProxyResponse :: Config -> Response -useProxyResponse = error_resp 305 -temporaryRedirectResponse :: Config -> Response -temporaryRedirectResponse = error_resp 307 -badRequestResponse :: Config -> Response -badRequestResponse = error_resp 400 -unauthorizedResponse :: Config -> Response -unauthorizedResponse = error_resp 401 -paymentRequiredResponse :: Config -> Response -paymentRequiredResponse = error_resp 402 -forbiddenResponse :: Config -> Response -forbiddenResponse = error_resp 403 -notFoundResponse :: Config -> Response -notFoundResponse = error_resp 404 -methodNotAllowedResponse :: Config -> Response -methodNotAllowedResponse = error_resp 405 -notAcceptableResponse :: Config -> Response -notAcceptableResponse = error_resp 406 -proxyAuthenticationRequiredResponse :: Config - -> Response -proxyAuthenticationRequiredResponse = error_resp 407 -requestTimeOutResponse :: Config -> Response -requestTimeOutResponse = error_resp 408 -conflictResponse :: Config -> Response -conflictResponse = error_resp 409 -goneResponse :: Config -> Response -goneResponse = error_resp 410 -lengthRequiredResponse :: Config -> Response -lengthRequiredResponse = error_resp 411 -preconditionFailedResponse :: Config -> Response -preconditionFailedResponse = error_resp 412 -requestEntityTooLargeResponse :: Config -> Response -requestEntityTooLargeResponse = error_resp 413 -requestURITooLargeResponse :: Config -> Response -requestURITooLargeResponse = error_resp 414 -unsupportedMediaTypeResponse :: Config -> Response -unsupportedMediaTypeResponse = error_resp 415 -requestedRangeNotSatisfiableResponse :: Config - -> Response -requestedRangeNotSatisfiableResponse = error_resp 416 -expectationFailedResponse :: Config -> Response -expectationFailedResponse = error_resp 417 -internalServerErrorResponse :: Config -> Response -internalServerErrorResponse = error_resp 500 -notImplementedResponse :: Config -> Response -notImplementedResponse = error_resp 501 -badGatewayResponse :: Config -> Response -badGatewayResponse = error_resp 502 -serviceUnavailableResponse :: Config -> Response -serviceUnavailableResponse = error_resp 503 -gatewayTimeOutResponse :: Config -> Response -gatewayTimeOutResponse = error_resp 504 -versionNotSupportedResponse :: Config -> Response -versionNotSupportedResponse = error_resp 505 - -responseDescription :: Int -> String -responseDescription 100 = "Continue" -responseDescription 101 = "Switching Protocols" - -responseDescription 200 = "OK" -responseDescription 201 = "Created" -responseDescription 202 = "Accepted" -responseDescription 203 = "Non-Authoritative Information" -responseDescription 204 = "No Content" -responseDescription 205 = "Reset Content" -responseDescription 206 = "Partial Content" - -responseDescription 300 = "Multiple Choices" -responseDescription 301 = "Moved Permanently" -responseDescription 302 = "Found" -responseDescription 303 = "See Other" -responseDescription 304 = "Not Modified" -responseDescription 305 = "Use Proxy" -responseDescription 307 = "Temporary Redirect" - -responseDescription 400 = "Bad Request" -responseDescription 401 = "Unauthorized" -responseDescription 402 = "Payment Required" -responseDescription 403 = "Forbidden" -responseDescription 404 = "Not Found" -responseDescription 405 = "Method Not Allowed" -responseDescription 406 = "Not Acceptable" -responseDescription 407 = "Proxy Authentication Required" -responseDescription 408 = "Request Time-out" -responseDescription 409 = "Conflict" -responseDescription 410 = "Gone" -responseDescription 411 = "Length Required" -responseDescription 412 = "Precondition Failed" -responseDescription 413 = "Request Entity Too Large" -responseDescription 414 = "Request-URI Too Large" -responseDescription 415 = "Unsupported Media Type" -responseDescription 416 = "Requested range not satisfiable" -responseDescription 417 = "Expectation Failed" - -responseDescription 500 = "Internal Server Error" -responseDescription 501 = "Not Implemented" -responseDescription 502 = "Bad Gateway" -responseDescription 503 = "Service Unavailable" -responseDescription 504 = "Gateway Time-out" -responseDescription 505 = "HTTP Version not supported" -responseDescription _ = "Unknown response" - -error_resp :: Int -> Config -> Response -error_resp cde conf - = Response cde (responseDescription cde) hs [] - (generateErrorPage cde conf) True - where hs = mkHeaders [contentTypeHeader "text/html"] - -body_resp :: Int -> t -> ResponseBody -> Headers -> Bool -> Response -body_resp cde _conf bdy headers sendbody = - Response cde (responseDescription cde) headers [] bdy sendbody - ------------------------------------------------------------------------------ --- Error pages - --- We generate some html for the client to display on an error. - -generateErrorPage :: Int -> Config -> ResponseBody -generateErrorPage cde conf - = HereItIs (renderHtml (genErrorHtml cde conf)) - -genErrorHtml :: Int -> Config -> Html -genErrorHtml cde conf - = header << thetitle << response - +++ body << - (h1 << response - +++ hr - +++ serverSoftware +++ '/' +++ serverVersion - -- ToDo: use real hostname if we don't have a serverName - +++ case serverName conf of - "" -> noHtml - me -> " on " +++ me +++ br - +++ case serverAdmin conf of - "" -> noHtml - her -> "Server Admin: " +++ - hotlink ("mailto:"++her) [toHtml her] - ) - where - descr = responseDescription cde - response = show cde +++ ' ' +++ descr diff --git a/src/ServerRequest.hs b/src/ServerRequest.hs deleted file mode 100644 --- a/src/ServerRequest.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Copyright 2006, Bjorn Bringert. -module ServerRequest where - -import Request - -import Network.BSD (HostEntry) -import Network.Socket (HostAddress) - --- | All the server's information about a request -data ServerRequest = ServerRequest - { - clientRequest :: Request, - clientAddress :: HostAddress, - clientName :: Maybe HostEntry, - requestHostName :: HostEntry, - serverURIPath :: String, - serverFilename :: FilePath - } - deriving Show diff --git a/src/ServerState.hs b/src/ServerState.hs deleted file mode 100644 --- a/src/ServerState.hs +++ /dev/null @@ -1,111 +0,0 @@ --- Copyright 2006, Bjorn Bringert. -module ServerState where - -import Config -import AccessLogger -import ErrorLogger -import LogLevel -import MimeTypes -import Options -import Response -import ServerRequest -import Util - -import Control.Concurrent (myThreadId) -import Control.Monad -import Network.BSD (HostEntry) -import System.Time (TimeDiff) - --- --- * Module API --- - -data ModuleDesc = ModuleDesc - { - moduleName :: String, - moduleLoad :: IO Module - } - -emptyModuleDesc :: ModuleDesc -emptyModuleDesc = ModuleDesc - { - moduleName = "", - moduleLoad = return emptyModule - } - -data Module = Module - { - moduleLoadConfig :: ServerState -> IO (), - moduleTranslatePath :: ServerState -> String -> IO (Maybe FilePath), - moduleTweakRequest :: ServerState -> ServerRequest -> IO ServerRequest, - moduleHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response) - } - -emptyModule :: Module -emptyModule = Module { - moduleLoadConfig = \_ -> return (), - moduleTranslatePath = \_ _ -> return Nothing, - moduleTweakRequest = \_ r -> return r, - moduleHandleRequest = \_ _ -> return Nothing - } - -tweakFilename :: (ServerState -> FilePath -> IO FilePath) - -> ServerState -> ServerRequest -> IO ServerRequest -tweakFilename f conf req = - do filename' <- f conf (serverFilename req) - return $ req { serverFilename = filename' } - - --- --- * ServerState --- - -data ServerState = ServerState - { - serverOptions :: Options, - serverConfig :: Config, - serverHostName :: HostEntry, - serverPort :: Int, - serverMimeTypes :: MimeTypes, - serverErrorLogger :: ErrorLoggerHandle, - serverAccessLoggers :: [AccessLoggerHandle], - serverModules :: [Module] - } - --- * MIME types - -getMimeType :: ServerState -> FilePath -> String -getMimeType st filename = - maybe def show (mimeTypeOf (serverMimeTypes st) filename) - where def = defaultType (serverConfig st) - --- ** Logging - -debug :: ServerState -> String -> IO () -debug st s = do t <- myThreadId - logDebug st $ show t ++ ": " ++ s - -logError :: ServerState -> String -> IO () -logError st = logErrorMessage (serverErrorLogger st) LogError - -logInfo :: ServerState -> String -> IO () -logInfo st = logErrorMessage (serverErrorLogger st) LogInfo - -logDebug :: ServerState -> String -> IO () -logDebug st = logErrorMessage (serverErrorLogger st) LogDebug - -logAccess :: ServerState -> ServerRequest -> Response -> TimeDiff -> IO () -logAccess st req resp delay = - do msg <- mkAccessLogRequest req resp (serverHostName st) delay - mapM_ (\l -> logAccessLogRequest l msg) (serverAccessLoggers st) - --- ** Modules - -mapModules_ :: ServerState -> (Module -> IO ()) -> IO () -mapModules_ st f = mapM_ f (serverModules st) - -foldModules :: ServerState -> (Module -> a -> IO a) -> a -> IO a -foldModules st f x = foldM (flip f) x (serverModules st) - -tryModules :: ServerState -> (Module -> IO (Maybe a)) -> IO (Maybe a) -tryModules st f = firstJustM f (serverModules st) diff --git a/src/StaticModules.hs b/src/StaticModules.hs deleted file mode 100644 --- a/src/StaticModules.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE CPP #-} --- Copyright 2006, Bjorn Bringert. -module StaticModules (staticModules) where - -import ServerState (ModuleDesc) - - -import Module.Userdir -import Module.Index -import Module.CGI -#ifdef DYNHS -import Module.DynHS -#endif -import Module.File - -staticModules :: [ModuleDesc] -staticModules = - [ - Module.Userdir.desc, - Module.Index.desc, - Module.CGI.desc, -#ifdef DYNHS - Module.DynHS.desc, -#endif - Module.File.desc - ] diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -1,228 +0,0 @@ --- ----------------------------------------------------------------------------- --- 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