hascat-lib (empty) → 0.2
raw patch · 9 files changed
+1467/−0 lines, 9 filesdep +HTTPdep +HaXmldep +basesetup-changed
Dependencies added: HTTP, HaXml, base, bytestring, containers, directory, haskell98, html, mtl, network, old-locale, old-time, parsec, plugins, xhtml
Files
- Hascat/App.hs +50/−0
- Hascat/Config.hs +369/−0
- Hascat/Header.hs +311/−0
- Hascat/Multipart.hs +219/−0
- Hascat/Protocol.hs +199/−0
- Hascat/Toolkit.hs +276/−0
- LICENSE +0/−0
- Setup.hs +7/−0
- hascat-lib.cabal +36/−0
+ Hascat/App.hs view
@@ -0,0 +1,50 @@+module Hascat.App+ ( module Hascat.Config,+ InitHandler,+ RespondHandler,+ DoneHandler,+ Handlers(..),+ SystemHandler(..),+ App(..),+ defaultInit,+ defaultDone,+ defaultHandlers )+where++import Data.Maybe+import Hascat.Config+import Network.HTTP+import Data.ByteString.Lazy+import Hascat.Protocol+import System.Plugins+++type InitHandler a = AppConfig -> IO a+type RespondHandler a = + AppConfig -> a -> ServletRequest -> IO (Response ByteString)+type DoneHandler a = AppConfig -> a -> IO ()++data Handlers a = Handlers {+ initHandler :: InitHandler a,+ respondHandler :: RespondHandler a,+ doneHandler :: DoneHandler a }++data SystemHandler a = SystemHandler (RespondHandler a)++data App = forall a . App {+ appConfig :: AppConfig,+ appModule :: Module,+ appHandlers :: Handlers a,+ appState :: Maybe a,+ appPaused :: Bool }++defaultHandlers = Handlers {+ initHandler = defaultInit,+ respondHandler = undefined,+ doneHandler = defaultDone}++defaultInit :: InitHandler ()+defaultInit _ = return ()++defaultDone :: DoneHandler a+defaultDone _ _ = return ()
+ Hascat/Config.hs view
@@ -0,0 +1,369 @@+module Hascat.Config where++import Text.XML.HaXml.Xml2Haskell+import Text.XML.HaXml.OneOfN+import Char (isSpace)++import Data.List+import Data.Maybe+++{-Type decls-}++data Config = Config Config_Attrs General AppController+ deriving (Eq,Show)+data Config_Attrs = Config_Attrs+ { configVersion :: String+ } deriving (Eq,Show)+data General = General Port ServerRoot PluginLoader+ deriving (Eq,Show)+newtype Port = Port Int deriving (Eq,Show)+newtype ServerRoot = ServerRoot String deriving (Eq,Show)+data PluginLoader = PluginLoader [IncludePath] [PkgConfFile]+ deriving (Eq,Show)+newtype IncludePath = IncludePath String deriving (Eq,Show)+newtype PkgConfFile = PkgConfFile String deriving (Eq,Show)+newtype AppController = AppController [AppConfig] deriving (Eq,Show)++data AppConfig = AppConfig {+ appAttr :: AppConfig_Attrs,+ appName :: Name,+ appDesc :: Description,+ appRoot :: Root,+ appCode :: Code,+ appContextPath :: ContextPath,+ appInitTimeOut :: InitTimeout,+ appResponseTimeOut :: RespondTimeout,+ appDoneTimeOut :: DoneTimeout }+ deriving (Eq,Show)++data AppConfig_Attrs = AppConfig_Attrs { + appConfigType :: Maybe AppConfig_type,+ appConfigAutoStart :: Maybe AppConfig_autoStart } + deriving (Eq,Show)++data AppConfig_type = AppConfig_type_normal | + AppConfig_type_system+ deriving (Eq,Show)+data AppConfig_autoStart = AppConfig_autoStart_yes | + AppConfig_autoStart_no+ deriving (Eq,Show)+newtype Name = Name String deriving (Eq,Show)+newtype Description = Description String deriving (Eq,Show)+newtype Root = Root String deriving (Eq,Show)+newtype Code = Code String deriving (Eq,Show)+newtype ContextPath = ContextPath String deriving (Eq)+newtype InitTimeout = InitTimeout Int deriving (Eq,Show)+newtype RespondTimeout = RespondTimeout Int deriving (Eq,Show)+newtype DoneTimeout = DoneTimeout Int deriving (Eq,Show)++instance Show ContextPath where+ show (ContextPath contextPath) = contextPath++{-Instance decls-}++instance XmlContent Config where+ fromElem (CElem (Elem "config" as c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Just (Config (fromAttrs as) a b), rest))+ (definite fromElem "<appController>" "config" ca))+ (definite fromElem "<general>" "config" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Config as a b) =+ [CElem (Elem "config" (toAttrs as) (toElem a ++ toElem b))]+instance XmlAttributes Config_Attrs where+ fromAttrs as =+ Config_Attrs+ { configVersion = definiteA fromAttrToStr "config" "version" as+ }+ toAttrs v = catMaybes + [ toAttrFrStr "version" (configVersion v)+ ]+instance XmlContent General where+ fromElem (CElem (Elem "general" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (\(c,cc)->+ (Just (General a b c), rest))+ (definite fromElem "<pluginLoader>" "general" cb))+ (definite fromElem "<serverRoot>" "general" ca))+ (definite fromElem "<port>" "general" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (General a b c) =+ [CElem (Elem "general" [] (toElem a ++ toElem b ++ toElem c))]+instance XmlContent Port where+ fromElem (CElem (Elem "port" [] c0):rest) =+ (\(a,ca)->+ (Just (Port a), rest))+ (definite (toInt . fromText) "int" "port" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Port a) =+ [CElem (Elem "port" [] (toText (fromInt a)))]+instance XmlContent ServerRoot where+ fromElem (CElem (Elem "serverRoot" [] c0):rest) =+ (\(a,ca)->+ (Just (ServerRoot a), rest))+ (definite fromText "text" "serverRoot" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (ServerRoot a) =+ [CElem (Elem "serverRoot" [] (toText a))]+instance XmlContent PluginLoader where+ fromElem (CElem (Elem "pluginLoader" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Just (PluginLoader a b), rest))+ (many fromElem ca))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (PluginLoader a b) =+ [CElem (Elem "pluginLoader" [] (concatMap toElem a +++ concatMap toElem b))]+instance XmlContent IncludePath where+ fromElem (CElem (Elem "includePath" [] c0):rest) =+ (\(a,ca)->+ (Just (IncludePath a), rest))+ (definite fromText "text" "includePath" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (IncludePath a) =+ [CElem (Elem "includePath" [] (toText a))]+instance XmlContent PkgConfFile where+ fromElem (CElem (Elem "pkgConfFile" [] c0):rest) =+ (\(a,ca)->+ (Just (PkgConfFile a), rest))+ (definite fromText "text" "pkgConfFile" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (PkgConfFile a) =+ [CElem (Elem "pkgConfFile" [] (toText a))]+instance XmlContent AppController where+ fromElem (CElem (Elem "appController" [] c0):rest) =+ (\(a,ca)->+ (Just (AppController a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (AppController a) =+ [CElem (Elem "appController" [] (concatMap toElem a))]+instance XmlContent AppConfig where+ fromElem (CElem (Elem "appConfig" as c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (\(c,cc)->+ (\(d,cd)->+ (\(e,ce)->+ (\(f,cf)->+ (\(g,cg)->+ (\(h,ch)->+ (Just (AppConfig (fromAttrs as) a b c d e f g h), rest))+ (definite fromElem "<doneTimeout>" "appConfig" cg))+ (definite fromElem "<respondTimeout>" "appConfig" cf))+ (definite fromElem "<initTimeout>" "appConfig" ce))+ (definite fromElem "<contextPath>" "appConfig" cd))+ (definite fromElem "<code>" "appConfig" cc))+ (definite fromElem "<root>" "appConfig" cb))+ (definite fromElem "<description>" "appConfig" ca))+ (definite fromElem "<name>" "appConfig" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (AppConfig as a b c d e f g h) =+ [CElem (Elem "appConfig" (toAttrs as) (toElem a ++ toElem b +++ toElem c ++ toElem d ++ toElem e ++ toElem f +++ toElem g ++ toElem h))]+instance XmlAttributes AppConfig_Attrs where+ fromAttrs as =+ AppConfig_Attrs+ { appConfigType = possibleA fromAttrToTyp "type" as+ , appConfigAutoStart = possibleA fromAttrToTyp "autoStart" as+ }+ toAttrs v = catMaybes + [ maybeToAttr toAttrFrTyp "type" (appConfigType v)+ , maybeToAttr toAttrFrTyp "autoStart" (appConfigAutoStart v)+ ]+instance XmlAttrType AppConfig_type where+ fromAttrToTyp n (n',v)+ | n==n' = translate (attr2str v)+ | otherwise = Nothing+ where translate "normal" = Just AppConfig_type_normal+ translate "system" = Just AppConfig_type_system+ translate _ = Nothing+ toAttrFrTyp n AppConfig_type_normal = Just (n, str2attr "normal")+ toAttrFrTyp n AppConfig_type_system = Just (n, str2attr "system")+instance XmlAttrType AppConfig_autoStart where+ fromAttrToTyp n (n',v)+ | n==n' = translate (attr2str v)+ | otherwise = Nothing+ where translate "yes" = Just AppConfig_autoStart_yes+ translate "no" = Just AppConfig_autoStart_no+ translate _ = Nothing+ toAttrFrTyp n AppConfig_autoStart_yes = Just (n, str2attr "yes")+ toAttrFrTyp n AppConfig_autoStart_no = Just (n, str2attr "no")+instance XmlContent Name where+ fromElem (CElem (Elem "name" [] c0):rest) =+ (\(a,ca)->+ (Just (Name a), rest))+ (definite fromText "text" "name" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Name a) =+ [CElem (Elem "name" [] (toText a))]+instance XmlContent Description where+ fromElem (CElem (Elem "description" [] c0):rest) =+ (\(a,ca)->+ (Just (Description a), rest))+ (definite fromText "text" "description" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Description a) =+ [CElem (Elem "description" [] (toText a))]+instance XmlContent Root where+ fromElem (CElem (Elem "root" [] c0):rest) =+ (\(a,ca)->+ (Just (Root a), rest))+ (definite fromText "text" "root" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Root a) =+ [CElem (Elem "root" [] (toText a))]+instance XmlContent Code where+ fromElem (CElem (Elem "code" [] c0):rest) =+ (\(a,ca)->+ (Just (Code a), rest))+ (definite fromText "text" "code" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (Code a) =+ [CElem (Elem "code" [] (toText a))]+instance XmlContent ContextPath where+ fromElem (CElem (Elem "contextPath" [] c0):rest) =+ (\(a,ca)->+ (Just (ContextPath a), rest))+ (definite fromText "text" "contextPath" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (ContextPath a) =+ [CElem (Elem "contextPath" [] (toText a))]+instance XmlContent InitTimeout where+ fromElem (CElem (Elem "initTimeout" [] c0):rest) =+ (\(a,ca)->+ (Just (InitTimeout a), rest))+ (definite (toInt . fromText) "int" "initTimeout" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (InitTimeout a) =+ [CElem (Elem "initTimeout" [] (toText (fromInt a)))]+instance XmlContent RespondTimeout where+ fromElem (CElem (Elem "respondTimeout" [] c0):rest) =+ (\(a,ca)->+ (Just (RespondTimeout a), rest))+ (definite (toInt . fromText) "int" "respondTimeout" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (RespondTimeout a) =+ [CElem (Elem "respondTimeout" [] (toText (fromInt a)))]+instance XmlContent DoneTimeout where+ fromElem (CElem (Elem "doneTimeout" [] c0):rest) =+ (\(a,ca)->+ (Just (DoneTimeout a), rest))+ (definite (toInt . fromText) "int" "doneTimeout" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (DoneTimeout a) =+ [CElem (Elem "doneTimeout" [] (toText (fromInt a)))]+++{-Done-}++++{-Int Conversion-}++fromInt :: Int -> String+fromInt = show++toInt :: (Maybe String, [Content]) -> (Maybe Int, [Content])+toInt (Nothing, rest) = (Nothing, rest)+toInt (Just s, rest) = case reads s of+ [(n, _)] -> (Just n, rest)+ _ -> (Nothing, rest)+++{- Getter -}++getPort :: General -> Int+getPort (General (Port port) _ _) = port++getServerRoot :: General -> FilePath+getServerRoot (General _ (ServerRoot root) _) = root++getPluginLoader :: General -> PluginLoader+getPluginLoader (General _ _ loader) = loader++getIncludePaths :: PluginLoader -> [FilePath]+getIncludePaths (PluginLoader elements _) =+ map (\(IncludePath path) -> path) elements++getPkgConfFiles :: PluginLoader -> [FilePath]+getPkgConfFiles (PluginLoader _ elements) =+ map (\(PkgConfFile file) -> file) elements+++getAppType :: AppConfig -> AppConfig_type+getAppType (AppConfig attrs _ _ _ _ _ _ _ _) =+ fromMaybe AppConfig_type_normal (appConfigType attrs)++getAppAutoStart :: AppConfig -> AppConfig_autoStart+getAppAutoStart (AppConfig attrs _ _ _ _ _ _ _ _) =+ fromMaybe AppConfig_autoStart_yes (appConfigAutoStart attrs)++getAppName :: AppConfig -> String+getAppName (AppConfig _ (Name name) _ _ _ _ _ _ _) = name++getAppDescription :: AppConfig -> String+getAppDescription (AppConfig _ _ (Description description) _ _ _ _ _ _) =+ description++getAppRoot :: AppConfig -> FilePath+getAppRoot (AppConfig _ _ _ (Root root) _ _ _ _ _) = root++getAppCode :: AppConfig -> FilePath+getAppCode (AppConfig _ _ _ _ (Code code) _ _ _ _) = code++getAppContextPath :: AppConfig -> ContextPath+getAppContextPath (AppConfig _ _ _ _ _ (ContextPath contextPath) _ _ _) =+ if "/" `isSuffixOf` contextPath then (ContextPath contextPath)+ else (ContextPath $ contextPath ++ "/")+++getAppInitTimeout :: AppConfig -> Int+getAppInitTimeout (AppConfig _ _ _ _ _ _ (InitTimeout timeout) _ _) = timeout++getAppRespondTimeout :: AppConfig -> Int+getAppRespondTimeout (AppConfig _ _ _ _ _ _ _ (RespondTimeout timeout) _) =+ timeout++getAppDoneTimeout :: AppConfig -> Int+getAppDoneTimeout (AppConfig _ _ _ _ _ _ _ _ (DoneTimeout timeout)) = timeout
+ Hascat/Header.hs view
@@ -0,0 +1,311 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Header+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- Parsing of HTTP headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Hascat.Header (+ -- * Headers+ Headers,+ HeaderName(..),+ HeaderValue(..),+ pHeaders,++ -- * Content-type+ ContentType(..), + getContentType,+ parseContentType,+ showContentType,++ -- * Content-transfer-encoding+ ContentTransferEncoding(..),+ getContentTransferEncoding,++ -- * Content-disposition+ ContentDisposition(..),+ getContentDisposition, + + -- * Utilities+ parseM,+ caseInsensitiveEq,+ caseInsensitiveCompare,+ lexeme, ws1, p_token+ ) where++import Control.Monad+import Data.Char+import Data.Function+import Data.List+import Data.Maybe+import Data.Monoid++import Text.ParserCombinators.Parsec++--+-- * Headers+--++-- | HTTP headers.+type Headers = [(HeaderName, String)]++-- | A string with case insensitive equality and comparisons.+newtype HeaderName = HeaderName String deriving (Show)++instance Eq HeaderName where+ HeaderName x == HeaderName y = map toLower x == map toLower y++instance Ord HeaderName where+ HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y+++class HeaderValue a where+ parseHeaderValue :: Parser a+ prettyHeaderValue :: a -> String++pHeaders :: Parser Headers+pHeaders = many pHeader++pHeader :: Parser (HeaderName, String)+pHeader = + do name <- many1 headerNameChar+ char ':'+ many ws1+ line <- lineString+ crLf+ extraLines <- many extraFieldLine+ return (HeaderName name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = + do sp <- ws1+ line <- lineString+ crLf+ return (sp:line)++getHeaderValue :: (Monad m, HeaderValue a) => String -> Headers -> m a+getHeaderValue h hs = lookupM (HeaderName h) hs >>= parseM parseHeaderValue h++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+ where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+ esc '\\' = "\\\\"+ esc '"' = "\\\""+ esc c | c `elem` ['\\','"'] = '\\':[c]+ | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter = try $+ do lexeme $ char ';'+ p_name <- lexeme $ p_token+ -- Don't allow parameters named q. This is needed for parsing Accept-X + -- headers. From RFC 2616 14.1:+ -- Note: Use of the "q" parameter name to separate media type+ -- parameters from Accept extension parameters is due to historical+ -- practice. Although this prevents any media type parameter named+ -- "q" from being used with a media range, such an event is believed+ -- to be unlikely given the lack of any "q" parameters in the IANA+ -- media type registry and the rare usage of any media type+ -- parameters in Accept. Future media types are discouraged from+ -- registering any parameter named "q".+ when (p_name == "q") pzero+ lexeme $ char '='+ -- Workaround for seemingly standardized web browser bug+ -- where nothing is escaped in the filename parameter+ -- of the content-disposition header in multipart/form-data+ let litStr = if p_name == "filename" + then buggyLiteralString+ else literalString+ p_value <- litStr <|> p_token+ return (map toLower p_name, p_value)++-- +-- * Content type+--++-- | A MIME media type value.+-- The 'Show' instance is derived automatically.+-- Use 'showContentType' to obtain the standard+-- string representation.+-- See <http://www.ietf.org/rfc/rfc2046.txt> for more+-- information about MIME media types.+data ContentType = + ContentType {+ -- | The top-level media type, the general type+ -- of the data. Common examples are+ -- \"text\", \"image\", \"audio\", \"video\",+ -- \"multipart\", and \"application\".+ ctType :: String,+ -- | The media subtype, the specific data format.+ -- Examples include \"plain\", \"html\",+ -- \"jpeg\", \"form-data\", etc.+ ctSubtype :: String,+ -- | Media type parameters. On common example is+ -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+ ctParameters :: [(String, String)]+ }+ deriving (Show, Read)++instance Eq ContentType where+ x == y = ctType x `caseInsensitiveEq` ctType y + && ctSubtype x `caseInsensitiveEq` ctSubtype y + && ctParameters x == ctParameters y++instance Ord ContentType where+ x `compare` y = mconcat [ctType x `caseInsensitiveCompare` ctType y,+ ctSubtype x `caseInsensitiveCompare` ctSubtype y,+ ctParameters x `compare` ctParameters y]++instance HeaderValue ContentType where+ parseHeaderValue = + do many ws1+ c_type <- p_token+ char '/'+ c_subtype <- lexeme $ p_token+ c_parameters <- many p_parameter+ return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters+ prettyHeaderValue (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps+++-- | Parse the standard representation of a content-type.+-- If the input cannot be parsed, this function calls+-- 'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM parseHeaderValue "Content-type"++showContentType :: ContentType -> String+showContentType = prettyHeaderValue++getContentType :: Monad m => Headers -> m ContentType+getContentType = getHeaderValue "content-type"++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+ ContentTransferEncoding String+ deriving (Show, Read, Eq, Ord)++instance HeaderValue ContentTransferEncoding where+ parseHeaderValue = + do many ws1+ c_cte <- p_token+ return $ ContentTransferEncoding (map toLower c_cte)+ prettyHeaderValue (ContentTransferEncoding s) = s++getContentTransferEncoding :: Monad m => Headers -> m ContentTransferEncoding+getContentTransferEncoding = getHeaderValue "content-transfer-encoding"++--+-- * Content disposition+--++data ContentDisposition =+ ContentDisposition String [(String, String)]+ deriving (Show, Read, Eq, Ord)++instance HeaderValue ContentDisposition where+ parseHeaderValue = + do many ws1+ c_cd <- p_token+ c_parameters <- many p_parameter+ return $ ContentDisposition (map toLower c_cd) c_parameters+ prettyHeaderValue (ContentDisposition t hs) = + t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs]+ where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard++getContentDisposition :: Monad m => Headers -> m ContentDisposition+getContentDisposition = getHeaderValue "content-disposition"++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+ case parse p n inp of+ Left e -> fail (show e)+ Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++caseInsensitiveEq :: String -> String -> Bool+caseInsensitiveEq x y = map toLower x == map toLower y++caseInsensitiveCompare :: String -> String -> Ordering+caseInsensitiveCompare x y = map toLower x `compare` map toLower y++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+ str <- many (noneOf "\"\\" <|> quoted_pair)+ char '\"'+ return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = + do char '\"'+ str <- manyTill anyChar (try lastQuote)+ return str+ where lastQuote = do char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++tspecials, tokenchar :: [Char]+tspecials = "()<>@,;:\\\"/[]?="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+ p_text
+ Hascat/Multipart.hs view
@@ -0,0 +1,219 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- orig-Module : Network.CGI.Multipart+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- Parsing of the multipart format from RFC2046.+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Hascat.Multipart + (+ -- * Multi-part messages+ MultiPart(..), BodyPart(..)+ , parseMultipartBody, hGetMultipartBody+ , showMultipartBody+ -- * Headers+ , ContentType(..), ContentTransferEncoding(..)+ , ContentDisposition(..)+ , parseContentType+ , getContentType+ , getContentTransferEncoding+ , getContentDisposition+ ) where++import Control.Monad+import Data.Int (Int64)+import Data.List (intersperse)+import Data.Maybe+import System.IO (Handle)++import Hascat.Header++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++--+-- * Multi-part stuff.+--++data MultiPart = MultiPart [BodyPart]+ deriving (Show, Eq, Ord)++data BodyPart = BodyPart Headers ByteString+ deriving (Show, Eq, Ord)++-- | Read a multi-part message from a 'ByteString'.+parseMultipartBody :: String -- ^ Boundary+ -> ByteString -> MultiPart+parseMultipartBody b = + MultiPart . mapMaybe parseBodyPart . splitParts (BS.pack b)++-- | Read a multi-part message from a 'Handle'.+-- Fails on parse errors.+hGetMultipartBody :: String -- ^ Boundary+ -> Handle+ -> IO MultiPart+hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents++++parseBodyPart :: ByteString -> Maybe BodyPart+parseBodyPart s =+ do+ let (hdr,bdy) = splitAtEmptyLine s+ hs <- parseM pHeaders "<input>" (BS.unpack hdr)+ return $ BodyPart hs bdy++showMultipartBody :: String -> MultiPart -> ByteString+showMultipartBody b (MultiPart bs) = + unlinesCRLF $ foldr (\x xs -> d:showBodyPart x:xs) [c,BS.empty] bs+ where d = BS.pack ("--" ++ b)+ c = BS.pack ("--" ++ b ++ "--") ++showBodyPart :: BodyPart -> ByteString+showBodyPart (BodyPart hs c) = + unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c]+++--+-- * Splitting into multipart parts.+--++-- | Split a multipart message into the multipart parts.+splitParts :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> [ByteString]+splitParts b = spl . dropPreamble b+ where+ spl x = case splitAtBoundary b x of+ Nothing -> []+ Just (s1,d,s2) | isClose b d -> [s1]+ | otherwise -> s1:spl s2++-- | Drop everything up to and including the first line starting +-- with the boundary.+dropPreamble :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> ByteString+dropPreamble b s | BS.null s = BS.empty+ | isBoundary b s = dropLine s+ | otherwise = dropPreamble b (dropLine s)++-- | Split a string at the first boundary line.+splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString,ByteString)+ -- ^ The part before the boundary, the boundary line,+ -- and the part after the boundary line. The CRLF+ -- before and the CRLF (if any) after the boundary line+ -- are not included in any of the strings returned.+ -- Returns 'Nothing' if there is no boundary.+splitAtBoundary b s = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)+ | otherwise -> spl (i+j+l)+ where + s1 = BS.take (i+j) s+ s2 = BS.drop (i+j+l) s+ (d,s3) = splitAtCRLF s2++-- | Check whether a string starts with two dashes followed by+-- the given boundary string.+isBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString+ -> Bool+isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s++-- | Check whether a string for which 'isBoundary' returns true+-- has two dashes after the boudary string.+isClose :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Bool+isClose b s = startsWithDashes (BS.drop (2+BS.length b) s)++-- | Checks whether a string starts with two dashes.+startsWithDashes :: ByteString -> Bool+startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s+++--+-- * RFC 2046 CRLF+--++crlf :: ByteString+crlf = BS.pack "\r\n"++unlinesCRLF :: [ByteString] -> ByteString+unlinesCRLF = BS.concat . intersperse crlf++-- | Drop everything up to and including the first CRLF.+dropLine :: ByteString -> ByteString+dropLine s = snd (splitAtCRLF s)++-- | Split a string at the first empty line. The CRLF (if any) before the+-- empty line is included in the first result. The CRLF after the+-- empty line is not included in the result.+-- If there is no empty line, the entire input is returned+-- as the first result.+splitAtEmptyLine :: ByteString -> (ByteString, ByteString)+splitAtEmptyLine s | startsWithCRLF s = (BS.empty, dropCRLF s)+ | otherwise = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> (s, BS.empty)+ Just (j,l) | startsWithCRLF s2 -> (s1, dropCRLF s2)+ | otherwise -> spl (i+j+l)+ where (s1,s2) = BS.splitAt (i+j+l) s++-- | Split a string at the first CRLF. The CRLF is not included+-- in any of the returned strings.+-- If there is no CRLF, the entire input is returned+-- as the first string.+splitAtCRLF :: ByteString -- ^ String to split.+ -> (ByteString,ByteString)+splitAtCRLF s = case findCRLF s of+ Nothing -> (s,BS.empty)+ Just (i,l) -> (s1, BS.drop l s2)+ where (s1,s2) = BS.splitAt i s++-- | Get the index and length of the first CRLF, if any.+findCRLF :: ByteString -- ^ String to split.+ -> Maybe (Int64,Int64)+findCRLF s = + case findCRorLF s of+ Nothing -> Nothing+ Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)+ Just j -> case (BS.index s j, BS.index s (j+1)) of+ ('\n','\r') -> Just (j,2)+ ('\r','\n') -> Just (j,2)+ _ -> Just (j,1)++findCRorLF :: ByteString -> Maybe Int64+findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s++startsWithCRLF :: ByteString -> Bool+startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')+ where c = BS.index s 0++-- | Drop an initial CRLF, if any. If the string is empty, +-- nothing is done. If the string does not start with CRLF,+-- the first character is dropped.+dropCRLF :: ByteString -> ByteString+dropCRLF s | BS.null s = BS.empty+ | BS.null (BS.drop 1 s) = BS.empty+ | c0 == '\n' && c1 == '\r' = BS.drop 2 s+ | c0 == '\r' && c1 == '\n' = BS.drop 2 s+ | otherwise = BS.drop 1 s+ where c0 = BS.index s 0+ c1 = BS.index s 1
+ Hascat/Protocol.hs view
@@ -0,0 +1,199 @@+-----------------------------------------------------------------------------+-- |+-- orig-Module : Network.CGI.Protocol+-- Copyright : (c) Bjorn Bringert 2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- An implementation of the program side of the CGI protocol.+--+-----------------------------------------------------------------------------++module Hascat.Protocol (+ Input(..), + ServletRequest(..),+ -- * Inputs+ decodeInput, takeInput,+ -- * URL encoding+ formDecode, urlDecode,+ -- * Utilities+ maybeRead, replace+ ) where++import Data.List (intersperse)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe, listToMaybe, isJust)+import Network.URI+import qualified Network.HTTP as HTTP+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import Hascat.Multipart++++data ServletRequest = ServletRequest {+ rqURI :: URI,+ rqMethod :: HTTP.RequestMethod,+ rqHeaders :: [HTTP.Header],+ -- | Input parameters. For better laziness in reading inputs,+ -- this is not a Map.+ rqInputs :: [(String, Input)],+ rqBody :: ByteString+}+ deriving Show++-- | The value of an input parameter, and some metadata.+data Input = Input {+ inputValue :: ByteString,+ inputFilename :: Maybe String,+ inputContentType :: ContentType+ }+ deriving Show++--+-- * Inputs+--++++-- | Gets and decodes the input according to the request+-- method and the content-type.+decodeInput :: HTTP.Request ByteString+ -> ServletRequest+decodeInput req@(HTTP.Request uri method headers inp) =+ let inputs = bodyInput req + in ServletRequest uri method headers (queryInput uri ++ inputs) inp++++-- | Builds an 'Input' object for a simple value.+simpleInput :: String -> Input+simpleInput v = Input { inputValue = BS.pack v,+ inputFilename = Nothing,+ inputContentType = defaultInputType }++-- | The default content-type for variables.+defaultInputType :: ContentType+defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?++--+-- * Query string+--++-- | Gets inputs from the query string.+queryInput :: URI -- ^ + -> [(String,Input)] -- ^ Input variables and values.+queryInput uri = formInput $ + case uriQuery uri of+ '?':str -> str+ str -> str++-- | Decodes application\/x-www-form-urlencoded inputs.+formInput :: String+ -> [(String,Input)] -- ^ Input variables and values.+formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]++--+-- * URL encoding+--+++-- | Gets the name-value pairs from application\/x-www-form-urlencoded data.+formDecode :: String -> [(String,String)]+formDecode "" = []+formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)+ where (nv,rs) = break (=='&') s+ (n,v) = break (=='=') nv++-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding.+urlDecode :: String -> String+urlDecode = unEscapeString . replace '+' ' '++--+-- * Request content and form-data stuff+--++-- | Gets input variables from the body, if any.+bodyInput :: HTTP.Request ByteString+ -> [(String,Input)]+bodyInput req@(HTTP.Request uri method headers inp) =+ case method of+ HTTP.POST -> + let ctype = HTTP.lookupHeader HTTP.HdrContentType headers >>= parseContentType+ in decodeBody ctype $ takeInput headers inp+ _ -> []++-- | Decodes a POST body.+decodeBody :: Maybe ContentType+ -> ByteString+ -> [(String,Input)]+decodeBody ctype inp = + case ctype of+ Just (ContentType "application" "x-www-form-urlencoded" _) + -> formInput (BS.unpack inp)+ Just (ContentType "multipart" "form-data" ps) + -> multipartDecode ps inp+ Just _ -> [] -- unknown content-type, the user will have to+ -- deal with it by looking at the raw content+ -- No content-type given, assume x-www-form-urlencoded+ Nothing -> formInput (BS.unpack inp)++-- | Takes the right number of bytes from the input.+takeInput :: [HTTP.Header] -- ^ + -> ByteString -- ^ Request body.+ -> ByteString -- ^ CONTENT_LENGTH bytes from the request + -- body, or the empty string if there is no+ -- CONTENT_LENGTH.+takeInput headers req = + case len of+ Just l -> BS.take l req+ Nothing -> BS.empty+ where len = HTTP.lookupHeader HTTP.HdrContentLength headers >>= maybeRead++-- | Decodes multipart\/form-data input.+multipartDecode :: [(String,String)] -- ^ Content-type parameters+ -> ByteString -- ^ Request body+ -> [(String,Input)] -- ^ Input variables and values.+multipartDecode ps inp =+ case lookup "boundary" ps of+ Just b -> let MultiPart bs = parseMultipartBody b inp+ in map bodyPartToInput bs+ Nothing -> [] -- FIXME: report that there was no boundary++bodyPartToInput :: BodyPart -> (String,Input)+bodyPartToInput (BodyPart hs b) = + case getContentDisposition hs of+ Just (ContentDisposition "form-data" ps) -> + (lookupOrNil "name" ps,+ Input { inputValue = b,+ inputFilename = lookup "filename" ps,+ inputContentType = ctype })+ _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error+ where ctype = fromMaybe defaultInputType (getContentType hs)+++--+-- * Utilities+--++-- | Replaces all instances of a value in a list by another value.+replace :: Eq a =>+ a -- ^ Value to look for+ -> a -- ^ Value to replace it with+ -> [a] -- ^ Input list+ -> [a] -- ^ Output list+replace x y = map (\z -> if z == x then y else z)++maybeRead :: Read a => String -> Maybe a+maybeRead = fmap fst . listToMaybe . reads++-- | Same as 'lookup' specialized to strings, but +-- returns the empty string if lookup fails.+lookupOrNil :: String -> [(String,String)] -> String+lookupOrNil n = fromMaybe "" . lookup n+
+ Hascat/Toolkit.hs view
@@ -0,0 +1,276 @@+module Hascat.Toolkit+ ( ResponseCode,+ Content(..),+ (//),+ getRelativePath,+ getReason,+ getCodeString,+ getResponse200,+ getResponse303,+ getResponse400,+ getResponse401,+ getResponse404,+ getResponse405,+ getResponse500,+ getResponse503,+ getDirectoryIndex,+ getFileOrDirectoryIndex,+ getFileResponse,+ getFileOrDirectoryIndexResponse,+ getErrorResponse,+ guessContentType,+ HP.ServletRequest(..),+ HP.Input(..),+ module Hascat.App+ )+where++import Control.OldException+import Data.Char+import Data.Maybe+import Data.List+import Hascat.App+import Hascat.Protocol as HP+import Network.HTTP+import Network.URI+import System.Directory+import Text.Html+import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span )+import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span )+++class Show a => Content a where+ toResponse :: ResponseCode -> [Header] -> a -> Response Lazy.ByteString+ ++instance Content Lazy.ByteString where+ toResponse code headers s =+ replaceHeader HdrContentType "text/plain" $+ Response { rspCode = code,+ rspReason = getReason code,+ rspHeaders = headers,+ rspBody = s }++ +instance Content String where+ toResponse code headers s =+ replaceHeader HdrContentType "text/plain" $+ Response { rspCode = code,+ rspReason = getReason code,+ rspHeaders = headers,+ rspBody = Lazy.pack s }+ ++instance Content Html where+ toResponse code headers html =+ replaceHeader HdrContentType "text/html" $+ Response { rspCode = code,+ rspReason = getReason code,+ rspHeaders = headers,+ rspBody = Lazy.pack (show html) }+ ++(//) :: String -> String -> String+"" // "" = ""+"" // path = path+_ // ('/':path) = '/':path+dir // path = if last dir == '/' then dir ++ path+ else dir ++ "/" ++ path+++getRelativePath :: String -> String -> Maybe String+getRelativePath path contextPath =+ let n = length contextPath+ in if take n path == contextPath then Just (drop n path)+ else Nothing+++getReason :: ResponseCode -> String+getReason (1, 0, 0) = "Continue"+getReason (1, 0, 1) = "Switching Protocols"+getReason (2, 0, 0) = "OK"+getReason (2, 0, 1) = "Created"+getReason (2, 0, 2) = "Accepted"+getReason (2, 0, 3) = "Non-Authoritive Information"+getReason (2, 0, 4) = "No Content"+getReason (2, 0, 5) = "Reset Content"+getReason (2, 0, 6) = "Partial Content"+getReason (3, 0, 0) = "Multiple Choices"+getReason (3, 0, 1) = "Moved Permanently"+getReason (3, 0, 2) = "Found"+getReason (3, 0, 3) = "See Other"+getReason (3, 0, 4) = "Not Modified"+getReason (3, 0, 5) = "Use Proxy"+getReason (3, 0, 7) = "Temporary Redirect"+getReason (4, 0, 0) = "Bad Request"+getReason (4, 0, 1) = "Unauthorized"+getReason (4, 0, 2) = "Payment Required"+getReason (4, 0, 3) = "Forbidden"+getReason (4, 0, 4) = "Not Found"+getReason (4, 0, 5) = "Method Not Allowed"+getReason (4, 0, 6) = "Not Acceptable"+getReason (4, 0, 7) = "Proxy Authentication Required"+getReason (4, 0, 8) = "Request Timeout"+getReason (4, 0, 9) = "Conflict"+getReason (4, 1, 0) = "Gone"+getReason (4, 1, 1) = "Length Required"+getReason (4, 1, 2) = "Precondition Failed"+getReason (4, 1, 3) = "Request Entity Too Large"+getReason (4, 1, 4) = "Request-URI Too Long"+getReason (4, 1, 5) = "Unsupported Media Type"+getReason (4, 1, 6) = "Requested Range Not Satisfiable"+getReason (4, 1, 7) = "Expectation Failed"+getReason (5, 0, 0) = "Internal Server Error"+getReason (5, 0, 1) = "Not Implemented"+getReason (5, 0, 2) = "Bad Gateway"+getReason (5, 0, 3) = "Service Unavailable"+getReason (5, 0, 4) = "Gateway Timeout"+getReason (5, 0, 5) = "HTTP Version Not Supported"+++getCodeString :: ResponseCode -> String+getCodeString (a, b, c) = concat (map show [a, b, c])+++getResponse200 :: Content a => a -> Response Lazy.ByteString+getResponse200 content = toResponse (2, 0, 0) [] content+++getResponse303 :: String -> Response Lazy.ByteString+getResponse303 location =+ getErrorResponse (3, 0, 3) [Header HdrLocation location]+ ("If your browser does not support redirection, "+ +++ "please click the following link: "+ +++ hotlink location [toHtml location])+++getResponse400 :: Response Lazy.ByteString+getResponse400 = getErrorResponse (4, 0, 0) [] $ toHtml + "Hascat received a bad request."+++getResponse401 :: String -> Response Lazy.ByteString+getResponse401 auth =+ getErrorResponse (4, 0, 1)+ [Header HdrWWWAuthenticate ("Basic realm=" ++ show auth)] $+ toHtml "Authorization required."+++getResponse404 :: String -> Response Lazy.ByteString+getResponse404 url = getErrorResponse (4, 0, 4) [] $ toHtml+ ("The resource "+ +++ (thespan ! [thestyle "font-style: italic"] << url)+ +++ " could not be found.")+++getResponse405 :: RequestMethod -> Response Lazy.ByteString+getResponse405 method = getErrorResponse (4, 0, 5) [] $ toHtml+ ("Hascat does not support the method " ++ show method)+++getResponse500 :: String -> Response Lazy.ByteString+getResponse500 message = getErrorResponse (5, 0, 0) [] $ toHtml $+ "Hascat could not fulfill the request." ++ message+++getResponse503 :: String -> Response Lazy.ByteString+getResponse503 path = getErrorResponse (5, 0, 3) [] $+ "The application at the context path "+ +++ (thespan ! [thestyle "font-style: italic"] << path)+ +++ " is not running."++++getErrorResponse :: ResponseCode -> [Header] -> Html -> Response Lazy.ByteString+getErrorResponse code headers html = + let title = getReason code ++ " [" ++ getCodeString code ++ "]"+ in toResponse code headers $ + thehtml+ << [header << thetitle << title,+ body+ << [h1 << title,+ paragraph << html]]+++++getDirectoryIndex :: FilePath -> Bool -> IO [String]+getDirectoryIndex path showHidden = do+ contents <- getDirectoryContents path+ return $ sort $ + if showHidden then contents else+ filter (not.isPrefixOf ".") contents++-- Left: file contents, Right: directory listing+getFileOrDirectoryIndex :: FilePath -> Bool -> IO (Either (FilePath,Lazy.ByteString) [String])+getFileOrDirectoryIndex localPath showHidden = do+ isDir <- doesDirectoryExist localPath+ let filePath = if isDir then localPath // "index.html" else localPath+ isFile <- doesFileExist filePath+ if isDir && not isFile then do -- case index.html is not present+ dir <- getDirectoryIndex localPath showHidden+ return $ Right dir+ else do+ file <- Lazy.readFile filePath+ return $ Left (filePath,file)++getFileOrDirectoryIndexResponse :: String -> FilePath -> Maybe String -> Bool -> IO (Response Lazy.ByteString)+getFileOrDirectoryIndexResponse url localPath contentType showHidden =+ handle (\_ -> return $ getResponse404 url) $ do+ either <- getFileOrDirectoryIndex localPath showHidden+ return $ + case either of+ Right dir -> directoryToResponse url dir+ Left (filePath,file) -> fileToResponse file filePath contentType+++getFileResponse :: String -> FilePath -> Maybe String -> IO (Response Lazy.ByteString)+getFileResponse url localPath contentType = do+ handle (\_ -> return $ getResponse404 url) $ do+ either <- getFileOrDirectoryIndex localPath False+ return $ + case either of+ Left (filePath,file) -> fileToResponse file filePath contentType+ _ -> getResponse404 url++directoryToResponse :: String -> [String] -> Response Lazy.ByteString+directoryToResponse url dir = + toResponse (2, 0, 0) [] $ directoryIndexToHtml url dir++fileToResponse :: Lazy.ByteString -> FilePath -> Maybe String -> Response Lazy.ByteString+fileToResponse file localPath contentType = + let code = (2, 0, 0)+ contentTypeString = fromMaybe (guessContentType localPath) contentType+ in Response { rspCode = code,+ rspReason = getReason code,+ rspHeaders = [Header HdrContentType contentTypeString],+ rspBody = file }++directoryIndexToHtml :: String -> [String] -> Html+directoryIndexToHtml url contents = + thehtml+ << [header << thetitle << title,+ body+ << [h1 << title,+ paragraph << listing,+ paragraph << "Hascat web server 0.2"]]+ where+ title = "Directory Index for " ++ url + listing = directoryIndexToHtml' url contents+ directoryIndexToHtml' _ [] = toHtml ""+ directoryIndexToHtml' url (f:fs) = + (anchor ! [href (url // f)] $ toHtml f) +++ br +++ directoryIndexToHtml' url fs+++++guessContentType :: FilePath -> String+guessContentType path | ".txt" `isSuffixOf` path = "text/plain; charset=latin1"+ | ".html" `isSuffixOf` path = "text/html"+ | ".htm" `isSuffixOf` path = "text/html"+ | ".xml" `isSuffixOf` path = "text/xml"+ | ".css" `isSuffixOf` path = "text/css"+ | ".gif" `isSuffixOf` path = "image/gif"+ | ".jpg" `isSuffixOf` path = "image/jpeg"+ | ".jpeg" `isSuffixOf` path = "image/jpeg"+ | otherwise = "application/octet-stream"
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main where++import Distribution.Simple+++main :: IO ()+main = defaultMain
+ hascat-lib.cabal view
@@ -0,0 +1,36 @@+name: hascat-lib+version: 0.2+license: OtherLicense+Build-Type: Simple+license-file: LICENSE+copyright: Björn Teegen 2006, Florian Micheler 2010+author: Björn Teegen, Florian Micheler+maintainer: fmi@informatik.uni-kiel.de+stability: experimental+synopsis: Hascat Package+description: Library for programming Hascat applications+category: Network+tested-with: GHC+build-depends:+ base >=4 && <5,+ network,+ HTTP,+ haskell98,+ HaXml ==1.13.3,+ html ==1.0.1.2,+ directory,+ bytestring,+ containers,+ mtl, + parsec, + xhtml ==3000.2.0.1,+ old-time,+ old-locale,+ plugins+ghc-options: -fglasgow-exts+exposed-modules: Hascat.App,+ Hascat.Config,+ Hascat.Toolkit+ Hascat.Header+ Hascat.Protocol+ Hascat.Multipart