diff --git a/conf/httpd.conf b/conf/httpd.conf new file mode 100644 --- /dev/null +++ b/conf/httpd.conf @@ -0,0 +1,62 @@ +# ----------------------------------------------------------------------------- +# +# Example Config File +# +# (c) Simon Marlow 1999-2000 +# + +# ----------------------------------------------------------------------------- +# Server config + +User "nobody" # not implemented +Group "nogroup" # not implemented + +Timeout 300 +KeepAliveTimeout 15 +MaxClients 150 # not implemented + +Port 80 +# Listen 3000 # not implemented +# Listen 12.13.14.15:80 + +ServerAdmin "admin@example.com" + +ServerName "www.example.com" +ServerAlias "localhost" + +UseCanonicalName On + +DocumentRoot "/var/www" + +UserDir "public_html" + +DirectoryIndex "index.html" +# DirectoryIndex index.html index.shtml index.cgi index.htm Default.htm + +AccessFileName ".htaccess" # not implemented + +TypesConfig "/etc/mime.types" +DefaultType "text/plain" + +HostnameLookups Off + +# ----------------------------------------------------------------------------- +# Log files + +ErrorLog "log/error.log" +LogLevel 1 # not implemented + +AccessLogFile "log/access.log" +AccessLogFormat "%h %l %u %t \"%r\" %s %b \"%{Referer}i\" \"%{User-Agent}i\"" + +# ----------------------------------------------------------------------------- +# Language support + +AddLanguage "en" ".en" # not implemented +AddLanguage "fr" ".fr" # not implemented +AddLanguage "de" ".de" # not implemented +AddLanguage "da" ".da" # not implemented +AddLanguage "el" ".el" # not implemented +AddLanguage "it" ".it" # not implemented + +LanguagePriority "en" "fr" "de" # not implemented diff --git a/hws.cabal b/hws.cabal --- a/hws.cabal +++ b/hws.cabal @@ -1,5 +1,5 @@ name: hws -version: 1.1 +version: 1.1.0.1 license: BSD3 license-file: LICENSE author: Simon Marlow @@ -19,6 +19,8 @@ build-type: Simple cabal-version: >= 1.6 +extra-source-files: + conf/httpd.conf Executable hws build-depends: base >= 4.2 && < 4.4, @@ -37,3 +39,19 @@ main-is: Main.hs hs-source-dirs: src extensions: CPP + + other-modules: + AccessLogger + Config + ConfigParser + Dir + ErrorLogger + MimeTypes + ParseError + Parser + ParseToken + Request + Response + StdTokenDef + TokenDef + Util diff --git a/src/AccessLogger.hs b/src/AccessLogger.hs new file mode 100644 --- /dev/null +++ b/src/AccessLogger.hs @@ -0,0 +1,235 @@ +-- ----------------------------------------------------------------------------- +-- 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 AccessLogger ( + startAccessLogger, + stopAccessLogger, + logAccess + ) where + +import ErrorLogger +import Request +import Response +import Config +import Util + +import IO +import Char (toLower) +import Foreign +import Time +import System.Time +import Network.Socket +import Network.BSD +import Control.Exception +import Control.Concurrent + +----------------------------------------------------------------------------- +-- Access Logging + +-- logging is done by a separate thread, so it doesn't hold anything else up. + +data LogRequest = + LogReq { + log_ipaddr :: HostAddress, -- %a + log_logname :: String, -- %l + log_request :: Request, -- %r etc. + log_response :: Response, -- + log_time :: ClockTime, -- %{format}t + log_delay :: TimeDiff, -- %T + log_user :: String, -- %u + log_server :: HostEntry -- %v + } + +logAccess :: Request -> Response -> HostAddress -> TimeDiff -> IO () +logAccess req resp haddr delay + = do + time <- getClockTime + + -- ToDo: for servers serving multiple virtual domains, this + -- servername should be dynamic. + server <- readMVar local_hostent + + writeChan access_log_chan + LogReq { + log_ipaddr = haddr, + log_logname = "", -- ToDo + log_request = req, + log_response = resp, + log_time = time, + log_delay = delay, + log_user = "", -- ToDo + log_server = server + } + where + +access_log_chan :: Chan LogRequest +access_log_chan = unsafePerformIO (newChan) + +access_log_pid :: MVar ThreadId +access_log_pid = unsafePerformIO (newEmptyMVar) + +startAccessLogger :: Config -> IO () +startAccessLogger conf = do + logError ("access logger started on '" ++ accessLogFile conf ++ "'") + t <- forkIO (Control.Exception.catch (run_access_logger conf) (error_handler conf)) + putMVar access_log_pid t + +-- ToDo: shouldn't really kill the access logger with a signal, it might +-- be partway through servicing a log request. +stopAccessLogger :: IO () +stopAccessLogger = do + t <- takeMVar access_log_pid + throwTo t (ErrorCall "**stop**") + +error_handler conf (ErrorCall "**stop**") = + logError ("access logger stopped") +error_handler conf exception = do + logError ("access logger died: " ++ show exception) + Control.Exception.catch (run_access_logger conf) (error_handler conf) + +run_access_logger conf = + Control.Exception.bracket + (openFile (accessLogFile conf) AppendMode) + (\hdl -> hClose hdl) + (\hdl -> doLogRequests conf hdl) + +doLogRequests conf hdl = do + req <- readChan access_log_chan + ip_addr <- inet_ntoa (log_ipaddr req) + -- look up the hostname if hostnameLookups is on + host <- if hostnameLookups conf + then do Control.Exception.catch + (do ent <- getHostByAddr AF_INET (log_ipaddr req) + return (Just ent) + ) + (\e -> let _ = e :: IOError in return Nothing) + else return Nothing + let line = mkLogLine req ip_addr host (accessLogFormat conf) + hPutStrLn hdl line + hFlush hdl + doLogRequests conf hdl + +-- ToDo: could probably make this a lot faster by pre-parsing the log +-- specification. + +mkLogLine + :: LogRequest -- info to log + -> String -- IP addr if we need it + -> Maybe HostEntry -- hostname + -> String -- log format + -> String + +mkLogLine _info _ip_addr _host "" = "" +mkLogLine info ip_addr host ('%':'{':rest) + = expand info ip_addr host (Just str) c ++ mkLogLine info ip_addr host rest1 + where (str, '}':c:rest1) = span (/= '}') rest +mkLogLine info ip_addr host ('%':c:rest) + = expand info ip_addr host Nothing c ++ mkLogLine info ip_addr host rest +mkLogLine info ip_addr host (c:rest) = c : mkLogLine info ip_addr host rest + + +expand info ip_addr host arg c = + case c of + 'b' -> show (contentLength resp_body) + 'f' -> getFileName resp_body + + -- %h is the hostname if hostnameLookups is on, otherwise the + -- IP address. + 'h' -> case host of + Just ent -> hostName ent + Nothing -> ip_addr + 'a' -> ip_addr + 'l' -> log_logname info + 'r' -> show (log_request info) + -- ToDo: 'p' -> canonical port number of server + 's' -> show resp_code + 't' -> formatTimeSensibly (toUTCTime (log_time info)) + 'T' -> timeDiffToString (log_delay info) + 'v' -> hostName (log_server info) + 'u' -> log_user info + + 'i' -> getReqHeader arg (reqHeaders (log_request info)) + -- 'o' -> getRespHeader arg resp_headers + + -- ToDo: other stuff + _ -> ['%',c] + where + Response { + respCode = resp_code, + respHeaders = resp_headers, + respCoding = resp_coding, + respBody = resp_body, + respSendBody = resp_send_body + } = log_response info + +getReqHeader Nothing _hdrs = "" +getReqHeader (Just hdr) hdrs = concat ( + case map toLower hdr of + -- missing: + -- Connection [Connection] + -- Date String + -- Pragma String + -- Trailer String + -- TransferEncoding String + -- Upgrade String + -- Via String + -- Warning String + "accept" -> [ s | Accept s <- hdrs ] + "accept-charset" -> [ s | AcceptCharset s <- hdrs ] + "accept-encoding" -> [ s | AcceptEncoding s <- hdrs ] + "accept-language" -> [ s | AcceptLanguage s <- hdrs ] + "authorization" -> [ s | Authorization s <- hdrs ] + "cachecontrol" -> [ s | CacheControl s <- hdrs ] + -- Expect Expect + "from" -> [ s | From s <- hdrs ] + -- Host String{-hostname-} (Maybe Int){-port-} + "if-match" -> [ s | IfMatch s <- hdrs ] + "if-modified-since" -> [ s | IfModifiedSince s <- hdrs ] + "if-none-match" -> [ s | IfNoneMatch s <- hdrs ] + "if-range" -> [ s | IfRange s <- hdrs ] + "if-unmodified-since" -> [ s | IfUnmodifiedSince s <- hdrs ] + "max-forwards" -> [ s | MaxForwards s <- hdrs ] + "proxy-authorization" -> [ s | ProxyAuthorization s <- hdrs ] + "range" -> [ s | Range s <- hdrs ] + "referer" -> [ s | Referer s <- hdrs ] + "te" -> [ s | TE s <- hdrs ] + "user-agent" -> [ s | UserAgent s <- hdrs ] + _ -> [] + ) + +----------------------------------------------------------------------------- +-- older GHC compat + +#if __GLASGOW_HASKELL__ < 409 +catchJust = Control.Exception.catchIO +ioErrors = justIoErrors +#endif diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,127 @@ +-- ----------------------------------------------------------------------------- +-- 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 Foreign +import Network.BSD +import Control.Concurrent + +----------------------------------------------------------------------------- +-- Config info + +data Config = Config { + user :: String, + group :: String, + + port :: Int, + listen :: [Int], -- Todo: [(String,Int)], + -- eg. listen www.haskell.org:80 + + 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], + + accessLogFile :: String, + accessLogFormat :: String, + + errorLogFile :: String, + logLevel :: Int + } +#ifdef DEBUG + deriving Show +#endif + +defaultConfig :: Config +defaultConfig = Config{ + user = "nobody", + group = "nobody", + + port = 80, + listen = [], + + requestTimeout = 300, + keepAliveTimeout = 15, + maxClients = 150, + + serverAdmin = "", + serverName = "", + serverAlias = [], + useCanonicalName = False, + hostnameLookups = False, + + documentRoot = "/usr/local/www/data", + userDir = "", + directoryIndex = "index.html", + accessFileName = ".htaccess", + indexes = False, + followSymLinks = False, + + typesConfig = "/etc/mime.types", + defaultType = "text/plain", + + addLanguage = [], + languagePriority = [], + + accessLogFile = "http-access.log", + accessLogFormat = "%h %l %u %t \"%r\" %s %b \"%{Referer}i\" \"%{User-Agent}i\"", + + errorLogFile = "httpd-error.log", + logLevel = 1 + } + +-- not user-definable... +serverSoftware = "HWS" +serverVersion = "0.1" + +-- Local hostname. We'll update this on a SIGHUP, so make it an MVar. +local_hostent :: MVar HostEntry +local_hostent = unsafePerformIO newEmptyMVar diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs new file mode 100644 --- /dev/null +++ b/src/ConfigParser.hs @@ -0,0 +1,110 @@ +-- ----------------------------------------------------------------------------- +-- 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 where + +import Parser +import ParseToken +import Config + +type ConfigBuilder = Config -> Config + +parseConfig :: String -> IO (Either ParseError ConfigBuilder) +parseConfig fname + = parseFromFile configParser fname + +configParser :: Parser ConfigBuilder +configParser = do + whiteSpace + cs <- many configLine + eof + return (foldr (.) id cs) + +configLine :: Parser ConfigBuilder +configLine + = do (reserved "user" >> p_user) + <|> (reserved "group" >> p_group) + <|> (reserved "timeout" >> p_timeout) + <|> (reserved "keepalivetimeout" >> p_keepAliveTimeout) + <|> (reserved "maxclients" >> p_maxClients) + <|> (reserved "port" >> p_port) + <|> (reserved "serveradmin" >> p_serverAdmin) + <|> (reserved "servername" >> p_serverName) + <|> (reserved "serveralias" >> p_serverAlias) + <|> (reserved "usecanonicalname" >> p_useCanonicalName) + <|> (reserved "documentroot" >> p_documentRoot) + <|> (reserved "userdir" >> p_userDir) + <|> (reserved "directoryindex" >> p_directoryIndex) + <|> (reserved "accessfilename" >> p_accessFileName) + <|> (reserved "typesconfig" >> p_typesConfig) + <|> (reserved "defaulttype" >> p_defaultType) + <|> (reserved "hostnamelookups" >> p_hostnameLookups) + <|> (reserved "errorlog" >> p_errorLog) + <|> (reserved "loglevel" >> p_logLevel) + <|> (reserved "accesslogfile" >> p_accessLogFile) + <|> (reserved "accesslogformat" >> p_accessLogFormat) + <|> (reserved "listen" >> p_listen) + <|> (reserved "addlanguage" >> p_addlanguage) + <|> (reserved "languagepriority" >> p_languagepriority) + +p_user = do str <- stringLiteral; return (\c -> c{user = str}) +p_group = do str <- stringLiteral; return (\c -> c{group = str}) +p_timeout = do i <- int; return (\c -> c{requestTimeout = i}) +p_keepAliveTimeout = do i <- int; return (\c -> c{keepAliveTimeout = i}) +p_maxClients = do i <- int; return (\c -> c{maxClients = i}) +p_port = do i <- int; return (\c -> c{port = i}) +p_serverAdmin = do str <- stringLiteral; return (\c -> c{serverAdmin = str}) +p_serverName = do str <- stringLiteral; return (\c -> c{serverName = str}) +p_serverAlias = do str <- stringLiteral + return (\c -> c{serverAlias = str : serverAlias c}) +p_useCanonicalName = do b <- bool; return (\c -> c{useCanonicalName = b}) +p_documentRoot = do str <- stringLiteral; return (\c -> c{documentRoot = str}) +p_userDir = do str <- stringLiteral; return (\c -> c{userDir = str}) +p_directoryIndex = do str <- stringLiteral; return (\c -> c{directoryIndex = str}) +p_accessFileName = do str <- stringLiteral; return (\c -> c{accessFileName = str}) +p_typesConfig = do str <- stringLiteral; return (\c -> c{typesConfig = str}) +p_defaultType = do str <- stringLiteral; return (\c -> c{defaultType = str}) +p_hostnameLookups = do b <- bool; return (\c -> c{hostnameLookups = b}) +p_errorLog = do str <- stringLiteral; return (\c -> c{errorLogFile = str}) +p_logLevel = do i <- int; return (\c -> c{logLevel = i}) +p_accessLogFile = do str <- stringLiteral; return (\c -> c{accessLogFile = str}) +p_accessLogFormat = do str <- stringLiteral; return (\c -> c{accessLogFormat = str}) +p_listen = do i <- int; return (\c -> c{listen = i : listen c}) +p_addlanguage = do lang <- stringLiteral; ext <- stringLiteral; return (\c -> c{addLanguage = (lang,ext) : addLanguage c}) +p_languagepriority = do langs <- many stringLiteral; return (\c -> c{languagePriority = langs}) + +bool = do { reserved "On"; return True } + <|> do { reserved "Off"; return False } + +int :: Parser Int +int = do i <- integer; return (fromInteger i) + diff --git a/src/Dir.hs b/src/Dir.hs new file mode 100644 --- /dev/null +++ b/src/Dir.hs @@ -0,0 +1,31 @@ +module Dir (createDirListing) where + +import System.Directory +import Response +import Config + +-- XXX is_head? content_type? last_modified? +-- XXX move elsewhere! +-- perhaps it would be best to return a ResponseBody here and +-- let the upper layers handle the rest? +createDirListing :: String -> String -> IO (ResponseBody,String) +createDirListing urlpath dir = do + fs <- getDirectoryContents dir + let l = htmlFiles [f | f <- fs, (head f) /= '.'] + title = "Directory " ++ urlpath -- XXX html quoted! + parent = "Parent Directory\n" + s = sec title (parent ++ l) + p = page title s + return (HereItIs p, contentTypeHeader "text/html") + +-- XXX this should probably be elsewhere +htmlFiles fs = unlines ([""]) where + hs = map htmlFile fs + htmlFile f = "
  • " ++ f' ++ "
    • " where + f' = f -- XXX html quoted + +page title body = "\n" ++ title ++ "\n\n" ++ body ++ "\n\n" + +sec title body = "

    " ++ title ++ "

    \n" ++ body + + diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs new file mode 100644 --- /dev/null +++ b/src/ErrorLogger.hs @@ -0,0 +1,110 @@ +-- ----------------------------------------------------------------------------- +-- 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 ErrorLogger ( + startErrorLogger, + stopErrorLogger, + logError, + catchAndLogError, + showIOError + ) where + +import Config +import Util + +import Time +import IO +import Foreign +import Control.Concurrent +import Control.Exception + +import GHC.IO.Exception (IOException(..)) + +----------------------------------------------------------------------------- +-- Error Logging + +logError :: String -> IO () +logError err + = writeChan error_log_chan err + +error_log_chan :: Chan String +error_log_chan = unsafePerformIO (newChan) + +error_log_pid :: MVar ThreadId +error_log_pid = unsafePerformIO (newEmptyMVar) + +startErrorLogger :: Config -> IO () +startErrorLogger conf = do + logError ("error logger started (level " ++ show (logLevel conf) ++ + ") on '" ++ errorLogFile conf ++ "'") + t <- forkIO (Control.Exception.catch (run_error_logger conf) (error_handler conf)) + putMVar error_log_pid t + +stopErrorLogger :: IO () +stopErrorLogger = do + t <- takeMVar error_log_pid + throwTo t (ErrorCall "**stop**") + +error_handler conf (ErrorCall "**stop**") = + logError ("error logger stopped") +error_handler conf exception = do + logError ("error logger died: " ++ show exception) + Control.Exception.catch (run_error_logger conf) (error_handler conf) + +run_error_logger conf = do + Control.Exception.bracket + (openFile (errorLogFile conf) AppendMode) + (\hdl -> hClose hdl) + (\hdl -> doErrLogRequests hdl) + +doErrLogRequests hdl = do + str <- readChan error_log_chan + clock_time <- getClockTime + let time_str = formatTimeSensibly (toUTCTime clock_time) + hPutStr hdl time_str + hPutStrLn hdl (" " ++ str) + hFlush hdl + doErrLogRequests hdl + +catchAndLogError :: Exception e => String -> IO a -> (e -> IO a) -> IO a +catchAndLogError str io handler + = Control.Exception.catch io (\e -> logError (str ++ show e) >> handler e) + +showIOError :: IOException -> String +showIOError (IOError _hdl iot loc s _errno filepath) + = ( showString loc + . showString ": " + . shows iot + . showString " (" + . showString s + . showChar ')' + ) "" diff --git a/src/MimeTypes.hs b/src/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/src/MimeTypes.hs @@ -0,0 +1,85 @@ +-- ----------------------------------------------------------------------------- +-- 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 MimeTypes ( + MimeType(..), + initMimeTypes, -- :: IO () + mimeTypeOf, -- :: String -> MimeType + ) where + +import Data.Map hiding(map, null) +import IO +import Foreign +import Data.IORef +import Text.Regex + +data MimeType = MimeType String String +instance Show MimeType where + showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2) + +mime_types_ref :: IORef (Map String MimeType) +mime_types_ref = unsafePerformIO (newIORef (error "no mime types")) + +mimeTypeOf :: String -> Maybe MimeType +mimeTypeOf filename = unsafePerformIO (do + mime_types <- readIORef mime_types_ref + let ext = extension filename + if null ext + then return Nothing + else return (Data.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 :: String -> IO () +initMimeTypes mime_types_file = do + h <- openFile mime_types_file ReadMode + stuff <- hGetContents h + let mime_types = fromList (parseMimeTypes stuff) + writeIORef mime_types_ref mime_types + +parseMimeTypes file = + [ (ext,val) + | Just (val,exts) <- map (parseMimeLine . takeWhile (/= '#')) (lines file) + , ext <- exts + ] + +mimeRegex = mkRegex "^([^/]+)/([^ \t]+)[ \t]+(.*)$" + +parseMimeLine l = + case matchRegex mimeRegex l of + Just (part1:part2:extns:_) -> Just (MimeType part1 part2, words extns) + _ -> Nothing diff --git a/src/ParseError.hs b/src/ParseError.hs new file mode 100644 --- /dev/null +++ b/src/ParseError.hs @@ -0,0 +1,200 @@ +----------------------------------------------------------- +-- Daan Leijen (c) 1999, daan@cs.uu.nl +-- +-- $version: 23 Feb 2000, release version 0.2$ +----------------------------------------------------------- +module ParseError ( SourceName, Line, Column + , SourcePos, sourceLine, sourceColumn, sourceName + , newPos, initialPos, updatePos, updatePosString + + , Message(SysUnExpect,UnExpect,Expect,Message) + , messageString, messageCompare, messageEq + + , ParseError, errorPos, errorMessages, errorIsUnknown + , showErrorMessages + + , newErrorMessage, newErrorUnknown + , addErrorMessage, setErrorPos, setErrorMessage + , mergeError + ) + where + + +import List (nub,sortBy) + +----------------------------------------------------------- +-- Source Positions +----------------------------------------------------------- +type SourceName = String +type Line = Int +type Column = Int + +data SourcePos = SourcePos SourceName !Line !Column + deriving (Eq,Ord) + + +newPos :: SourceName -> Line -> Column -> SourcePos +newPos sourceName line column + = SourcePos sourceName line column + +initialPos sourceName + = newPos sourceName 1 1 + +sourceName (SourcePos name line column) = name +sourceLine (SourcePos name line column) = line +sourceColumn (SourcePos name line column) = column + + +updatePosString :: SourcePos -> String -> SourcePos +updatePosString pos string + = forcePos (foldl updatePos pos string) + +updatePos :: SourcePos -> Char -> SourcePos +updatePos pos@(SourcePos name line column) c + = forcePos $ + case c of + '\n' -> SourcePos name (line+1) 1 + '\r' -> pos + '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8)) + _ -> SourcePos name line (column + 1) + + +forcePos :: SourcePos -> SourcePos +forcePos pos@(SourcePos name line column) + = seq line (seq column (pos)) + + +instance Show SourcePos where + show (SourcePos name line column) + | null name = showLineColumn + | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn + where + showLineColumn = "(line " ++ show line ++ + ", column " ++ show column ++ + ")" + + +----------------------------------------------------------- +-- Messages +----------------------------------------------------------- +data Message = SysUnExpect !String --library generated unexpect + | UnExpect !String --unexpected something + | Expect !String --expecting something + | Message !String --raw message + +messageToEnum msg + = case msg of SysUnExpect _ -> 0 + UnExpect _ -> 1 + Expect _ -> 2 + Message _ -> 3 + _ -> error "ParseError.messageToEnum: no match" + +messageCompare msg1 msg2 + = compare (messageToEnum msg1) (messageToEnum msg2) + +messageString msg + = case msg of SysUnExpect s -> s + UnExpect s -> s + Expect s -> s + Message s -> s + _ -> error "ParseError.messageToEnum: no match" + +messageEq msg1 msg2 + = (messageCompare msg1 msg2 == EQ) + + +----------------------------------------------------------- +-- Parse Errors +----------------------------------------------------------- +data ParseError = ParseError !SourcePos [Message] + +errorPos :: ParseError -> SourcePos +errorPos (ParseError pos msgs) + = pos + +errorMessages :: ParseError -> [Message] +errorMessages (ParseError pos msgs) + = sortBy messageCompare msgs + +errorIsUnknown :: ParseError -> Bool +errorIsUnknown (ParseError pos msgs) + = null msgs + + +----------------------------------------------------------- +-- Create parse errors +----------------------------------------------------------- +newErrorUnknown pos + = ParseError pos [] + +newErrorMessage msg pos + = ParseError pos [msg] + +addErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg:msgs) + +setErrorPos pos (ParseError _ msgs) + = ParseError pos msgs + +setErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg:filter (not . messageEq msg) msgs) + + +mergeError :: ParseError -> ParseError -> ParseError +mergeError (ParseError _ msgs1) (ParseError pos msgs2) + = ParseError pos (msgs1 ++ msgs2) + + + +----------------------------------------------------------- +-- Show Parse Errors +----------------------------------------------------------- +instance Show ParseError where + show err + = show (errorPos err) ++ ":" ++ + showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" + (errorMessages err) + + +-- Language independent show function +showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs + | null msgs = msgUnknown + | otherwise = concat $ map ("\n"++) $ clean $ + [showSysUnExpect,showUnExpect,showExpect,showMessages] + where + (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs + (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1 + (expect,messages) = span (messageEq (Expect "")) msgs2 + + showExpect = showMany msgExpecting expect + showUnExpect = showMany msgUnExpected unExpect + showSysUnExpect | not (null unExpect) || + null sysUnExpect = "" + | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput + | otherwise = msgUnExpected ++ " " ++ firstMsg + where + firstMsg = messageString (head sysUnExpect) + + showMessages = showMany "" messages + + + --helpers + showMany pre msgs = case (clean (map messageString msgs)) of + [] -> "" + ms | null pre -> commasOr ms + | otherwise -> pre ++ " " ++ commasOr ms + + commasOr [] = "" + commasOr [m] = m + commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms + + commaSep = seperate ", " . clean + semiSep = seperate "; " . clean + + seperate sep [] = "" + seperate sep [m] = m + seperate sep (m:ms) = m ++ sep ++ seperate sep ms + + clean = nub . filter (not.null) + diff --git a/src/ParseToken.hs b/src/ParseToken.hs new file mode 100644 --- /dev/null +++ b/src/ParseToken.hs @@ -0,0 +1,371 @@ +----------------------------------------------------------- +-- Daan Leijen (c) 1999, daan@cs.uu.nl +-- +-- $version: 23 Feb 2000, release version 0.2$ +----------------------------------------------------------- +module ParseToken( identifier, reserved + , operator, reservedOp + + , charLiteral, stringLiteral + , natural, integer, float, naturalOrFloat + , decimal, hexadecimal, octal + + , symbol, lexeme, whiteSpace + + , parens, braces, brackets, squares + , semi, comma, colon, dot + , semiSep, semiSep1 + , commaSep, commaSep1 + ) where + +import Char (isSpace,digitToInt,isAlpha,toLower,toUpper) +import List (nub,sort) +import Parser +import StdTokenDef (TokenDef(..)) +import TokenDef (tokenDef) + + +----------------------------------------------------------- +-- Bracketing +----------------------------------------------------------- +parens p = between (symbol "(") (symbol ")") p +braces p = between (symbol "{") (symbol "}") p +brackets p = between (symbol "<") (symbol ">") p +squares p = between (symbol "[") (symbol "]") p + +semi = symbol ";" +comma = symbol "," +dot = symbol "." +colon = symbol ":" + +commaSep p = sepBy p comma +semiSep p = sepBy p semi + +commaSep1 p = sepBy1 p comma +semiSep1 p = sepBy1 p semi + + +----------------------------------------------------------- +-- Chars & Strings +----------------------------------------------------------- +charLiteral :: Parser Char +charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + +characterChar = charLetter <|> charEscape + "literal character" + +charEscape = do{ char '\\'; escapeCode } +charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + +stringLiteral :: Parser String +stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + +stringChar :: Parser (Maybe Char) +stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + +stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + +stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + +escapeEmpty = char '&' +escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + +-- escape codes +escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + +charControl :: Parser Char +charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + +charNum :: Parser Char +charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + +charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + +charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + +-- escape code tables +escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") +asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + +ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] +ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + +ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] +ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + +----------------------------------------------------------- +-- Numbers +----------------------------------------------------------- +naturalOrFloat :: Parser (Either Integer Double) +naturalOrFloat = lexeme (natFloat) "number" + +float = lexeme floating "float" +integer = lexeme int "integer" +natural = lexeme nat "natural" + + +-- floats +floating = do{ n <- decimal + ; fractExponent n + } + + +natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + +zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> return (Left 0) + +decimalFloat = do{ n <- decimal + ; option (Left n) + (do{ f <- fractExponent n; return (Right f)}) + } + + +fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + +fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + +exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + +-- integers and naturals +int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + +sign :: Parser (Integer -> Integer) +sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + +nat = zeroNumber <|> decimal + +zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + +decimal = number 10 digit +hexadecimal = do{ oneOf "xX"; number 16 hexDigit } +octal = do{ oneOf "oO"; number 8 octDigit } + +number :: Integer -> Parser Char -> Parser Integer +number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + +----------------------------------------------------------- +-- Operators & reserved ops +----------------------------------------------------------- +reservedOp name = + lexeme $ try $ + do{ string name + ; notFollowedBy (opLetter tokenDef) ("end of " ++ show name) + } + +operator = + lexeme $ try $ + do{ name <- oper + ; if (isReservedOp name) + then unexpected ("reserved operator " ++ show name) + else return name + } + +oper = + do{ c <- (opStart tokenDef) + ; cs <- many (opLetter tokenDef) + ; return (c:cs) + } + "operator" + +isReservedOp name = + isReserved (sort (reservedOpNames tokenDef)) name + + +----------------------------------------------------------- +-- Identifiers & Reserved words +----------------------------------------------------------- +reserved name = + lexeme $ try $ + do{ caseString name + ; notFollowedBy (identLetter tokenDef) ("end of " ++ show name) + } + +caseString name + | caseSensitive tokenDef = string name + | otherwise = do{ walk name; return name } + where + walk [] = return () + walk (c:cs) = do{ caseChar c msg; walk cs } + + caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) + | otherwise = char c + + msg = show name + + +identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then unexpected ("reserved word " ++ show name) + else return name + } + +ident + = do{ c <- identStart tokenDef + ; cs <- many (identLetter tokenDef) + ; return (c:cs) + } + "identifier" + +isReservedName name + = isReserved theReservedNames caseName + where + caseName | caseSensitive tokenDef = name + | otherwise = map toLower name + + +isReserved names name + = scan names + where + scan [] = False + scan (r:rs) = case (compare r name) of + LT -> scan rs + EQ -> True + GT -> False + +theReservedNames + | caseSensitive tokenDef = sortedNames + | otherwise = map (map toLower) sortedNames + where + sortedNames = sort (reservedNames tokenDef) + + +----------------------------------------------------------- +-- White space & symbols +----------------------------------------------------------- +symbol name + = lexeme (string name) + +lexeme p + = do{ x <- p; whiteSpace; return x } + + +--whiteSpace +whiteSpace + | noLine && noMulti = skipMany (simpleSpace "") + | noLine = skipMany (simpleSpace <|> multiLineComment "") + | noMulti = skipMany (simpleSpace <|> oneLineComment "") + | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + noLine = null (commentLine tokenDef) + noMulti = null (commentStart tokenDef) + + +simpleSpace = + skipMany1 (satisfy isSpace) + +oneLineComment = + do{ try (string (commentLine tokenDef)) + ; skipMany (satisfy (/= '\n')) + ; return () + } + +multiLineComment = + do { try (string (commentStart tokenDef)) + ; inComment + } + +inComment + | nestedComments tokenDef = inCommentMulti + | otherwise = inCommentSingle + +inCommentMulti + = do{ try (string (commentEnd tokenDef)) ; return () } + <|> do{ multiLineComment ; inCommentMulti } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } + <|> do{ oneOf startEnd ; inCommentMulti } + "end of comment" + where + startEnd = nub (commentEnd tokenDef ++ commentStart tokenDef) + +inCommentSingle + = do{ try (string (commentEnd tokenDef)); return () } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } + <|> do{ oneOf startEnd ; inCommentSingle } + "end of comment" + where + startEnd = nub (commentEnd tokenDef ++ commentStart tokenDef) + diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,453 @@ +{----------------------------------------------------------- + Daan Leijen (c) 1999-2000, daan@cs.uu.nl + + $version: 23 Feb 2000, release version 0.2$ + + Parsec, the Fast Monadic Parser combinator library. + http://wwww.cs.uu.nl/~daan/parsec.html + + Inspired by: + + Graham Hutton and Erik Meijer: + Monadic Parser Combinators. + Technical report NOTTCS-TR-96-4. + Department of Computer Science, University of Nottingham, 1996. + http://www.cs.nott.ac.uk/~gmh/monparsing.ps + + and: + + Andrew Partridge, David Wright: + Predictive parser combinators need four values to report errors. + Journal of Functional Programming 6(2): 355-364, 1996 +-----------------------------------------------------------} + +module Parser( + --operators: label a parser, alternative + (), (<|>) + + --basic types + , Parser, parse, parseFromFile + + , ParseError, errorPos, errorMessages + , SourcePos, sourceName, sourceLine, sourceColumn + , SourceName, Source, Line, Column + , Message(SysUnExpect,UnExpect,Expect,Message) + , messageString, messageCompare, messageEq, showErrorMessages + + --general combinators + , skipMany, skipMany1 + , many, many1, manyTill + , sepBy, sepBy1 + , count + , chainr1, chainl1 + , option, optional + , choice, between + , oneOf, noneOf + , anySymbol + , notFollowedBy + + --language dependent character parsers + , letter, alphaNum, lower, upper, newline, tab + , digit, hexDigit, octDigit + , space, spaces + --, oneOf, noneOf + , char, anyChar + , string + , eof + + --primitive + , satisfy + , try + , token --obsolete, use try instead + , pzero, onFail, unexpected + + , getPosition, setPosition + , getInput, setInput + + , getState, setState + ) where + +import ParseError +import Monad +import Char + + +----------------------------------------------------------- +-- Operators: +-- gives a name to a parser (which is used in error messages) +-- <|> is the choice operator +----------------------------------------------------------- +infix 0 +infixr 1 <|> + + +() :: Parser a -> String -> Parser a +p msg = onFail p msg + +(<|>) :: Parser a -> Parser a -> Parser a +p1 <|> p2 = mplus p1 p2 + + +----------------------------------------------------------- +-- Character parsers +----------------------------------------------------------- +spaces = skipMany space "white space" +space = satisfy (isSpace) "space" + +newline = char '\n' "new-line" +tab = char '\t' "tab" + +upper = satisfy (isUpper) "uppercase letter" +lower = satisfy (isLower) "lowercase letter" +alphaNum = satisfy (isAlphaNum) "letter or digit" +letter = satisfy (isAlpha) "letter" +digit = satisfy (isDigit) "digit" +hexDigit = satisfy (isHexDigit) "hexadecimal digit" +octDigit = satisfy (isOctDigit) "octal digit" + + +-- char c = satisfy (==c) show [c] +char c = do{ string [c]; return c} show [c] +anyChar = anySymbol + +-- string :: String -> Parser String +-- string is defined later as a primitive for speed reasons. + + +----------------------------------------------------------- +-- General parser combinators +----------------------------------------------------------- +noneOf cs = satisfy (\c -> not (c `elem` cs)) +oneOf cs = satisfy (\c -> c `elem` cs) + +anySymbol = satisfy (const True) + + +choice :: [Parser a] -> Parser a +choice ps = foldr (<|>) mzero ps + +option :: a -> Parser a -> Parser a +option x p = p <|> return x + +optional :: Parser a -> Parser () +optional p = do{ p; return ()} <|> return () + +between :: Parser open -> Parser close -> Parser a -> Parser a +between open close p + = do{ open; x <- p; close; return x } + + +skipMany,skipMany1 :: Parser a -> Parser () +skipMany1 p = do{ p; skipMany p } +skipMany p = scan + where + scan = do{ p; scan } <|> return () + +many1,many :: Parser a -> Parser [a] +many1 p = do{ x <- p; xs <- many p; return (x:xs) } + +many p = scan id + where + scan f = do{ x <- p + ; scan (\tail -> f (x:tail)) + } + <|> return (f []) + +sepBy1,sepBy :: Parser a -> Parser sep -> Parser [a] +sepBy p sep = sepBy1 p sep <|> return [] +sepBy1 p sep = do{ x <- p + ; xs <- many (sep >> p) + ; return (x:xs) + } + +count :: Int -> Parser a -> Parser [a] +count n p | n <= 0 = return [] + | otherwise = sequence (replicate n p) + + +chainr p op x = chainr1 p op <|> return x +chainl p op x = chainl1 p op <|> return x + +chainr1,chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a +chainl1 p op = do{ x <- p; rest x } + where + rest x = do{ f <- op + ; y <- p + ; rest (f x y) + } + <|> return x + +chainr1 p op = scan + where + scan = do{ x <- p; rest x } + + rest x = do{ f <- op + ; y <- scan + ; return (f x y) + } + <|> return x + + +----------------------------------------------------------- +-- Tricky combinators +----------------------------------------------------------- +eof :: Parser () +eof = notFollowedBy anySymbol "end of input" + +notFollowedBy :: Parser Char -> Parser () +notFollowedBy p = try (do{ c <- p; unexpected (show [c]) } + <|> return () + ) + +manyTill :: Parser a -> Parser end -> Parser [a] +manyTill p end = scan + where + scan = do{ end; return [] } + <|> + do{ x <- p; xs <- scan; return (x:xs) } + + +lookAhead :: Parser a -> Parser a +lookAhead p = do{ state <- getState + ; x <- p + ; setState state + ; return x + } + + +----------------------------------------------------------- +-- Parser state combinators +----------------------------------------------------------- +getPosition :: Parser SourcePos +getPosition = do{ state <- getState; return (statePos state) } + +getInput :: Parser Source +getInput = do{ state <- getState; return (stateInput state) } + + +setPosition :: SourcePos -> Parser () +setPosition pos = do{ updateState (\(State input _) -> State input pos) + ; return () + } + +setInput :: Source -> Parser () +setInput input = do{ updateState (\(State _ pos) -> State input pos) + ; return () + } + +getState = updateState id +setState state = updateState (const state) + + + + +----------------------------------------------------------- +-- Parser definition. +----------------------------------------------------------- +data Parser a = Parser (State -> Consumed (Reply a)) +runP (Parser p) = p + +data Consumed a = Consumed a --input is consumed + | Empty !a --no input is consumed + +data Reply a = Ok !a !State ParseError --parsing succeeded with @a@ + | Error ParseError --parsing failed + +data State = State { stateInput :: !Source + , statePos :: !SourcePos + } +type Source = String + + + +setExpectError msg err = setErrorMessage (Expect msg) err +sysUnExpectError msg pos= Error (newErrorMessage (SysUnExpect msg) pos) +unknownError state = newErrorUnknown (statePos state) + +----------------------------------------------------------- +-- run a parser +----------------------------------------------------------- +parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a) +parseFromFile p fname + = do{ input <- readFile fname + ; return (parse p fname input) + } + +parse :: Parser a -> SourceName -> Source -> Either ParseError a +parse p name input + = case parserReply (runP p (State input (initialPos name))) of + Ok x _ _ -> Right x + Error err -> Left err + +parserReply result + = case result of + Consumed reply -> reply + Empty reply -> reply + + +----------------------------------------------------------- +-- Functor: fmap +----------------------------------------------------------- +instance Functor Parser where + fmap f (Parser p) + = Parser (\state -> + case (p state) of + Consumed reply -> Consumed (mapReply reply) + Empty reply -> Empty (mapReply reply) + ) + where + mapReply reply + = case reply of + Ok x state err -> let fx = f x + in seq fx (Ok fx state err) + Error err -> Error err + + +----------------------------------------------------------- +-- Monad: return, sequence (>>=) and fail +----------------------------------------------------------- +instance Monad Parser where + return x + = Parser (\state -> Empty (Ok x state (unknownError state))) + + (Parser p) >>= f + = Parser (\state -> + case (p state) of + Consumed reply1 + -> Consumed $ + case (reply1) of + Ok x state1 err1 -> case runP (f x) state1 of + Empty reply2 -> mergeErrorReply err1 reply2 + Consumed reply2 -> reply2 + Error err1 -> Error err1 + + Empty reply1 + -> case (reply1) of + Ok x state1 err1 -> case runP (f x) state1 of + Empty reply2 -> Empty (mergeErrorReply err1 reply2) + other -> other + Error err1 -> Empty (Error err1) + ) + + + fail msg + = Parser (\state -> + Empty (Error (newErrorMessage (Message msg) (statePos state)))) + + +mergeErrorReply err1 reply + = case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) + + +----------------------------------------------------------- +-- MonadPlus: alternative (mplus) and mzero +----------------------------------------------------------- +pzero :: Parser a +pzero = mzero + +instance MonadPlus Parser where + mzero + = Parser (\state -> Empty (Error (unknownError state))) + + mplus (Parser p1) (Parser p2) + = Parser (\state -> + case (p1 state) of + Empty (Error err) -> case (p2 state) of + Empty reply -> Empty (mergeErrorReply err reply) + consumed -> consumed + other -> other + ) + +----------------------------------------------------------- +-- Primitive Parsers: +-- try, satisfy, onFail, unexpected and updateState +----------------------------------------------------------- +try :: Parser a -> Parser a +try (Parser p) + = Parser (\state@(State input pos) -> + case (p state) of + Consumed (Error err) -> Empty (Error (setErrorPos pos err)) + Consumed ok -> Empty ok + empty -> empty + ) + +token p --obsolete, use "try" instead + = try p + +satisfy :: (Char -> Bool) -> Parser Char +satisfy test + = Parser (\state@(State input pos) -> + case input of + (c:cs) | test c -> let newpos = updatePos pos c + newstate = State cs newpos + in seq newpos $ seq newstate $ + Consumed (Ok c newstate (newErrorUnknown newpos)) + | otherwise -> Empty (sysUnExpectError (show [c]) pos) + [] -> Empty (sysUnExpectError "" pos) + ) + + +onFail :: Parser a -> String -> Parser a +onFail (Parser p) msg + = Parser (\state -> + case (p state) of + Empty reply + -> Empty $ + case (reply) of + Error err -> Error (setExpectError msg err) + Ok x state1 err | errorIsUnknown err -> reply + | otherwise -> Ok x state1 (setExpectError msg err) + other -> other + ) + + +updateState :: (State -> State) -> Parser State +updateState f + = Parser (\state -> Empty (Ok state (f state) (unknownError state))) + + +unexpected :: String -> Parser a +unexpected msg + = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state)))) + + +----------------------------------------------------------- +-- Parsers unfolded for speed: +-- string +----------------------------------------------------------- + +{- specification of @string@: +string s = scan s + where + scan [] = return s + scan (c:cs) = do{ char c show s; scan cs } +-} + +string :: String -> Parser String +string s + = Parser (\state@(State input pos) -> + let + ok cs = let newpos = updatePosString pos s + newstate = State cs newpos + in seq newpos $ seq newstate $ + (Ok s newstate (newErrorUnknown newpos)) + + errEof = Error (setErrorMessage (Expect (show s)) + (newErrorMessage (SysUnExpect "") pos)) + errExpect c = Error (setErrorMessage (Expect (show s)) + (newErrorMessage (SysUnExpect (show [c])) pos)) + + walk [] cs = ok cs + walk xs [] = errEof + walk (x:xs) (c:cs)| x == c = walk xs cs + | otherwise = errExpect c + + walk1 [] cs = Empty (ok cs) + walk1 xs [] = Empty (errEof) + walk1 (x:xs) (c:cs)| x == c = Consumed (walk xs cs) + | otherwise = Empty (errExpect c) + + in walk1 s input) + diff --git a/src/Request.hs b/src/Request.hs new file mode 100644 --- /dev/null +++ b/src/Request.hs @@ -0,0 +1,271 @@ +-- ----------------------------------------------------------------------------- +-- 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 Request where + +import Parser hiding (Message(..)) +import Config +import Response +import Util + +import Network.URI +import Char + +----------------------------------------------------------------------------- +-- Requests + +-- Request-Line = Method SP Request-URI SP HTTP-Version CRLF + +data RequestCmd + = OptionsReq + | GetReq + | HeadReq + | PostReq + | PutReq + | DeleteReq + | TraceReq + | ConnectReq + | ExtensionReq String + +type CResponse = Config -> Response + +requestCmdString cmd = case cmd of + OptionsReq -> "OPTIONS" + GetReq -> "GET" + HeadReq -> "HEAD" + PostReq -> "POST" + PutReq -> "PUT" + DeleteReq -> "DELETE" + TraceReq -> "TRACE" + ConnectReq -> "CONNECT" + +data Request = Request { + reqCmd :: RequestCmd, + reqURI :: ReqURI, + reqHTTPVer :: HTTPVersion, + reqHeaders :: [RequestHeader] + } + +instance Show Request where + showsPrec _ Request{reqCmd = cmd, reqURI = uri, reqHTTPVer = (maj,min)} + = showString (requestCmdString cmd) . (' ':) + . shows uri . (' ':) + . showString "HTTP/" . shows maj . showString "." . shows min + +type HTTPVersion = (Int,Int) + +http1_1, http1_0 :: HTTPVersion +http1_1 = (1,1) +http1_0 = (1,0) + +data ReqURI + = NoURI + | AbsURI URI + | AbsPath String + | AuthorityURI String + +instance Show ReqURI where + showsPrec _ NoURI = showString "" + showsPrec _ (AbsURI uri) = shows uri + showsPrec _ (AbsPath path) = showString path + showsPrec _ (AuthorityURI s) = showString s + +data Connection + = ConnectionClose + | ConnectionKeepAlive -- non-std? Netscape generates it. + | ConnectionOther String + deriving (Eq, Show) + +data Expect + = ExpectContinue + deriving Show + +data RequestHeader + -- general headers: + = CacheControl String + | Connection [Connection] + | Date String + | Pragma String + | Trailer String + | TransferEncoding String + | Upgrade String + | Via String + | Warning String + -- request-only headers: + | Accept String + | AcceptCharset String + | AcceptEncoding String + | AcceptLanguage String + | Authorization String + | Expect Expect + | From String + | Host String{-hostname-} (Maybe Int){-port-} + | IfMatch String + | IfModifiedSince String + | IfNoneMatch String + | IfRange String + | IfUnmodifiedSince String + | MaxForwards String + | ProxyAuthorization String + | Range String + | Referer String + | TE String + | UserAgent String + | ExtensionHeader String String + deriving Show + +-- parseRequest returns a response directly if the request +-- isn't valid for some reason. + +parseRequest :: [String] -> E CResponse Request +parseRequest [] = failE badRequestResponse +parseRequest (request : headers) = + case words request of + [cmd, uri, http_ver] -> do + req_cmd <- maybeE badRequestResponse (parseCmd cmd) + req_uri <- maybeE badRequestResponse (parseReqURI uri) + req_http_ver <- maybeE badRequestResponse (parseHTTPVersion http_ver) + req_headers <- parseHeaders headers + trace (show req_headers) $ + return (Request req_cmd req_uri req_http_ver req_headers) + + _other -> failE badRequestResponse + + +-- RFC 2616 says these are case-sensitive (sec. 5.1.1) +parseCmd :: String -> Maybe RequestCmd +parseCmd "OPTIONS" = Just OptionsReq +parseCmd "GET" = Just GetReq +parseCmd "HEAD" = Just HeadReq +parseCmd "POST" = Just PostReq +parseCmd "PUT" = Just PutReq +parseCmd "DELETE" = Just DeleteReq +parseCmd "TRACE" = Just TraceReq +parseCmd "CONNECT" = Just ConnectReq +parseCmd other = Just (ExtensionReq other) + +parseReqURI :: String -> Maybe ReqURI +parseReqURI "*" = Just NoURI +parseReqURI (uri@('/':_)) = Just (AbsPath (deHex uri)) +parseReqURI uri = + case parseURI uri of + Nothing -> Nothing + Just uri -> Just (AbsURI uri) + +parseHTTPVersion :: String -> Maybe (Int,Int) +parseHTTPVersion s = + case parse httpVersionParser "HTTP version" s of + Right result -> Just result + Left error -> Nothing + +httpVersionParser = + do string "HTTP/"; + major <- int; + char '.'; + minor <- int; + return (major, minor) + +int :: Parser Int +int = do{ digits <- many1 digit + ; let n = foldl (\x d -> 10*x + digitToInt d) 0 digits + ; seq n (return n) + } + +----------------------------------------------------------------------------- +-- Parsing request headers + +parseHeaders :: [String] -> E CResponse [RequestHeader] +parseHeaders hs = sequence (map parseHeader hs) + +parseHeader :: String -> E CResponse RequestHeader +parseHeader header = + let (header_type, val) = break (==':') header + in case val of + ':':val -> parseHeaderAs header_type (stripWS val) + _ -> failE badRequestResponse + +parseHeaderAs :: String -> String -> E CResponse RequestHeader +parseHeaderAs header_type value + = case (map toLower header_type) of + "connection" -> parseConnection value + "date" -> valString Date + "pragma" -> valString Pragma + "trailer" -> valString Trailer + "transfer-encoding" -> valString TransferEncoding + "upgrade" -> valString Upgrade + "via" -> valString Via + "warning" -> valString Warning + "accept" -> valString Accept + "accept-charset" -> valString AcceptCharset + "accept-encoding" -> valString AcceptEncoding + "accept-language" -> valString AcceptLanguage + "authorization" -> valString Authorization + "cache-control" -> valString CacheControl + "expect" -> parseExpect value + "from" -> valString From + "host" -> parseHost value + "if-match" -> valString IfMatch + "if-modified-since" -> valString IfModifiedSince + "if-none-match" -> valString IfNoneMatch + "if-range" -> valString IfRange + "if-unmodified-since" -> valString IfUnmodifiedSince + "max-forwards" -> valString MaxForwards + "proxy-authorization" -> valString ProxyAuthorization + "range" -> valString Range + "referer" -> valString Referer + "te" -> valString TE + "user-agent" -> valString UserAgent + _ -> valString (ExtensionHeader header_type) + where + valString :: (String -> RequestHeader) -> E CResponse RequestHeader + valString header_con = return (header_con value) + +parseConnection :: String -> E CResponse RequestHeader +parseConnection s = return (Connection (map fn (commaSep (map toLower s)))) + where fn "close" = ConnectionClose + fn "keep-alive" = ConnectionKeepAlive + fn other = ConnectionOther other + +parseExpect :: String -> E CResponse RequestHeader +parseExpect s = + case commaSep s of + ["100-continue"] -> return (Expect ExpectContinue) + _ -> failE expectationFailedResponse + +parseHost :: String -> E CResponse RequestHeader +parseHost s = + case port of + "" -> return (Host host Nothing) + ':':port | all isDigit port -> return (Host host (Just (read port))) + _ -> failE badRequestResponse + where (host,port) = break (==':') s + diff --git a/src/Response.hs b/src/Response.hs new file mode 100644 --- /dev/null +++ b/src/Response.hs @@ -0,0 +1,331 @@ +-- ----------------------------------------------------------------------------- +-- 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 Response where + +import Config +import Util + +import IO +import Time +import Control.Monad +import Control.Exception +import Data.Array.MArray +import Data.Array.IO +import Text.Html +import Control.Monad.ST (stToIO) + +--import PrelHandle + +----------------------------------------------------------------------------- +-- Responses + +data ResponseBody + = NoBody + | FileBody Integer{-size-} FilePath + | HereItIs String + +data Response + = Response { + respCode :: Int, + respHeaders :: [String], + 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 _ (Response s hs _ _ _) + = foldr (\s r -> s . r) id (shows s : (' ':) : showString (responseDescription s) : map (showString . ('\n':)) hs) + . showChar '\n' + +response :: Config + -> Handle + -> Response + -> IO () + +response _conf h (Response { respCode = code, + respHeaders = headers, + respCoding = tes, + respBody = body, + respSendBody = send_body }) = do + + hPutStrCrLf h (statusLine code) + hPutStrCrLf h serverHeader + + -- Date Header: required on all messages + date <- dateHeader + hPutStrCrLf h date + + mapM_ (hPutStrCrLf h) 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 = contentLength body + when (content_length /= 0 && null tes) + (hPutStrCrLf h (contentLengthHeader content_length)) + + mapM_ (hPutStrCrLf h . transferCodingHeader) tes + + hPutStr h crlf + -- ToDo: implement transfer codings + + if send_body + then sendBody h body + else return () + +contentLength :: ResponseBody -> Integer +contentLength NoBody = 0 +contentLength (HereItIs stuff) = toInteger (length stuff) +contentLength (FileBody size _) = size + +getFileName :: ResponseBody -> String +getFileName (NoBody) = "" +getFileName (FileBody _size filename) = filename +getFileName (HereItIs _) = "" + +sendBody :: Handle -> ResponseBody -> IO () +sendBody _ NoBody = return () +sendBody h (HereItIs stuff) = hPutStr h stuff +sendBody h (FileBody _size filename) + = Control.Exception.bracket + (openFile filename ReadMode) + (\handle -> hClose handle) + (\handle -> squirt handle h >> hFlush h) + +bufsize = 4 * 1024 :: Int + +-- squirt data from 'rd' into 'wr' as fast as possible. We use a 4k +-- single buffer. +squirt rd wr = do + arr <- newArray_ (0, bufsize-1) + let loop = do r <- hGetArray rd arr bufsize + if (r < bufsize) + then if (r == 0) + then return () + else hPutArray wr arr r + else hPutArray wr arr bufsize >> loop + loop + +statusLine :: Int{-Response-} -> String +statusLine code = httpVersion ++ + ' ': show code ++ + ' ': responseDescription code + +httpVersion = "HTTP/1.1" + +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 + +----------------------------------------------------------------------------- +-- Response Headers + +dateHeader :: IO String +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 ("Date: " ++ time_str) + +serverHeader :: String +serverHeader = "Server: " ++ serverSoftware ++ '/':serverVersion + +contentLengthHeader :: Integer -> String +contentLengthHeader i = "Content-Length: " ++ show i + +contentTypeHeader :: String -> String +contentTypeHeader t = "Content-Type: " ++ t + +lastModifiedHeader :: ClockTime -> String +lastModifiedHeader t = "Last-Modified: " ++ formatTimeSensibly (toUTCTime t) + +locationHeader :: String -> String +locationHeader l = "Location: " ++ (urlEncode l) + +locationBody :: String -> ResponseBody +locationBody l = HereItIs ("\n\n301 Moved Permanently\n\n

    Moved Permanently

    \n

    The document has moved here.

    \n\n") + + +transferCodingHeader :: TransferCoding -> String +transferCodingHeader te = "Transfer-Coding: " ++ transferCodingStr te + +----------------------------------------------------------------------------- +-- Response codes + +contResponse = error_resp 100 +switchingProtocolsResponse = error_resp 101 +okResponse = body_resp 200 +createdResponse = error_resp 201 +acceptedResponse = error_resp 202 +nonAuthoritiveInformationResponse = error_resp 203 +noContentResponse = error_resp 204 +resetContentResponse = error_resp 205 +partialContentResponse = error_resp 206 +multipleChoicesResponse = error_resp 300 +movedPermanentlyResponse = redir_resp 301 +foundResponse = error_resp 302 +seeOtherResponse = error_resp 303 +notModifiedResponse = error_resp 304 +useProxyResponse = error_resp 305 +temporaryRedirectResponse = error_resp 307 +badRequestResponse = error_resp 400 +unauthorizedResponse = error_resp 401 +paymentRequiredResponse = error_resp 402 +forbiddenResponse = error_resp 403 +notFoundResponse = error_resp 404 +methodNotAllowedResponse = error_resp 405 +notAcceptableResponse = error_resp 406 +proxyAuthenticationRequiredResponse = error_resp 407 +requestTimeOutResponse = error_resp 408 +conflictResponse = error_resp 409 +goneResponse = error_resp 410 +lengthRequiredResponse = error_resp 411 +preconditionFailedResponse = error_resp 412 +requestEntityTooLargeResponse = error_resp 413 +requestURITooLargeResponse = error_resp 414 +unsupportedMediaTypeResponse = error_resp 415 +requestedRangeNotSatisfiableResponse = error_resp 416 +expectationFailedResponse = error_resp 417 +internalServerErrorResponse = error_resp 500 +notImplementedResponse = error_resp 501 +badGatewayResponse = error_resp 502 +serviceUnavailableResponse = error_resp 503 +gatewayTimeOutResponse = error_resp 504 +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 code conf + = Response code [contentTypeHeader "text/html"] [] + (generateErrorPage code conf) True + +body_resp code _conf body headers = Response code headers [] body + +redir_resp code conf url = Response code [locationHeader url] [] (locationBody url) True + +----------------------------------------------------------------------------- +-- Error pages + +-- We generate some html for the client to display on an error. + +generateErrorPage :: Int -> Config -> ResponseBody +generateErrorPage code conf + = HereItIs (renderHtml (genErrorHtml code conf)) + +genErrorHtml :: Int -> Config -> Html +genErrorHtml code 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 code + response = show code +++ ' ' +++ descr diff --git a/src/StdTokenDef.hs b/src/StdTokenDef.hs new file mode 100644 --- /dev/null +++ b/src/StdTokenDef.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------- +-- Daan Leijen (c) 1999, daan@cs.uu.nl +-- +-- $version: 23 Feb 2000, release version 0.2$ +----------------------------------------------------------- +module StdTokenDef (TokenDef(..) + ,haskellStyle, javaStyle + ,emptyStyle + ,haskell, haskellExt + ,mondrian + ) where + +import Parser + +----------------------------------------------------------- +-- TokenDef +----------------------------------------------------------- +data TokenDef = TokenDef + { commentStart :: String + , commentEnd :: String + , commentLine :: String + , nestedComments :: Bool + , identStart :: Parser Char + , identLetter :: Parser Char + , opStart :: Parser Char + , opLetter :: Parser Char + , reservedNames :: [String] + , reservedOpNames:: [String] + , caseSensitive :: Bool + } + +----------------------------------------------------------- +-- Styles: haskellStyle, javaStyle +----------------------------------------------------------- +haskellStyle= emptyStyle + { commentStart = "{-" + , commentEnd = "-}" + , commentLine = "--" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter haskell + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + +javaStyle = emptyStyle + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "//" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + -- fixed set of operators: use 'symbol' + , reservedNames = [] + , reservedOpNames= [] + , caseSensitive = False + } + +----------------------------------------------------------- +-- Haskell +----------------------------------------------------------- +haskellExt = haskell + { identLetter = identLetter haskell <|> char '#' + , reservedNames = reservedNames haskell ++ + ["foreign","import","export","primitive" + ,"_ccall_","_casm_" + ,"forall" + ] + } + +haskell = haskellStyle + { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] + , reservedNames = ["let","in","case","of","if","then","else", + "data","type", + "class","default","deriving","do","import", + "infix","infixl","infixr","instance","module", + "newtype","where", + "primitive" + -- "as","qualified","hiding" + ] + } + + +----------------------------------------------------------- +-- Mondrian +----------------------------------------------------------- +mondrian = javaStyle + { reservedNames = [ "case", "class", "default", "extends" + , "import", "in", "let", "new", "of", "package" + ] + , caseSensitive = True + } + + +----------------------------------------------------------- +-- minimal token definition +----------------------------------------------------------- +emptyStyle + = TokenDef + { commentStart = "" + , commentEnd = "" + , commentLine = "" + , nestedComments = True + , identStart = unexpected "identifier" + , identLetter = unexpected "identifier" + , opStart = unexpected "operator" + , opLetter = unexpected "operator" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + diff --git a/src/TokenDef.hs b/src/TokenDef.hs new file mode 100644 --- /dev/null +++ b/src/TokenDef.hs @@ -0,0 +1,11 @@ +module TokenDef where + +import StdTokenDef + +tokenDef = emptyStyle + { commentLine = "#" + , nestedComments = False + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = False + } diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,215 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ----------------------------------------------------------------------------- +-- 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 Util where + +import System.Posix +import Control.Exception +import Control.Concurrent +import Network.Socket + +import Time +import System.Time +import Locale +import Char +import IO +import Data.Bits +import List +import Maybe + +-- XXX necessary? +import GHC.Base +import GHC.Conc +import GHC.IOBase + +#ifdef DEBUG +import qualified Debug.Trace +#endif + +----------------------------------------------------------------------------- +-- Utils + +#ifdef DEBUG +trace s e = Debug.Trace.trace s e +#else +trace s e = e +#endif +traceVal v = trace (show v) v + +crlf = "\r\n" + +emptyLine "\r" = True +emptyLine _ = False + +stripWS :: String -> String +stripWS = stripLeadingWS . reverse . stripLeadingWS . reverse + +stripLeadingWS :: String -> String +stripLeadingWS = dropWhile isSpace + +data E b a = Ok a | Bad b +instance Monad (E b) where + m >>= k = case m of + Ok a -> k a + Bad b -> Bad b + return a = Ok a + +failE :: b -> E b a +failE b = Bad b + +maybeE :: b -> Maybe a -> E b a +maybeE _ (Just a) = return a +maybeE b Nothing = failE b + +commaSep :: String -> [String] +commaSep s = go (dropWhile isSpace s) + where go "" = [] + go s = word : case rest of ',':rest -> go rest; _ -> go rest + where (word,rest) = break (==',') s + +-- ToDo: deHex is supposed to remove the '%'-encoding +deHex :: String -> String +deHex s = s + +hPutStrCrLf h s = hPutStr h s >> hPutChar h '\r' >> hPutChar h '\n' + +----------------------------------------------------------------------------- +-- 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 (fromIntegral (fromEnum epoch_time)) 0 + +----------------------------------------------------------------------------- +-- concurrency utilities + +-- timeout + +-- Time-outs are implemented by having another thread wait for the +-- specified period of time before sending an exception to the +-- original thread. We have to be extremely careful about race +-- conditions here: we don't want the timeout thread raising an +-- exception outside of our handler, so we must arrange that the +-- timeout exception can only be raised when we're ready for it. This +-- is implemented using a semaphore to indicate that the thread is +-- ready to handle the timeout exception. +-- +-- Things get hairy when we consider that the action being run may +-- generate its own exceptions. + +timeout + :: Int -- secs + -> IO a -- action to run + -> IO a -- action to run on timeout + -> IO a + +timeout secs action on_timeout + = do + threadid <- myThreadId + timeout <- forkIOIgnoreExceptions ( + do threadDelay (secs * 1000000) + throwTo threadid (ErrorCall "__timeout") + ) + ( do result <- action + killThread timeout + return result + ) + `Control.Exception.catch` + ( \exception -> case exception of + ErrorCall "__timeout" -> on_timeout + _other -> do + killThread timeout + throw exception ) + +fromHex :: Char -> Int +fromHex c | (c >= '0' && c <= '9') = (fromEnum c) - (fromEnum '0') + | (c >= 'a' && c <= 'f') = (fromEnum c) - (fromEnum 'a') + 10 + | (c >= 'A' && c <= 'F') = (fromEnum c) - (fromEnum 'A') + 10 + | otherwise = -1 +toHex :: Int -> Char +toHex n = "0123456789ABCDEF" !! (n .&. 0xf) + +urlDecode :: String -> String +urlDecode [] = [] +urlDecode ('%':a:b:xs) = if (av /= -1) && (bv /= -1) + then (toEnum (av * 16 + bv)) : urlDecode xs + else '%' : a : b : urlDecode xs where + av = fromHex a + bv = fromHex b +urlDecode (x:xs) = x : urlDecode xs + +urlEncode :: String -> String +urlEncode = concatMap transChars where + transChars c | (c >= 'a' && c <= 'z') = return c + | (c >= 'A' && c <= 'Z') = return c + | (c >= '0' && c <= '9') = return c + | isJust (elemIndex c "$-_.+!*'()/") = return c + | otherwise = '%' : (toHex (cv `shiftR` 4)) : (toHex cv) : [] where + cv = fromEnum c + +splitStr ch s = case span (/= ch) s of + (x, []) -> x : [] + (x, ch : xs) -> x : splitStr ch xs +joinStr ch [] = [] +joinStr ch (x:[]) = x +joinStr ch (x:xs) = x ++ (ch : (joinStr ch xs)) + +{- Strip out ".." components in path names, and colons (dangerous in win32) -} +pathSep = '/' +normPath = rootNull . (joinStr pathSep) . unColon . (normDotDot []) . (splitStr pathSep) . urlDecode where + --normDotDot ps ("":xs) = normDotDot ps xs + normDotDot (p:ps) ("..":xs) = normDotDot ps xs + normDotDot ps ("..":xs) = normDotDot ps xs + normDotDot ps (x:xs) = normDotDot (x:ps) xs + normDotDot ps [] = reverse ps + unColon ps = map (filter (/= ':')) ps + rootNull [] = "/" + rootNull xs = xs + +forkIOIgnoreExceptions :: IO () -> IO ThreadId +forkIOIgnoreExceptions action = IO $ \ s -> + case (fork# action s) of (# s1, id #) -> (# s1, ThreadId id #) + +----------------------------------------------------------------------------- +-- networking utils + +accept :: Socket -- Listening Socket + -> IO (Handle,SockAddr) -- StdIO Handle for read/write +accept sock = do + (sock', addr) <- Network.Socket.accept sock + handle <- socketToHandle sock' ReadWriteMode + return (handle,addr) +