mohws 0.1 → 0.2
raw patch · 64 files changed
+4743/−3190 lines, 64 filesdep +HTTPdep +bytestringdep +data-accessordep −arraynew-component:exe:hws-dynnew-uploader
Dependencies added: HTTP, bytestring, data-accessor, explicit-exception, filepath, ghc, transformers, utility-ht
Dependencies removed: array
Files
- mohws.cabal +77/−19
- public_html/Pi.hs +5/−0
- public_html/html.cgi +16/−0
- public_html/text.cgi +6/−0
- src/AccessLogger.hs +0/−129
- src/Config.hs +0/−116
- src/ConfigParser.hs +0/−177
- src/ErrorLogger.hs +0/−82
- src/Headers.hs +0/−317
- src/LogLevel.hs +0/−32
- src/Logger.hs +0/−124
- src/Main.hs +6/−486
- src/MainDynamic.hs +69/−0
- src/MimeTypes.hs +0/−94
- src/Module/CGI.hs +0/−207
- src/Module/DynHS.hs +0/−79
- src/Module/DynHS/CGI.hs +0/−47
- src/Module/DynHS/GHCUtil.hs +0/−98
- src/Module/File.hs +0/−70
- src/Module/Index.hs +0/−40
- src/Module/Userdir.hs +0/−35
- src/Network/MoHWS/ByteString.hs +54/−0
- src/Network/MoHWS/Configuration.hs +172/−0
- src/Network/MoHWS/Configuration/Accessor.hs +122/−0
- src/Network/MoHWS/Configuration/Parser.hs +233/−0
- src/Network/MoHWS/HTTP/Header.hs +289/−0
- src/Network/MoHWS/HTTP/MimeType.hs +90/−0
- src/Network/MoHWS/HTTP/Request.hs +214/−0
- src/Network/MoHWS/HTTP/Response.hs +413/−0
- src/Network/MoHWS/HTTP/Version.hs +65/−0
- src/Network/MoHWS/Initialization.hs +9/−0
- src/Network/MoHWS/Initialization/Standard.hs +64/−0
- src/Network/MoHWS/Logger.hs +130/−0
- src/Network/MoHWS/Logger/Access.hs +156/−0
- src/Network/MoHWS/Logger/Error.hs +138/−0
- src/Network/MoHWS/Logger/Level.hs +37/−0
- src/Network/MoHWS/Module.hs +46/−0
- src/Network/MoHWS/Module/Description.hs +37/−0
- src/Network/MoHWS/ParserUtility.hs +85/−0
- src/Network/MoHWS/Part/AddSlash.hs +94/−0
- src/Network/MoHWS/Part/CGI.hs +302/−0
- src/Network/MoHWS/Part/DynHS.hs +103/−0
- src/Network/MoHWS/Part/DynHS/CGI.hs +48/−0
- src/Network/MoHWS/Part/DynHS/GHCUtil.hs +98/−0
- src/Network/MoHWS/Part/File.hs +117/−0
- src/Network/MoHWS/Part/Index.hs +91/−0
- src/Network/MoHWS/Part/Listing.hs +114/−0
- src/Network/MoHWS/Part/UserDirectory.hs +77/−0
- src/Network/MoHWS/Part/VirtualHost.hs +109/−0
- src/Network/MoHWS/Server.hs +555/−0
- src/Network/MoHWS/Server/Context.hs +57/−0
- src/Network/MoHWS/Server/Environment.hs +76/−0
- src/Network/MoHWS/Server/Options.hs +58/−0
- src/Network/MoHWS/Server/Request.hs +33/−0
- src/Network/MoHWS/Stream.hs +83/−0
- src/Network/MoHWS/Utility.hs +195/−0
- src/Options.hs +0/−58
- src/Parse.hs +0/−84
- src/Request.hs +0/−208
- src/Response.hs +0/−304
- src/ServerRequest.hs +0/−19
- src/ServerState.hs +0/−111
- src/StaticModules.hs +0/−26
- src/Util.hs +0/−228
mohws.cabal view
@@ -1,20 +1,23 @@ Name: mohws-Version: 0.1-Author: Simon Marlow, Bjorn Bringert+Version: 0.2+Author: Simon Marlow, Bjorn Bringert <bjorn@bringert.net> Copyright: Simon Marlow, Bjorn Bringert-Maintainer: Bjorn Bringert <bjorn@bringert.net>+Maintainer: Henning Thielemann <webserver@henning-thielemann.de> 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
+ public_html/Pi.hs view
@@ -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))
+ public_html/html.cgi view
@@ -0,0 +1,16 @@+#! /bin/bash+echo Content-Type: text/html+echo+echo '<html>'+echo '<head>'+echo '<title>Hello World</title>'+echo '</head>'+echo '<body>'+echo '<ul>'+echo '<li>Hello World</li>'+echo '<li>'`date`'</li>'+echo '<li>Query: '$QUERY_STRING'</li>'+echo '<li>Port: '$SERVER_PORT'</li>'+echo '</ul>'+echo '</body>'+echo '</html>'
+ public_html/text.cgi view
@@ -0,0 +1,6 @@+#! /bin/bash+echo Content-Type: text/plain+echo+echo Hello World+date+echo Query: $QUERY_STRING
− src/AccessLogger.hs
@@ -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
− src/Config.hs
@@ -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"
− src/ConfigParser.hs
@@ -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)-
− src/ErrorLogger.hs
@@ -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)
− src/Headers.hs
@@ -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)-
− src/LogLevel.hs
@@ -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 ]
− src/Logger.hs
@@ -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
src/Main.hs view
@@ -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)
+ src/MainDynamic.hs view
@@ -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)
− src/MimeTypes.hs
@@ -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
− src/Module/CGI.hs
@@ -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)
− src/Module/DynHS.hs
@@ -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))-
− src/Module/DynHS/CGI.hs
@@ -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"
− src/Module/DynHS/GHCUtil.hs
@@ -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
− src/Module/File.hs
@@ -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
− src/Module/Index.hs
@@ -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
− src/Module/Userdir.hs
@@ -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
+ src/Network/MoHWS/ByteString.hs view
@@ -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
+ src/Network/MoHWS/Configuration.hs view
@@ -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+ }
+ src/Network/MoHWS/Configuration/Accessor.hs view
@@ -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+
+ src/Network/MoHWS/Configuration/Parser.hs view
@@ -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
+ src/Network/MoHWS/HTTP/Header.hs view
@@ -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+-}
+ src/Network/MoHWS/HTTP/MimeType.hs view
@@ -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)
+ src/Network/MoHWS/HTTP/Request.hs view
@@ -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
+ src/Network/MoHWS/HTTP/Response.hs view
@@ -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 = "<generated>",+ size = Nothing,+ close = return (),+ content = str+ }++bodyWithSizeFromString :: (Stream.C body) => body -> Body body+bodyWithSizeFromString str =+ Body {+ source = "<generated>",+ 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]+ )
+ src/Network/MoHWS/HTTP/Version.hs view
@@ -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
+ src/Network/MoHWS/Initialization.hs view
@@ -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+ }
+ src/Network/MoHWS/Initialization/Standard.hs view
@@ -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")+ }
+ src/Network/MoHWS/Logger.hs view
@@ -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
+ src/Network/MoHWS/Logger/Access.hs view
@@ -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
+ src/Network/MoHWS/Logger/Error.hs view
@@ -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
+ src/Network/MoHWS/Logger/Level.hs view
@@ -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 ]
+ src/Network/MoHWS/Module.hs view
@@ -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 }
+ src/Network/MoHWS/Module/Description.hs view
@@ -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 = "<unnamed module>",+ 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)+ }
+ src/Network/MoHWS/ParserUtility.hs view
@@ -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)
+ src/Network/MoHWS/Part/AddSlash.hs view
@@ -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")
+ src/Network/MoHWS/Part/CGI.hs view
@@ -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
+ src/Network/MoHWS/Part/DynHS.hs view
@@ -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))+
+ src/Network/MoHWS/Part/DynHS/CGI.hs view
@@ -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"
+ src/Network/MoHWS/Part/DynHS/GHCUtil.hs view
@@ -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
+ src/Network/MoHWS/Part/File.hs view
@@ -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
+ src/Network/MoHWS/Part/Index.hs view
@@ -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
+ src/Network/MoHWS/Part/Listing.hs view
@@ -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
+ src/Network/MoHWS/Part/UserDirectory.hs view
@@ -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
+ src/Network/MoHWS/Part/VirtualHost.hs view
@@ -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)
+ src/Network/MoHWS/Server.hs view
@@ -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
+ src/Network/MoHWS/Server/Context.hs view
@@ -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)
+ src/Network/MoHWS/Server/Environment.hs view
@@ -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
+ src/Network/MoHWS/Server/Options.hs view
@@ -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 ("<server-root>/" ++ 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)
+ src/Network/MoHWS/Server/Request.hs view
@@ -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+ }
+ src/Network/MoHWS/Stream.hs view
@@ -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
+ src/Network/MoHWS/Utility.hs view
@@ -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
− src/Options.hs
@@ -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 ("<server-root>/" ++ defaultConfigFile)),- Option ['d'] ["server-root"] (ReqArg O_ServerRoot "directory")- ("default: " ++ show defaultServerRoot)- ]--usage :: String-usage = "usage: hws [option...]"--defaultConfigFile :: FilePath-defaultConfigFile = "conf/httpd.conf"--defaultServerRoot :: FilePath-defaultServerRoot = "."--serverRoot :: Options -> FilePath-serverRoot opts =- case [ s | O_ServerRoot s <- opts] of- [] -> defaultServerRoot- s -> last s--configPath :: Options -> FilePath-configPath args = inServerRoot args (configFile args)--configFile :: Options -> FilePath-configFile args = - case [ s | O_ConfigFile s <- args] of- [] -> defaultConfigFile- s -> last s--inServerRoot :: Options -> FilePath -> FilePath-inServerRoot opts f | "/" `isPrefixOf` f = f- | otherwise = serverRoot opts ++ '/':f---- returns error message or options-parseOptions :: [String] -> Either String Options-parseOptions args =- case getOpt Permute options args of- (flags, [], []) -> Right flags- (_, _, errs) -> Left (concat errs ++ "\n" - ++ usageInfo usage options)
− src/Parse.hs
@@ -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)
− src/Request.hs
@@ -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-
− src/Response.hs
@@ -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) = "<no file>"-getFileName (FileBody _size filename) = filename-getFileName (HereItIs _) = "<generated content>"--sendBody :: Handle -> ResponseBody -> IO ()-sendBody _ NoBody = return ()-sendBody h (HereItIs stuff) = do hPutStr h stuff- hFlush h-sendBody h (FileBody _size filename)- = Exception.bracket- (openFile filename ReadMode)- (\hndle -> hClose hndle)- (\hndle -> squirt hndle h >> hFlush h)---statusLine :: Int -> String -> String-statusLine cde desc = httpVersion ++ ' ': show cde ++ ' ': desc--httpVersion :: String-httpVersion = "HTTP/1.1"----------------------------------------------------------------------------------- Response Headers--dateHeader :: IO Header-dateHeader = do- -- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC- clock_time <- getClockTime- let utc = toUTCTime clock_time- let time_str = formatTimeSensibly utc- return $ Header HdrDate time_str--serverHeader :: Header-serverHeader = Header HdrServer (serverSoftware ++ '/':serverVersion)----------------------------------------------------------------------------------- Response codes--contResponse :: Config -> Response-contResponse = error_resp 100-switchingProtocolsResponse :: Config -> Response-switchingProtocolsResponse = error_resp 101-okResponse :: t -> ResponseBody -> Headers -> Bool -> Response-okResponse = body_resp 200-createdResponse :: Config -> Response-createdResponse = error_resp 201-acceptedResponse :: Config -> Response-acceptedResponse = error_resp 202-nonAuthoritiveInformationResponse :: Config- -> Response-nonAuthoritiveInformationResponse = error_resp 203-noContentResponse :: Config -> Response-noContentResponse = error_resp 204-resetContentResponse :: Config -> Response-resetContentResponse = error_resp 205-partialContentResponse :: Config -> Response-partialContentResponse = error_resp 206-multipleChoicesResponse :: Config -> Response-multipleChoicesResponse = error_resp 300-movedPermanentlyResponse :: Config -> Response-movedPermanentlyResponse = error_resp 301-foundResponse :: Config -> Response-foundResponse = error_resp 302-seeOtherResponse :: Config -> Response-seeOtherResponse = error_resp 303-notModifiedResponse :: Config -> Response-notModifiedResponse = error_resp 304-useProxyResponse :: Config -> Response-useProxyResponse = error_resp 305-temporaryRedirectResponse :: Config -> Response-temporaryRedirectResponse = error_resp 307-badRequestResponse :: Config -> Response-badRequestResponse = error_resp 400-unauthorizedResponse :: Config -> Response-unauthorizedResponse = error_resp 401-paymentRequiredResponse :: Config -> Response-paymentRequiredResponse = error_resp 402-forbiddenResponse :: Config -> Response-forbiddenResponse = error_resp 403-notFoundResponse :: Config -> Response-notFoundResponse = error_resp 404-methodNotAllowedResponse :: Config -> Response-methodNotAllowedResponse = error_resp 405-notAcceptableResponse :: Config -> Response-notAcceptableResponse = error_resp 406-proxyAuthenticationRequiredResponse :: Config- -> Response-proxyAuthenticationRequiredResponse = error_resp 407-requestTimeOutResponse :: Config -> Response-requestTimeOutResponse = error_resp 408-conflictResponse :: Config -> Response-conflictResponse = error_resp 409-goneResponse :: Config -> Response-goneResponse = error_resp 410-lengthRequiredResponse :: Config -> Response-lengthRequiredResponse = error_resp 411-preconditionFailedResponse :: Config -> Response-preconditionFailedResponse = error_resp 412-requestEntityTooLargeResponse :: Config -> Response-requestEntityTooLargeResponse = error_resp 413-requestURITooLargeResponse :: Config -> Response-requestURITooLargeResponse = error_resp 414-unsupportedMediaTypeResponse :: Config -> Response-unsupportedMediaTypeResponse = error_resp 415-requestedRangeNotSatisfiableResponse :: Config- -> Response-requestedRangeNotSatisfiableResponse = error_resp 416-expectationFailedResponse :: Config -> Response-expectationFailedResponse = error_resp 417-internalServerErrorResponse :: Config -> Response-internalServerErrorResponse = error_resp 500-notImplementedResponse :: Config -> Response-notImplementedResponse = error_resp 501-badGatewayResponse :: Config -> Response-badGatewayResponse = error_resp 502-serviceUnavailableResponse :: Config -> Response-serviceUnavailableResponse = error_resp 503-gatewayTimeOutResponse :: Config -> Response-gatewayTimeOutResponse = error_resp 504-versionNotSupportedResponse :: Config -> Response-versionNotSupportedResponse = error_resp 505--responseDescription :: Int -> String-responseDescription 100 = "Continue"-responseDescription 101 = "Switching Protocols"--responseDescription 200 = "OK"-responseDescription 201 = "Created"-responseDescription 202 = "Accepted"-responseDescription 203 = "Non-Authoritative Information"-responseDescription 204 = "No Content"-responseDescription 205 = "Reset Content"-responseDescription 206 = "Partial Content"--responseDescription 300 = "Multiple Choices"-responseDescription 301 = "Moved Permanently"-responseDescription 302 = "Found"-responseDescription 303 = "See Other"-responseDescription 304 = "Not Modified"-responseDescription 305 = "Use Proxy"-responseDescription 307 = "Temporary Redirect"--responseDescription 400 = "Bad Request"-responseDescription 401 = "Unauthorized"-responseDescription 402 = "Payment Required"-responseDescription 403 = "Forbidden"-responseDescription 404 = "Not Found"-responseDescription 405 = "Method Not Allowed"-responseDescription 406 = "Not Acceptable"-responseDescription 407 = "Proxy Authentication Required"-responseDescription 408 = "Request Time-out"-responseDescription 409 = "Conflict"-responseDescription 410 = "Gone"-responseDescription 411 = "Length Required"-responseDescription 412 = "Precondition Failed"-responseDescription 413 = "Request Entity Too Large"-responseDescription 414 = "Request-URI Too Large"-responseDescription 415 = "Unsupported Media Type"-responseDescription 416 = "Requested range not satisfiable"-responseDescription 417 = "Expectation Failed"--responseDescription 500 = "Internal Server Error"-responseDescription 501 = "Not Implemented"-responseDescription 502 = "Bad Gateway"-responseDescription 503 = "Service Unavailable"-responseDescription 504 = "Gateway Time-out"-responseDescription 505 = "HTTP Version not supported"-responseDescription _ = "Unknown response"--error_resp :: Int -> Config -> Response-error_resp cde conf- = Response cde (responseDescription cde) hs []- (generateErrorPage cde conf) True- where hs = mkHeaders [contentTypeHeader "text/html"]--body_resp :: Int -> t -> ResponseBody -> Headers -> Bool -> Response-body_resp cde _conf bdy headers sendbody =- Response cde (responseDescription cde) headers [] bdy sendbody---------------------------------------------------------------------------------- Error pages---- We generate some html for the client to display on an error.--generateErrorPage :: Int -> Config -> ResponseBody-generateErrorPage cde conf- = HereItIs (renderHtml (genErrorHtml cde conf))--genErrorHtml :: Int -> Config -> Html-genErrorHtml cde conf- = header << thetitle << response- +++ body <<- (h1 << response- +++ hr- +++ serverSoftware +++ '/' +++ serverVersion- -- ToDo: use real hostname if we don't have a serverName- +++ case serverName conf of- "" -> noHtml- me -> " on " +++ me +++ br- +++ case serverAdmin conf of- "" -> noHtml- her -> "Server Admin: " +++- hotlink ("mailto:"++her) [toHtml her]- )- where- descr = responseDescription cde- response = show cde +++ ' ' +++ descr
− src/ServerRequest.hs
@@ -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
− src/ServerState.hs
@@ -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 = "<unnamed module>",- moduleLoad = return emptyModule- }--data Module = Module - {- moduleLoadConfig :: ServerState -> IO (),- moduleTranslatePath :: ServerState -> String -> IO (Maybe FilePath),- moduleTweakRequest :: ServerState -> ServerRequest -> IO ServerRequest,- moduleHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response)- }--emptyModule :: Module-emptyModule = Module {- moduleLoadConfig = \_ -> return (),- moduleTranslatePath = \_ _ -> return Nothing,- moduleTweakRequest = \_ r -> return r,- moduleHandleRequest = \_ _ -> return Nothing- }--tweakFilename :: (ServerState -> FilePath -> IO FilePath) - -> ServerState -> ServerRequest -> IO ServerRequest-tweakFilename f conf req = - do filename' <- f conf (serverFilename req)- return $ req { serverFilename = filename' }-------- * ServerState -----data ServerState = ServerState- {- serverOptions :: Options,- serverConfig :: Config,- serverHostName :: HostEntry,- serverPort :: Int,- serverMimeTypes :: MimeTypes,- serverErrorLogger :: ErrorLoggerHandle,- serverAccessLoggers :: [AccessLoggerHandle],- serverModules :: [Module]- }---- * MIME types--getMimeType :: ServerState -> FilePath -> String-getMimeType st filename = - maybe def show (mimeTypeOf (serverMimeTypes st) filename)- where def = defaultType (serverConfig st)---- ** Logging--debug :: ServerState -> String -> IO ()-debug st s = do t <- myThreadId- logDebug st $ show t ++ ": " ++ s--logError :: ServerState -> String -> IO ()-logError st = logErrorMessage (serverErrorLogger st) LogError--logInfo :: ServerState -> String -> IO ()-logInfo st = logErrorMessage (serverErrorLogger st) LogInfo--logDebug :: ServerState -> String -> IO ()-logDebug st = logErrorMessage (serverErrorLogger st) LogDebug--logAccess :: ServerState -> ServerRequest -> Response -> TimeDiff -> IO ()-logAccess st req resp delay = - do msg <- mkAccessLogRequest req resp (serverHostName st) delay- mapM_ (\l -> logAccessLogRequest l msg) (serverAccessLoggers st)---- ** Modules--mapModules_ :: ServerState -> (Module -> IO ()) -> IO ()-mapModules_ st f = mapM_ f (serverModules st)--foldModules :: ServerState -> (Module -> a -> IO a) -> a -> IO a-foldModules st f x = foldM (flip f) x (serverModules st)--tryModules :: ServerState -> (Module -> IO (Maybe a)) -> IO (Maybe a)-tryModules st f = firstJustM f (serverModules st)
− src/StaticModules.hs
@@ -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- ]
− src/Util.hs
@@ -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