diff --git a/Hascat/App.hs b/Hascat/App.hs new file mode 100644 --- /dev/null +++ b/Hascat/App.hs @@ -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 () diff --git a/Hascat/Config.hs b/Hascat/Config.hs new file mode 100644 --- /dev/null +++ b/Hascat/Config.hs @@ -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 "" "config" ca)) + (definite fromElem "" "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 "" "general" cb)) + (definite fromElem "" "general" ca)) + (definite fromElem "" "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 "" "appConfig" cg)) + (definite fromElem "" "appConfig" cf)) + (definite fromElem "" "appConfig" ce)) + (definite fromElem "" "appConfig" cd)) + (definite fromElem "" "appConfig" cc)) + (definite fromElem "" "appConfig" cb)) + (definite fromElem "" "appConfig" ca)) + (definite fromElem "" "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 diff --git a/Hascat/Header.hs b/Hascat/Header.hs new file mode 100644 --- /dev/null +++ b/Hascat/Header.hs @@ -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 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 diff --git a/Hascat/Multipart.hs b/Hascat/Multipart.hs new file mode 100644 --- /dev/null +++ b/Hascat/Multipart.hs @@ -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 "" (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 diff --git a/Hascat/Protocol.hs b/Hascat/Protocol.hs new file mode 100644 --- /dev/null +++ b/Hascat/Protocol.hs @@ -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 + diff --git a/Hascat/Toolkit.hs b/Hascat/Toolkit.hs new file mode 100644 --- /dev/null +++ b/Hascat/Toolkit.hs @@ -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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple + + +main :: IO () +main = defaultMain diff --git a/hascat-lib.cabal b/hascat-lib.cabal new file mode 100644 --- /dev/null +++ b/hascat-lib.cabal @@ -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