hws 1.1 → 1.1.0.1
raw patch · 16 files changed
+2746/−1 lines, 16 files
Files
- conf/httpd.conf +62/−0
- hws.cabal +19/−1
- src/AccessLogger.hs +235/−0
- src/Config.hs +127/−0
- src/ConfigParser.hs +110/−0
- src/Dir.hs +31/−0
- src/ErrorLogger.hs +110/−0
- src/MimeTypes.hs +85/−0
- src/ParseError.hs +200/−0
- src/ParseToken.hs +371/−0
- src/Parser.hs +453/−0
- src/Request.hs +271/−0
- src/Response.hs +331/−0
- src/StdTokenDef.hs +115/−0
- src/TokenDef.hs +11/−0
- src/Util.hs +215/−0
+ conf/httpd.conf view
@@ -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
hws.cabal view
@@ -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
+ src/AccessLogger.hs view
@@ -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 = "<nobody>", -- ToDo+ log_request = req,+ log_response = resp,+ log_time = time,+ log_delay = delay,+ log_user = "<nouser>", -- 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
+ src/Config.hs view
@@ -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
+ src/ConfigParser.hs view
@@ -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)+
+ src/Dir.hs view
@@ -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 = "<a href=\"..\">Parent Directory</a>\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 (["<ul>"] ++ hs ++ ["</ul>"]) where+ hs = map htmlFile fs+ htmlFile f = " <li><a href=\"" ++ f ++ "\">" ++ f' ++ "</a></li>" where+ f' = f -- XXX html quoted++page title body = "<html>\n<head><title>" ++ title ++ "</title></head>\n<body>\n" ++ body ++ "</body>\n</html>\n"++sec title body = "<h1>" ++ title ++ "</h1>\n" ++ body++
+ src/ErrorLogger.hs view
@@ -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 ')'+ ) ""
+ src/MimeTypes.hs view
@@ -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
+ src/ParseError.hs view
@@ -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) +
+ src/ParseToken.hs view
@@ -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) +
+ src/Parser.hs view
@@ -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) +
+ src/Request.hs view
@@ -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 "<no URI>"+ 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+
+ src/Response.hs view
@@ -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) = "<no file>"+getFileName (FileBody _size filename) = filename+getFileName (HereItIs _) = "<generated content>"++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 ("<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n<html><head>\n<title>301 Moved Permanently</title>\n</head><body>\n<h1>Moved Permanently</h1>\n<p>The document has moved <a href=\"" ++ (urlEncode l) ++ "\">here</a>.</p>\n</body></html>\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
+ src/StdTokenDef.hs view
@@ -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 + } +
+ src/TokenDef.hs view
@@ -0,0 +1,11 @@+module TokenDef where++import StdTokenDef++tokenDef = emptyStyle + { commentLine = "#"+ , nestedComments = False+ , reservedOpNames= []+ , reservedNames = []+ , caseSensitive = False+ }
+ src/Util.hs view
@@ -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)+