salvia 0.0.5 → 0.1
raw patch · 73 files changed
+2639/−2000 lines, 73 filesdep +fclabelsdep +pureMD5dep −clevercssdep −hscolourdep −nano-md5dep ~parsec
Dependencies added: fclabels, pureMD5
Dependencies removed: clevercss, hscolour, nano-md5, template-haskell
Dependency ranges changed: parsec
Files
- salvia.cabal +37/−37
- src/Data/Record/Label.hs +0/−86
- src/Data/Record/Label/TH.hs +0/−47
- src/Demo.hs +21/−0
- src/Misc/Misc.hs +2/−2
- src/Network/Protocol/Cookie.hs +27/−15
- src/Network/Protocol/Http.hs +44/−348
- src/Network/Protocol/Http/Data.hs +195/−0
- src/Network/Protocol/Http/Parser.hs +63/−0
- src/Network/Protocol/Http/Printer.hs +41/−0
- src/Network/Protocol/Http/Status.hs +163/−0
- src/Network/Protocol/Mime.hs +10/−1
- src/Network/Protocol/Uri.hs +99/−49
- src/Network/Salvia/Advanced/CleverCSS.hs +0/−29
- src/Network/Salvia/Advanced/ExtendedFileSystem.hs +0/−20
- src/Network/Salvia/Advanced/HsColour.hs +0/−54
- src/Network/Salvia/Core/Config.hs +19/−8
- src/Network/Salvia/Core/Context.hs +101/−0
- src/Network/Salvia/Core/Handler.hs +12/−54
- src/Network/Salvia/Core/IO.hs +80/−52
- src/Network/Salvia/Core/Main.hs +38/−5
- src/Network/Salvia/Core/Network.hs +0/−52
- src/Network/Salvia/Handler/Banner.hs +28/−0
- src/Network/Salvia/Handler/CGI.hs +22/−0
- src/Network/Salvia/Handler/Close.hs +51/−0
- src/Network/Salvia/Handler/Cookie.hs +44/−0
- src/Network/Salvia/Handler/Counter.hs +11/−0
- src/Network/Salvia/Handler/Directory.hs +64/−0
- src/Network/Salvia/Handler/Dispatching.hs +48/−0
- src/Network/Salvia/Handler/Environment.hs +78/−0
- src/Network/Salvia/Handler/Error.hs +58/−0
- src/Network/Salvia/Handler/ExtensionDispatcher.hs +21/−0
- src/Network/Salvia/Handler/Fallback.hs +33/−0
- src/Network/Salvia/Handler/File.hs +88/−0
- src/Network/Salvia/Handler/FileSystem.hs +56/−0
- src/Network/Salvia/Handler/Head.hs +23/−0
- src/Network/Salvia/Handler/Log.hs +47/−0
- src/Network/Salvia/Handler/Login.hs +276/−0
- src/Network/Salvia/Handler/MethodRouter.hs +78/−0
- src/Network/Salvia/Handler/Parser.hs +51/−0
- src/Network/Salvia/Handler/PathRouter.hs +45/−0
- src/Network/Salvia/Handler/Printer.hs +15/−0
- src/Network/Salvia/Handler/Put.hs +26/−0
- src/Network/Salvia/Handler/Redirect.hs +18/−0
- src/Network/Salvia/Handler/Rewrite.hs +60/−0
- src/Network/Salvia/Handler/Session.hs +192/−0
- src/Network/Salvia/Handler/VirtualHosting.hs +34/−0
- src/Network/Salvia/Handlers.hs +213/−0
- src/Network/Salvia/Handlers/Banner.hs +0/−26
- src/Network/Salvia/Handlers/CGI.hs +0/−18
- src/Network/Salvia/Handlers/Cookie.hs +0/−37
- src/Network/Salvia/Handlers/Counter.hs +0/−10
- src/Network/Salvia/Handlers/Default.hs +0/−30
- src/Network/Salvia/Handlers/Directory.hs +0/−55
- src/Network/Salvia/Handlers/Dispatching.hs +0/−23
- src/Network/Salvia/Handlers/Error.hs +0/−47
- src/Network/Salvia/Handlers/ExtensionDispatcher.hs +0/−17
- src/Network/Salvia/Handlers/Fallback.hs +0/−25
- src/Network/Salvia/Handlers/File.hs +0/−69
- src/Network/Salvia/Handlers/FileSystem.hs +0/−38
- src/Network/Salvia/Handlers/Head.hs +0/−23
- src/Network/Salvia/Handlers/Log.hs +0/−31
- src/Network/Salvia/Handlers/Login.hs +0/−272
- src/Network/Salvia/Handlers/MethodRouter.hs +0/−42
- src/Network/Salvia/Handlers/Parser.hs +0/−41
- src/Network/Salvia/Handlers/PathRouter.hs +0/−37
- src/Network/Salvia/Handlers/Printer.hs +0/−23
- src/Network/Salvia/Handlers/Put.hs +0/−26
- src/Network/Salvia/Handlers/Redirect.hs +0/−13
- src/Network/Salvia/Handlers/Rewrite.hs +0/−38
- src/Network/Salvia/Handlers/Session.hs +0/−180
- src/Network/Salvia/Handlers/VirtualHosting.hs +0/−16
- src/Network/Salvia/Httpd.hs +7/−4
salvia.cabal view
@@ -1,5 +1,5 @@ Name: salvia-Version: 0.0.5+Version: 0.1 Description: Lightweight Haskell Web Server Framework Synopsis: Lightweight Haskell Web Server Framework Category: Network, Web@@ -11,19 +11,17 @@ Build-Depends: base, bimap, bytestring,- clevercss, containers, directory,- nano-md5,+ pureMD5 == 0.2.4,+ fclabels ==0.1, encoding, filepath,- hscolour, mtl ==1.1.0.2, network, old-locale,- parsec,+ parsec ==3.0.0, process,- template-haskell >= 2.2, random, stm, time,@@ -33,43 +31,45 @@ HS-Source-Dirs: src Other-modules: Misc.Misc, Misc.Terminal,- Data.Record.Label.TH-Exposed-modules: Data.Record.Label,+ Network.Protocol.Http.Data,+ Network.Protocol.Http.Parser,+ Network.Protocol.Http.Printer,+ Network.Protocol.Http.Status+Exposed-modules: Demo, Network.Protocol.Cookie, Network.Protocol.Http, Network.Protocol.Mime, Network.Protocol.Uri,- Network.Salvia.Httpd, Network.Salvia.Core.Config,+ Network.Salvia.Core.Context, Network.Salvia.Core.Handler, Network.Salvia.Core.IO, Network.Salvia.Core.Main,- Network.Salvia.Core.Network,- Network.Salvia.Handlers.Banner,- Network.Salvia.Handlers.CGI,- Network.Salvia.Handlers.Cookie,- Network.Salvia.Handlers.Counter,- Network.Salvia.Handlers.Default,- Network.Salvia.Handlers.Directory,- Network.Salvia.Handlers.Dispatching,- Network.Salvia.Handlers.Error,- Network.Salvia.Handlers.ExtensionDispatcher,- Network.Salvia.Handlers.Fallback,- Network.Salvia.Handlers.File,- Network.Salvia.Handlers.FileSystem,- Network.Salvia.Handlers.Head,- Network.Salvia.Handlers.Log,- Network.Salvia.Handlers.Login,- Network.Salvia.Handlers.MethodRouter,- Network.Salvia.Handlers.Parser,- Network.Salvia.Handlers.PathRouter,- Network.Salvia.Handlers.Printer,- Network.Salvia.Handlers.Put,- Network.Salvia.Handlers.Redirect,- Network.Salvia.Handlers.Rewrite,- Network.Salvia.Handlers.Session,- Network.Salvia.Handlers.VirtualHosting,- Network.Salvia.Advanced.CleverCSS,- Network.Salvia.Advanced.ExtendedFileSystem,- Network.Salvia.Advanced.HsColour+ Network.Salvia.Handler.Banner,+ Network.Salvia.Handler.CGI,+ Network.Salvia.Handler.Close,+ Network.Salvia.Handler.Cookie,+ Network.Salvia.Handler.Counter,+ Network.Salvia.Handler.Directory,+ Network.Salvia.Handler.Dispatching,+ Network.Salvia.Handler.Environment,+ Network.Salvia.Handler.Error,+ Network.Salvia.Handler.ExtensionDispatcher,+ Network.Salvia.Handler.Fallback,+ Network.Salvia.Handler.File,+ Network.Salvia.Handler.FileSystem,+ Network.Salvia.Handler.Head,+ Network.Salvia.Handler.Log,+ Network.Salvia.Handler.Login,+ Network.Salvia.Handler.MethodRouter,+ Network.Salvia.Handler.Parser,+ Network.Salvia.Handler.PathRouter,+ Network.Salvia.Handler.Printer,+ Network.Salvia.Handler.Put,+ Network.Salvia.Handler.Redirect,+ Network.Salvia.Handler.Rewrite,+ Network.Salvia.Handler.Session,+ Network.Salvia.Handler.VirtualHosting,+ Network.Salvia.Handlers+ Network.Salvia.Httpd
− src/Data/Record/Label.hs
@@ -1,86 +0,0 @@-module Data.Record.Label (- Getter, Setter, Modifier- , Label (..)- , lmod- , (%), comp- , getM, setM, modM- , bothM- , enterM, enterMT- , withM, localM- , list- , module Data.Record.Label.TH- ) where--import Control.Monad.State-import Data.Record.Label.TH--type Getter a b = a -> b-type Setter a b = b -> a -> a-type Modifier a b = (b -> b) -> a -> a--data Label a b = Label {- lget :: Getter a b- , lset :: Setter a b- }--lmod :: Label a b -> Modifier a b-lmod l f a = lset l (f (lget l a)) a--infixr 8 %--(%) :: Label t a -> Label b t -> Label b a-a % b = Label (lget a . lget b) (lmod b . lset a)---- Apply custom `parser' and 'printer' function.--comp :: (b -> c) -> (c -> b) -> Label t b -> Label t c-comp f g (Label a b) = Label (f . a) (\v -> b $ g v)---- Extend the state monad with support for labels.--getM :: MonadState s m => Label s b -> m b-getM = gets . lget--setM :: MonadState s m => Label s b -> b -> m ()-setM l = modify . lset l--modM :: MonadState s m => Label s b -> (b -> b) -> m ()-modM l = modify . lmod l---- Run a state computation for a sub element updating this part of the state afterwards.--enterM :: MonadState s m => Label s b -> State b a -> m a-enterM l c = do- b <- getM l- let (a, s) = runState c b- setM l s- return a--enterMT :: (MonadState s (t m), MonadTrans t, Monad m) => Label s b -> StateT b m a -> t m a-enterMT l c = do- b <- getM l- (a, s) <- lift $ runStateT c b- setM l s- return a--bothM :: MonadState s m => Label s b -> State b a -> m (b, a)-bothM parent cmp = do- p <- getM parent- c <- enterM parent cmp- return (p, c)--localM :: MonadState s m => Label s b -> m c -> m c-localM l c = do- k <- getM l- c' <- c- setM l k- return c'--withM :: MonadState s m => Label s b -> State b a -> m c -> m c-withM l c d = localM l (enterM l c >> d)---- Lift list indexing to a label.--list :: Int -> Label [a] a-list i = Label (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)-
− src/Data/Record/Label/TH.hs
@@ -1,47 +0,0 @@-module Data.Record.Label.TH (mkLabels) where--import Control.Monad (liftM)-import Data.Char (toLower, toUpper)-import Language.Haskell.TH ( Body (NormalB)- , Clause (Clause)- , Con (RecC)- , Dec (DataD, FunD)- , Exp (AppE, ConE, LamE, RecUpdE, VarE)- , Info (TyConI)- , Name- , Pat (VarP)- , Q- , mkName- , nameBase- , reify)-import Language.Haskell.TH.Syntax (VarStrictType)--mkLabels :: [Name] -> Q [Dec]-mkLabels = liftM concat . mapM mkLabels1--mkLabels1 :: Name -> Q [Dec]-mkLabels1 n = do- i <- reify n- let cs' = case i of- TyConI (DataD _ _ _ cs _) -> cs -- only process data declarations- _ -> []- ls' = [ l | (RecC _ ls) <- cs', l <- ls ] -- we're only interested in labels of record constructors- return $ map mkLabel ls'--mkLabel :: VarStrictType -> Dec-mkLabel (name, _, _) =- -- Generate a name for the label:- -- * If the original selector starts with an _, remove it and make- -- the next character lowercase.- -- * Otherwise, add 'l', and make the next character uppercase.- let n = mkName $ case nameBase name of- ('_' : c : rest) -> toLower c : rest- (f : rest) -> 'l' : toUpper f : rest- [] -> error "Data.Record.Label.TH: this should not happen."- in FunD n [Clause [] (NormalB (- AppE (AppE (ConE (mkName "Label"))- (VarE name)) -- getter- (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter- (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))- )) []]-
+ src/Demo.hs view
@@ -0,0 +1,21 @@+module Demo where++import Network.Socket+import Network.Salvia.Httpd+import Network.Salvia.Handlers++-- Serve the current directory.++main :: IO ()+main = do+ conf <- defaultConfig+ addr <- inet_addr "127.0.0.1"+ start + (conf { listenAddr = addr, listenPort = 8080 })+ (hDefaultEnv myHandler)++-- Serve the current directory.++myHandler :: Handler ()+myHandler = hFileSystem "."+
src/Misc/Misc.hs view
@@ -121,13 +121,13 @@ pMaybe = option Nothing . liftM Just -- Make parsec both applicative and alternative.-instance Applicative (GenParser s a) where+{-instance Applicative (GenParser s a) where pure = return (<*>) = ap instance Alternative (GenParser s a) where empty = mzero- (<|>) = mplus+ (<|>) = mplus-} -------[ time utils ]----------------------------------------------------------
src/Network/Protocol/Cookie.hs view
@@ -1,3 +1,7 @@+{- |+For more information: http://www.ietf.org/rfc/rfc2109.txt+-}+ module Network.Protocol.Cookie ( Cookie (..) , empty@@ -19,10 +23,11 @@ import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) import qualified Data.Map as M --- For more information:--- http://www.ietf.org/rfc/rfc2109.txt --------[ HTTP cookie data type ]-----------------------------------------------+{- |+The `Cookie` data type containg one key/value pair with all the (potentially+optional) meta-data.+-} data Cookie = Cookie {@@ -40,7 +45,8 @@ , version :: Int } --- Create an empty cookie.+{- | Create an empty cookie. -}+ empty :: Cookie empty = Cookie { name = ""@@ -57,16 +63,23 @@ , version = 0 } --- A set of multiple cookies. These can all be set in one single HTTP--- Set-Cookie header field.+{- |+A collection of multiple cookies. These can all be set in one single HTTP+/Set-Cookie/ header field.+-} type Cookies = M.Map String Cookie --- Convert a list of cookies into a cookie mapping. The name will be used as--- the key, the cookie itself as the value.+{- |+Convert a list of cookies into a cookie mapping. The name will be used as the+key, the cookie itself as the value.+-}+ cookies :: [Cookie] -> Cookies cookies = M.fromList . map (\a -> (name a, a)) +{- | Case-insensitive way of getting a cookie out of a collection by name. -}+ cookie :: String -> Cookies -> Maybe Cookie cookie n = M.lookup (map toLower n) @@ -104,7 +117,8 @@ optval 0 = Nothing optval i = Just (show i) --- Show multiple cookies, pretty printed using a comma separator.+{- | Show multiple cookies, pretty printed using a comma separator. -}+ showCookies :: Cookies -> String showCookies = ($"") . intersperseS (showString ", ")@@ -113,16 +127,14 @@ -------[ cookie parser ]------------------------------------------------------- --- The top-level cookie parser. This parser will return just a mapping of--- cookies or nothing on failure.-parseCookies :: String -> Maybe Cookies-parseCookies = fmap cookies . (pCookie @@)--{-+{- | Parse a set of cookie values and turn this into a collection of real cookies. As the specification states, only the name, value, domain, path and port will be recognized. -}++parseCookies :: String -> Maybe Cookies+parseCookies = fmap cookies . (pCookie @@) pCookie :: GenParser Char st [Cookie] pCookie = map ck <$> pCookieValues
src/Network/Protocol/Http.hs view
@@ -1,377 +1,73 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}- module Network.Protocol.Http( - Status (..)- , Method (..)+ -- * HTTP message data types.++ Method (..) , methods- , Version+ , Version (Version)+ , HeaderKey+ , HeaderValue , Headers- , Direction- , Message+ , Direction (Request, Response)+ , Message (Message) + -- * Creating (parts of) messages.++ , emptyRequest+ , emptyResponse+ , http10+ , http11++ -- * Accessing fields.+ , major , minor+ , body+ , headers+ , version+ , direction , method , uri , status- , direction- , version- , headers- , body - , utf8- , http10- , http11- , emptyRequest- , emptyResponse+ -- * Accessing specific header fields. , normalizeHeader , header++ , utf8++ , connection , contentLength- , keepAlive- , cookie- , location , contentType+ , cookie , date- , server , hostname+ , keepAlive+ , location+ , server - , pRequest- , pResponse+ -- * Parsing HTTP messages. - , showVersion- , showHeaders+ , parseRequest+ , parseResponse++ -- * Printing HTTP messages.+ , showMessageHeader + -- * Handling HTTP status codes.++ , Status (..) , statusCodes , statusFailure , statusFromCode , codeFromStatus- ) where -import Control.Applicative hiding (empty)-import Data.Char-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Data.Record.Label-import Misc.Misc-import Network.Protocol.Uri (URI, mkURI, pUriReference, parseURI)-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))-import qualified Data.Bimap as Bm-import qualified Data.Map as M---------- HTTP message data-types ------------------------------------------------data Status =- Continue | SwitchingProtocols- | OK | Created- | Accepted | NonAuthoritativeInformation- | NoContent | ResetContent- | PartialContent | MultipleChoices- | MovedPermanently | Found- | SeeOther | NotModified- | UseProxy | TemporaryRedirect- | BadRequest | Unauthorized- | PaymentRequired | Forbidden- | NotFound | MethodNotAllowed- | NotAcceptable | ProxyAuthenticationRequired- | RequestTimeOut | Conflict- | Gone | LengthRequired- | PreconditionFailed | RequestEntityTooLarge- | RequestURITooLarge | UnsupportedMediaType- | RequestedRangeNotSatisfiable | ExpectationFailed- | InternalServerError | NotImplemented- | BadGateway | ServiceUnavailable- | GatewayTimeOut | HTTPVersionNotSupported- | CustomStatus Int- deriving (Eq, Ord)--data Method =- OPTIONS- | GET- | HEAD- | POST- | PUT- | DELETE- | TRACE- | CONNECT- deriving (Show, Eq)--methods :: [Method]-methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]--data Version = Version {_major :: Int, _minor :: Int}--type HeaderKey = String-type HeaderValue = String-type Headers = M.Map HeaderKey HeaderValue--data Direction =- Request {__method :: Method, __uri :: URI}- | Response {__status :: Status}--data Message =- Message {- _direction :: Direction- , _version :: Version- , _headers :: Headers- , _body :: String- }--$(mkLabels [''Version, ''Direction, ''Message])--major :: Label Version Int-minor :: Label Version Int-body :: Label Message String-headers :: Label Message Headers-version :: Label Message Version-direction :: Label Message Direction-_status :: Label Direction Status-_uri :: Label Direction URI-_method :: Label Direction Method---- Public labels based on private labels.--method :: Label Message Method-method = _method % direction--uri :: Label Message URI-uri = _uri % direction--status :: Label Message Status-status = _status % direction---- More advanced labels.--normalizeHeader :: String -> String-normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-')--header :: HeaderKey -> Label Message HeaderValue-header key =- Label {- lget = maybe "" id . M.lookup (normalizeHeader key) . lget headers- , lset = lmod headers . M.insert (normalizeHeader key)- }--contentLength :: Label Message (Maybe Integer)-contentLength = comp safeRead (maybe "" show) (header "Content-Length")--keepAlive :: Label Message (Maybe Integer)-keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")--cookie :: Label Message String-cookie =- Label {- lget = lget (header "Cookie")- , lset = lset (header "Set-Cookie")- }--location :: Label Message (Maybe URI)-location =- Label {- lget = parseURI . lget (header "Location")- , lset = lset (header "Location") . maybe "" show- }--contentType :: Label Message (String, Maybe String)-contentType = comp pa pr (header "Content-Length")- where pr (t, c) = t ++ maybe "" ("; charset="++) c- pa = error "no getter for contentType yet"--date :: Label Message String-date = header "Date"--hostname :: Label Message String-hostname = header "Host"--server :: Label Message String-server = header "Server"---- Create HTTP versions.-http10, http11 :: Version-http10 = Version 1 0-http11 = Version 1 1--emptyRequest :: Message-emptyRequest = Message (Request GET (mkURI)) http11 M.empty ""--emptyResponse :: Message-emptyResponse = Message (Response OK) http11 M.empty ""--utf8 :: String-utf8 = "utf-8"---------- HTTP message parsing ----------------------------------------------------- todo: cleanup ugly code--lf, ws, ls :: String-lf = "\r\n"-ws = " \t\r\n"-ls = " \t"--pLf :: GenParser Char st Char-pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'--pVersion :: GenParser Char st Version-pVersion = - (\h l -> Version (ord h - ord '0') (ord l - ord '0'))- <$> (string "HTTP/" *> digit)- <*> (char '.' *> digit)--pHeaders :: GenParser Char st Headers-pHeaders = M.insert- <$> many1 (noneOf (':':ws)) <* string ":"- <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))- <*> option M.empty pHeaders--pMethod :: GenParser Char st Method-pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods--pRequest :: GenParser Char st Message-pRequest = (\m u v h b -> Message (Request m u) v h b)- <$> (pMethod <* many1 (oneOf ls))- <*> (pUriReference <* many1 (oneOf ls))- <*> (pVersion <* pLf)- <*> (pHeaders <* pLf)- <*> (many anyToken)--pResponse :: GenParser Char st Message-pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)- <$> (pVersion <* many1 (oneOf ls))- <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)- <*> (pHeaders <* pLf)- <*> (many anyToken)---------- HTTP message pretty printing -------------------------------------------showVersion :: Version -> String-showVersion (Version a b) = concat ["HTTP/", show a, ".", show b]--showHeaders :: Headers -> String-showHeaders =- intercalate lf- . M.elems- . M.mapWithKey (\k a -> k ++ ": " ++ a)--showMessageHeader :: Message -> String-showMessageHeader (Message (Response s) v hs _) =- concat [- showVersion v, " "- , maybe "Unknown status" show- $ Bm.lookupR s statusCodes, " "- , show s, lf- , showHeaders hs, lf, lf- ]-showMessageHeader (Message (Request m u) v hs _) =- concat [show m, " ", show u, " ", showVersion v, lf, showHeaders hs, lf, lf]--instance Show Message where- show m = concat [showMessageHeader m, lget body m]---------- status code mappings ----------------------------------------------------- rfc2616 sec6.1.1 Status Code and Reason Phrase-statusCodes :: Bm.Bimap Int Status-statusCodes = Bm.fromList [- (100, Continue)- , (101, SwitchingProtocols)- , (200, OK)- , (201, Created)- , (202, Accepted)- , (203, NonAuthoritativeInformation)- , (204, NoContent)- , (205, ResetContent)- , (206, PartialContent)- , (300, MultipleChoices)- , (301, MovedPermanently)- , (302, Found)- , (303, SeeOther)- , (304, NotModified)- , (305, UseProxy)- , (307, TemporaryRedirect)- , (400, BadRequest)- , (401, Unauthorized)- , (402, PaymentRequired)- , (403, Forbidden)- , (404, NotFound)- , (405, MethodNotAllowed)- , (406, NotAcceptable)- , (407, ProxyAuthenticationRequired)- , (408, RequestTimeOut)- , (409, Conflict)- , (410, Gone)- , (411, LengthRequired)- , (412, PreconditionFailed)- , (413, RequestEntityTooLarge)- , (414, RequestURITooLarge)- , (415, UnsupportedMediaType)- , (416, RequestedRangeNotSatisfiable)- , (417, ExpectationFailed)- , (500, InternalServerError)- , (501, NotImplemented)- , (502, BadGateway)- , (503, ServiceUnavailable)- , (504, GatewayTimeOut)- , (505, HTTPVersionNotSupported)- ]---- rfc2616 sec6.1.1 Status Code and Reason Phrase--instance Show Status where- show Continue = "Continue"- show SwitchingProtocols = "Switching Protocols"- show OK = "OK"- show Created = "Created"- show Accepted = "Accepted"- show NonAuthoritativeInformation = "Non-Authoritative Information"- show NoContent = "No Content"- show ResetContent = "Reset Content"- show PartialContent = "Partial Content"- show MultipleChoices = "Multiple Choices"- show MovedPermanently = "Moved Permanently"- show Found = "Found"- show SeeOther = "See Other"- show NotModified = "Not Modified"- show UseProxy = "Use Proxy"- show TemporaryRedirect = "Temporary Redirect"- show BadRequest = "Bad Request"- show Unauthorized = "Unauthorized"- show PaymentRequired = "Payment Required"- show Forbidden = "Forbidden"- show NotFound = "Not Found"- show MethodNotAllowed = "Method Not Allowed"- show NotAcceptable = "Not Acceptable"- show ProxyAuthenticationRequired = "Proxy Authentication Required"- show RequestTimeOut = "Request Time-out"- show Conflict = "Conflict"- show Gone = "Gone"- show LengthRequired = "Length Required"- show PreconditionFailed = "Precondition Failed"- show RequestEntityTooLarge = "Request Entity Too Large"- show RequestURITooLarge = "Request-URI Too Large"- show UnsupportedMediaType = "Unsupported Media Type"- show RequestedRangeNotSatisfiable = "Requested range not satisfiable"- show ExpectationFailed = "Expectation Failed"- show InternalServerError = "Internal Server Error"- show NotImplemented = "Not Implemented"- show BadGateway = "Bad Gateway"- show ServiceUnavailable = "Service Unavailable"- show GatewayTimeOut = "Gateway Time-out"- show HTTPVersionNotSupported = "HTTP Version not supported"- show (CustomStatus _) = "Unknown Status"--statusFailure :: Status -> Bool-statusFailure st = codeFromStatus st >= 400--statusFromCode :: Int -> Status-statusFromCode num =- fromMaybe (CustomStatus num)- $ Bm.lookup num statusCodes+ ) where -codeFromStatus :: Status -> Int-codeFromStatus st =- fromMaybe 0 -- total, should not happen- $ Bm.lookupR st statusCodes+import Network.Protocol.Http.Data+import Network.Protocol.Http.Parser+import Network.Protocol.Http.Printer+import Network.Protocol.Http.Status
+ src/Network/Protocol/Http/Data.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE TemplateHaskell #-}+module Network.Protocol.Http.Data where++import Data.List (intercalate)+import Data.Map (lookup, insert, Map, empty)+import Data.Record.Label+import Misc.Misc (safeRead, normalCase, split)+import Network.Protocol.Http.Status (Status (..))+import Network.Protocol.Uri+import Prelude hiding (lookup)++{- | List of HTTP request methods. -}++data Method =+ OPTIONS+ | GET+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | CONNECT+ deriving (Show, Eq)++{- | All `Method` constructors as a list. -}++methods :: [Method]+methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]++{- | HTTP protocol version. -}++data Version = Version {_major :: Int, _minor :: Int}++{- | Create HTTP 1.0 version. -}++http10 :: Version+http10 = Version 1 0++{- | Create HTTP 1.1 version. -}++http11 :: Version+http11 = Version 1 1++type HeaderKey = String+type HeaderValue = String++{- | HTTP headers as mapping from keys to values. -}++type Headers = Map HeaderKey HeaderValue++{- | Request or response specific part of HTTP messages. -}++data Direction =+ Request {__method :: Method, __uri :: URI}+ | Response {__status :: Status}++{- | An HTTP message. -}++data Message =+ Message {+ _direction :: Direction+ , _version :: Version+ , _headers :: Headers+ , _body :: String+ }++{- | Create an empty HTTP request object. -}++emptyRequest :: Message+emptyRequest = Message (Request GET (mkURI)) http11 empty ""++{- | Create an empty HTTP response object. -}++emptyResponse :: Message+emptyResponse = Message (Response OK) http11 empty ""++$(mkLabels [''Version, ''Direction, ''Message])++{- | Label to access the major part of the version. -}++major :: Label Version Int++{- | Label to access the minor part of the version. -}++minor :: Label Version Int++_status :: Label Direction Status+_uri :: Label Direction URI+_method :: Label Direction Method++{- | Label to access the body part of an HTTP message. -}++body :: Label Message String++{- | Label to access the header of an HTTP message. -}++headers :: Label Message Headers++{- | Label to access the version part of an HTTP message. -}++version :: Label Message Version++{- | Label to access the direction part of an HTTP message. -}++direction :: Label Message Direction++{- | Label to access the method part of an HTTP message. -}++method :: Label Message Method+method = _method % direction++{- | Label to access the URI part of an HTTP message. -}++uri :: Label Message URI+uri = _uri % direction++{- | Label to access the status part of an HTTP message. -}++status :: Label Message Status+status = _status % direction++++++{- | Normalize the capitalization of an HTTP header key. -}++normalizeHeader :: String -> String+normalizeHeader = (intercalate "-") . (map normalCase) . (split '-')++{- | Generic label to access an HTTP header field by key. -}++header :: HeaderKey -> Label Message HeaderValue+header key =+ Label {+ lget = maybe "" id . lookup (normalizeHeader key) . lget headers+ , lset = lmod headers . insert (normalizeHeader key)+ }++{- | Simply /utf-8/. -}++utf8 :: String+utf8 = "utf-8"++{- | Access the /Content-Length/ header field. -}++contentLength :: (Read i, Integral i) => Label Message (Maybe i)+contentLength = comp safeRead (maybe "" show) (header "Content-Length")++{- | Access the /Connection/ header field. -}++connection :: Label Message String+connection = header "Connection"++{- | Access the /Keep-Alive/ header field. -}++keepAlive :: (Read i, Integral i) => Label Message (Maybe i)+keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")++{- | Access the /Cookie/ and /Set-Cookie/ header fields. -}++cookie :: Label Message String+cookie = Label (lget $ header "Cookie") (lset $ header "Set-Cookie")++{- | Access the /Location/ header field. -}++location :: Label Message (Maybe URI)+location = Label+ (parseURI . lget (header "Location"))+ (lset (header "Location") . maybe "" show)++{- | Access the /Content-Type/ header field. -}++contentType :: Label Message (String, Maybe String)+contentType = comp pa pr (header "Content-Type")+ where pr (t, c) = t ++ maybe "" ("; charset="++) c+ pa = error "no getter for contentType yet"++{- | Access the /Data/ header field. -}++date :: Label Message String+date = header "Date"++{- | Access the /Host/ header field. -}++hostname :: Label Message (Maybe Authority)+hostname = Label+ (parseAuthority . lget (header "Host"))+ (lset (header "Host") . maybe "" show)++{- | Access the /Server/ header field. -}++server :: Label Message String+server = header "Server"+
+ src/Network/Protocol/Http/Parser.hs view
@@ -0,0 +1,63 @@+module Network.Protocol.Http.Parser (+ parseRequest+ , parseResponse+ ) where++import Control.Applicative hiding (empty)+import Data.Char (ord)+import Data.List (intercalate)+import Data.Map (insert, empty)+import Misc.Misc (pMaybe)+import Network.Protocol.Http.Data+import Network.Protocol.Http.Status+import Network.Protocol.Uri (pUriReference)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))++{- | Parse a string as an HTTP request message. -}++parseRequest :: String -> Either ParseError Message+parseRequest msg = parse pRequest "" msg++{- | Parse a string as an HTTP request message. -}++parseResponse :: String -> Either ParseError Message+parseResponse msg = parse pResponse "" msg++lf, ws, ls :: String+lf = "\r\n"+ws = " \t\r\n"+ls = " \t"++pLf :: GenParser Char st Char+pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'++pVersion :: GenParser Char st Version+pVersion = + (\h l -> Version (ord h - ord '0') (ord l - ord '0'))+ <$> (string "HTTP/" *> digit)+ <*> (char '.' *> digit)++pHeaders :: GenParser Char st Headers+pHeaders = insert+ <$> many1 (noneOf (':':ws)) <* string ":"+ <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))+ <*> option empty pHeaders++pMethod :: GenParser Char st Method+pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods++pRequest :: GenParser Char st Message+pRequest = (\m u v h b -> Message (Request m u) v h b)+ <$> (pMethod <* many1 (oneOf ls))+ <*> (pUriReference <* many1 (oneOf ls))+ <*> (pVersion <* pLf)+ <*> (pHeaders <* pLf)+ <*> (many anyToken)++pResponse :: GenParser Char st Message+pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)+ <$> (pVersion <* many1 (oneOf ls))+ <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)+ <*> (pHeaders <* pLf)+ <*> (many anyToken)+
+ src/Network/Protocol/Http/Printer.hs view
@@ -0,0 +1,41 @@+{- | Provides the `Show` instance for an HTTP `Message`. -}++module Network.Protocol.Http.Printer (showMessageHeader) where++import Data.Bimap (lookupR)+import Data.List (intercalate)+import Data.Map (elems, mapWithKey)+import Data.Record.Label (lget)+import Network.Protocol.Http.Data+import Network.Protocol.Http.Status++lf :: String+lf = "\r\n"++instance Show Version where+ show (Version a b) = concat ["HTTP/", show a, ".", show b]++showHeaders :: Headers -> String+showHeaders =+ intercalate lf+ . elems+ . mapWithKey (\k a -> k ++ ": " ++ a)++{- | Helper function that only prints the header part of an HTTP message. -}++showMessageHeader :: Message -> String+showMessageHeader (Message (Response s) v hs _) =+ concat [+ show v, " "+ , maybe "Unknown status" show+ $ lookupR s statusCodes, " "+ , show s, lf+ , showHeaders hs, lf, lf+ ]++showMessageHeader (Message (Request m u) v hs _) =+ concat [show m, " ", show u, " ", show v, lf, showHeaders hs, lf, lf]++instance Show Message where+ show m = concat [showMessageHeader m, lget body m]+
+ src/Network/Protocol/Http/Status.hs view
@@ -0,0 +1,163 @@+module Network.Protocol.Http.Status where++import Data.Bimap (Bimap, fromList, lookup, lookupR)+import Data.Maybe (fromMaybe)+import Prelude hiding (lookup)++{- | HTTP status codes. -}++data Status =+ Continue -- ^ 100+ | SwitchingProtocols -- ^ 101+ | OK -- ^ 200+ | Created -- ^ 201+ | Accepted -- ^ 202+ | NonAuthoritativeInformation -- ^ 203+ | NoContent -- ^ 204+ | ResetContent -- ^ 205+ | PartialContent -- ^ 206+ | MultipleChoices -- ^ 300+ | MovedPermanently -- ^ 301+ | Found -- ^ 302+ | SeeOther -- ^ 303+ | NotModified -- ^ 304+ | UseProxy -- ^ 305+ | TemporaryRedirect -- ^ 307+ | BadRequest -- ^ 400+ | Unauthorized -- ^ 401+ | PaymentRequired -- ^ 402+ | Forbidden -- ^ 403+ | NotFound -- ^ 404+ | MethodNotAllowed -- ^ 405+ | NotAcceptable -- ^ 406+ | ProxyAuthenticationRequired -- ^ 407+ | RequestTimeOut -- ^ 408+ | Conflict -- ^ 409+ | Gone -- ^ 410+ | LengthRequired -- ^ 411+ | PreconditionFailed -- ^ 412+ | RequestEntityTooLarge -- ^ 413+ | RequestURITooLarge -- ^ 414+ | UnsupportedMediaType -- ^ 415+ | RequestedRangeNotSatisfiable -- ^ 416+ | ExpectationFailed -- ^ 417+ | InternalServerError -- ^ 500+ | NotImplemented -- ^ 501+ | BadGateway -- ^ 502+ | ServiceUnavailable -- ^ 503+ | GatewayTimeOut -- ^ 504+ | HTTPVersionNotSupported -- ^ 505+ | CustomStatus Int+ deriving (Eq, Ord)++{- | rfc2616 sec6.1.1 Status Code and Reason Phrase. -}++instance Show Status where+ show Continue = "Continue"+ show SwitchingProtocols = "Switching Protocols"+ show OK = "OK"+ show Created = "Created"+ show Accepted = "Accepted"+ show NonAuthoritativeInformation = "Non-Authoritative Information"+ show NoContent = "No Content"+ show ResetContent = "Reset Content"+ show PartialContent = "Partial Content"+ show MultipleChoices = "Multiple Choices"+ show MovedPermanently = "Moved Permanently"+ show Found = "Found"+ show SeeOther = "See Other"+ show NotModified = "Not Modified"+ show UseProxy = "Use Proxy"+ show TemporaryRedirect = "Temporary Redirect"+ show BadRequest = "Bad Request"+ show Unauthorized = "Unauthorized"+ show PaymentRequired = "Payment Required"+ show Forbidden = "Forbidden"+ show NotFound = "Not Found"+ show MethodNotAllowed = "Method Not Allowed"+ show NotAcceptable = "Not Acceptable"+ show ProxyAuthenticationRequired = "Proxy Authentication Required"+ show RequestTimeOut = "Request Time-out"+ show Conflict = "Conflict"+ show Gone = "Gone"+ show LengthRequired = "Length Required"+ show PreconditionFailed = "Precondition Failed"+ show RequestEntityTooLarge = "Request Entity Too Large"+ show RequestURITooLarge = "Request-URI Too Large"+ show UnsupportedMediaType = "Unsupported Media Type"+ show RequestedRangeNotSatisfiable = "Requested range not satisfiable"+ show ExpectationFailed = "Expectation Failed"+ show InternalServerError = "Internal Server Error"+ show NotImplemented = "Not Implemented"+ show BadGateway = "Bad Gateway"+ show ServiceUnavailable = "Service Unavailable"+ show GatewayTimeOut = "Gateway Time-out"+ show HTTPVersionNotSupported = "HTTP Version not supported"+ show (CustomStatus _) = "Unknown Status"++{- |+RFC2616 sec6.1.1 Status Code and Reason Phrase.++Bidirectional mapping from status numbers to codes.+-}++statusCodes :: Bimap Int Status+statusCodes = fromList [+ (100, Continue)+ , (101, SwitchingProtocols)+ , (200, OK)+ , (201, Created)+ , (202, Accepted)+ , (203, NonAuthoritativeInformation)+ , (204, NoContent)+ , (205, ResetContent)+ , (206, PartialContent)+ , (300, MultipleChoices)+ , (301, MovedPermanently)+ , (302, Found)+ , (303, SeeOther)+ , (304, NotModified)+ , (305, UseProxy)+ , (307, TemporaryRedirect)+ , (400, BadRequest)+ , (401, Unauthorized)+ , (402, PaymentRequired)+ , (403, Forbidden)+ , (404, NotFound)+ , (405, MethodNotAllowed)+ , (406, NotAcceptable)+ , (407, ProxyAuthenticationRequired)+ , (408, RequestTimeOut)+ , (409, Conflict)+ , (410, Gone)+ , (411, LengthRequired)+ , (412, PreconditionFailed)+ , (413, RequestEntityTooLarge)+ , (414, RequestURITooLarge)+ , (415, UnsupportedMediaType)+ , (416, RequestedRangeNotSatisfiable)+ , (417, ExpectationFailed)+ , (500, InternalServerError)+ , (501, NotImplemented)+ , (502, BadGateway)+ , (503, ServiceUnavailable)+ , (504, GatewayTimeOut)+ , (505, HTTPVersionNotSupported)+ ]++-- | Every status greater-than or equal to 400 is considered to be a failure.+statusFailure :: Status -> Bool+statusFailure st = codeFromStatus st >= 400++-- | Conversion from status numbers to codes.+statusFromCode :: Int -> Status+statusFromCode num =+ fromMaybe (CustomStatus num)+ $ lookup num statusCodes++-- | Conversion from status codes to numbers.+codeFromStatus :: Status -> Int+codeFromStatus st =+ fromMaybe 0 -- function is total, should not happen.+ $ lookupR st statusCodes+
src/Network/Protocol/Mime.hs view
@@ -1,14 +1,23 @@+{- |+Handling mime types. This module contains a mapping from file extensions to+mime-types taken from the Apache webserver project.+-}+ module Network.Protocol.Mime where import Data.Map --------- file extension to mime type mapping ----------------------------------+{- | Get the mimetype for the specified extension. -} mime :: String -> Maybe String mime ext = Data.Map.lookup ext extensionToMime +{- | The default mimetype is /text/plain/. -}+ defaultMime :: String defaultMime = "text/plain"++{- | The mapping from extension to mimetype. -} extensionToMime :: Map String String extensionToMime = fromList [
src/Network/Protocol/Uri.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TemplateHaskell #-}+{- | See rfc2396 for more info. -} +{-# LANGUAGE TemplateHaskell #-} module Network.Protocol.Uri ( - URI- , Scheme+ Scheme , IPv4 , Domain , RegName@@ -17,7 +17,10 @@ , Path , Host , Authority+ , URI + -- * Creating (parts of) URIs.+ , encode , decode @@ -31,8 +34,8 @@ , mkHost , mkPort - , absolute- , segments+ -- * Accessing parts of URIs.+ , domain , regname , ipv4@@ -46,6 +49,15 @@ , query , fragment + -- * Helper labels.++ , absolute+ , segments+ , _host+ , _port++ -- * Parsing URIs.+ , parseURI , parseAbsoluteURI , parseAuthority@@ -54,13 +66,17 @@ , pUriReference , pAbsoluteURI- , pAuthority- , pPath- , pHost+-- , pAuthority+-- , pPath+-- , pHost + -- * Handling query parameters.+ , parseQueryParams , queryParams + -- * Filename related utilities.+ , extension , mkPathRelative@@ -73,7 +89,7 @@ import Control.Applicative import Data.Bits-import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit)+import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit, toLower) import Data.List (intercalate, isPrefixOf) import Data.Maybe (mapMaybe, fromJust) import Data.Record.Label@@ -100,20 +116,20 @@ _absolute :: Bool , _segments :: [PathSegment] }- deriving Eq+ deriving (Eq, Ord) data Host = Hostname { __domain :: Domain } | RegName { __regname :: String } | IPv4 { __ipv4 :: IPv4 }- deriving Eq+ deriving (Eq, Ord) data Authority = Authority { __userinfo :: UserInfo , __host :: Host , __port :: Port }- deriving Eq+ deriving (Eq, Ord) data URI = URI { _relative :: Bool@@ -123,7 +139,7 @@ , __query :: Query , _fragment :: Fragment }- deriving Eq+ deriving (Eq, Ord) $(mkLabels [''Path, ''Host, ''Authority, ''URI]) @@ -158,63 +174,69 @@ userinfo = _userinfo % authority port = _port % authority -query =- Label {- lget = decode . lget _query- , lset = lset _query . encode- }--host =- Label {- lget = show . lget (_host % authority)- , lset = lset (_host % authority) . fromJust . parseHost- }--path =- Label {- lget = decode . show . lget _path- , lset = lset _path . fromJust . parsePath . encode- }+query = Label+ (decode . lget _query)+ (lset _query . encode) --- testUri0 :: URI--- testUri0 = fromJust $ parseURI "http://sebas@hs.spugium.net:8080/wiki/first%20section/chapter-2.pdf?additional=vars"+host = Label+ (show . lget (_host % authority))+ (lset (_host % authority) . maybe (Hostname []) id . parseHost) --- testUri1 :: URI--- testUri1 = fromJust $ parseURI "http://cs.uu.nl/docs/../docs/vakken/../vakken/"+path = Label+ (decode . show . lget _path)+ (lset _path . maybe (Path True []) id . parsePath . encode) -------[ creating, selection and modifying URIs ]------------------------------ --- pseudo constructors for `empty values'+{- | Constructors for making empty URI. -} mkURI :: URI mkURI = URI False mkScheme mkAuthority mkPath mkQuery mkFragment +{- | Constructors for making empty `Scheme`. -}+ mkScheme :: Scheme mkScheme = "" +{- | Constructors for making empty `Path`. -}+ mkPath :: Path mkPath = Path False [] +{- | Constructors for making empty `Authority`. -}+ mkAuthority :: Authority mkAuthority = Authority "" mkHost mkPort +{- | Constructors for making empty `Query`. -}+ mkQuery :: Query mkQuery = "" +{- | Constructors for making empty `Fragment`. -}+ mkFragment :: Fragment mkFragment = "" +{- | Constructors for making empty `UserInfo`. -}+ mkUserinfo :: UserInfo mkUserinfo = "" +{- | Constructors for making empty `Host`. -}+ mkHost :: Host mkHost = Hostname [] +{- | Constructors for making empty `Port`. -}+ mkPort :: Port mkPort = (-1) -------[ path encoding and decoding ]------------------------------------------ +{- | URI encode a string. -}+ encode :: String -> String encode = concatMap encodeChr where@@ -224,10 +246,12 @@ intToDigit (shiftR (ord c) 4) : intToDigit ((ord c) .&. 0x0F) : [] +{- | URI decode a string. -}+ decode :: String -> String decode [] = []-decode ('%':d:e:ds) | isHexDigit d && isHexDigit e = f d e : decode ds- where f a b = chr $ (ord a-ord '0') * 16 + (ord b - ord '0')+decode ('%':d:e:ds) | isHexDigit d && isHexDigit e = (chr $ digs d * 16 + digs e) : decode ds + where digs a = fromJust $ lookup (toLower a) $ zip "0123456789abcdef" [0..] decode (d:ds) = d : decode ds -------[ show instance for URIs ]----------------------------------------------@@ -267,19 +291,28 @@ -------[ global URI parse interface ]------------------------------------------ --- Top level parsers.+{- | Parse string into a `URI`. -}+ parseURI :: String -> Maybe URI parseURI = eitherToMaybe . parse pUriReference "" +{- | Parse string into a `URI` and only accept absolute URIs. -}+ parseAbsoluteURI :: String -> Maybe URI parseAbsoluteURI = eitherToMaybe . parse pAbsoluteURI "" +{- | Parse string into a `Authority` object. -}+ parseAuthority :: String -> Maybe Authority parseAuthority = eitherToMaybe . parse pAuthority "" +{- | Parse string into a `Path`. -}+ parsePath :: String -> Maybe Path parsePath = eitherToMaybe . parse pPath "" +{- | Parse string into a `Host`. -}+ parseHost :: String -> Maybe Host parseHost = eitherToMaybe . parse pHost "" @@ -493,8 +526,6 @@ -------[ parsing query parameters ]-------------------------------------------- --- Parse a pre-decoded query string into key value pairs parameters.- pQueryParams :: GenParser Char st Parameters pQueryParams = filter (not . null . fst)@@ -504,9 +535,13 @@ *> (translateParam <$> many (noneOf "&")))) (char '&') +{- | Parse a pre-decoded query string into key value pairs parameters. -}+ parseQueryParams :: String -> Maybe Parameters parseQueryParams = eitherToMaybe . parse pQueryParams "" +{- | Fetch the query parameters form a URI. -}+ queryParams :: URI -> Parameters queryParams = maybe [] id . parseQueryParams . lget query @@ -518,10 +553,7 @@ -------[ filename path utilities ]--------------------------------------------- -mkPathRelative :: FilePath -> FilePath-mkPathRelative = dropWhile (=='/')---- Generate a label for the filename extension.+{- | Label to access the extension of a filename. -} extension :: Label FilePath (Maybe String) extension = Label {lget = getExt, lset = setExt}@@ -533,15 +565,21 @@ setExt e p = let (u, v) = splt p in (if isExt u v then p else init v) ++ maybe "" ('.':) e --- Try to guess the 'correct' mime type for the input file based on the file--- extension.+{- |+Try to guess the correct mime type for the input file based on the file+extension.+-} mimetype :: FilePath -> Maybe String mimetype p = lget extension p >>= mime --- Normalize a path by removing or merging all dot or dot-dot segments and--- double slashes. Todo: cleanup, remove fixp.+{- |+Normalize a path by removing or merging all dot or dot-dot segments and double+slashes. +-} +-- Todo: cleanup, remove fixp.+ normalize :: FilePath -> FilePath normalize [] = [] normalize p = fixAbs absolut $ intercalate "/" $ norm@@ -559,13 +597,25 @@ merge (x:xs) = x : merge xs merge xs = xs -jail :: FilePath -> FilePath -> Maybe FilePath+{- | Make a path relative by removing the first slash when there is one. -}++mkPathRelative :: FilePath -> FilePath+mkPathRelative = dropWhile (=='/')++{- | Jail a filepath within a jail directory. -}++jail+ :: FilePath -- ^ Jail directory.+ -> FilePath -- ^ Filename to jail.+ -> Maybe FilePath jail jailDir p = let nj = normalize jailDir np = normalize p in if nj `isPrefixOf` np -- && not (".." `isPrefixOf` np) then Just np else Nothing++{- | Concatenate and normalize two filepaths. -} (/+) :: FilePath -> FilePath -> FilePath a /+ b = normalize (a ++ "/" ++ b)
− src/Network/Salvia/Advanced/CleverCSS.hs
@@ -1,29 +0,0 @@-module Network.Salvia.Advanced.CleverCSS (- hFilterCSS- , hCleverCSS- , hParametrizedCleverCSS- ) where--import Network.Protocol.Uri (Parameters)-import Network.Salvia.Handlers.ExtensionDispatcher (hExtension)-import Network.Salvia.Handlers.Fallback (hOr)-import Network.Salvia.Handlers.File (hFile, hFileFilter)-import Network.Salvia.Handlers.PathRouter (hParameters)-import Network.Salvia.Handlers.Rewrite (hRewriteExt)-import Network.Salvia.Httpd (Handler)-import Text.CSS.CleverCSS (cleverCSSConvert)--hFilterCSS :: Handler () -> Handler () -> Handler ()-hFilterCSS cssfilter handler = do- hExtension (Just "css")- (hFile `hOr` cssfilter)- handler--hCleverCSS :: Handler ()-hCleverCSS = hParameters >>= hParametrizedCleverCSS--hParametrizedCleverCSS :: Parameters -> Handler ()-hParametrizedCleverCSS p = do- hRewriteExt (fmap ('c':)) (hFileFilter convert)- where convert = either id id . flip (cleverCSSConvert "") (map (fmap $ maybe "" id) p)-
− src/Network/Salvia/Advanced/ExtendedFileSystem.hs
@@ -1,20 +0,0 @@-module Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem) where--import Network.Salvia.Advanced.CleverCSS (hFilterCSS, hCleverCSS)-import Network.Salvia.Advanced.HsColour (hHighlightHaskell, hHsColour)-import Network.Salvia.Handlers.Directory (hDirectoryResource)-import Network.Salvia.Handlers.File (hFileResource)-import Network.Salvia.Handlers.FileSystem (hFileTypeDispatcher)-import Network.Salvia.Handlers.Rewrite (hWithDir)-import Network.Salvia.Httpd (Handler)--hExtendedFileSystem :: FilePath -> Handler ()-hExtendedFileSystem dir =- hFileTypeDispatcher dir- hDirectoryResource- $ \r -> hHighlightHaskell (hHsColour r)- $ hWithDir dir- $ hFilterCSS hCleverCSS- $ hFileResource r--
− src/Network/Salvia/Advanced/HsColour.hs
@@ -1,54 +0,0 @@-module Network.Salvia.Advanced.HsColour (- hHighlightHaskell- , hHsColour- , hHsColourCustomStyle-- , defaultStyleSheet- ) where--import Data.Record.Label-import Language.Haskell.HsColour.CSS-import Network.Protocol.Http (contentType, utf8)-import Network.Salvia.Handlers.ExtensionDispatcher-import Network.Salvia.Handlers.File-import Network.Salvia.Httpd--hHighlightHaskell :: Handler () -> Handler () -> Handler ()-hHighlightHaskell highlighter = - hExtensionRouter [- (Just "hs", highlighter)- , (Just "lhs", highlighter)- , (Just "ag", highlighter)- ]--hHsColour :: ResourceHandler ()-hHsColour = hHsColourCustomStyle (Left defaultStyleSheet)---- Left means direct inclusion of stylesheet, right means link to external--- stylesheet.--hHsColourCustomStyle :: Either String String -> ResourceHandler ()-hHsColourCustomStyle style r = do- sendStr (either id makeStyleLink style)- hFileResourceFilter (hscolour False True "") r- setM (contentType % response) ("text/html", Just utf8)--makeStyleLink :: String -> String-makeStyleLink css = "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ css ++ "\"></link>"--defaultStyleSheet :: String-defaultStyleSheet = filter (/=' ') $ concat [- "<style>"- , ".varop { color : #960; font-weight : normal; }"- , ".keyglyph { color : #960; font-weight : normal; }"- , ".definition { color : #005; font-weight : bold; }"- , ".varid { color : #444; font-weight : normal; }"- , ".keyword { color : #000; font-weight : bold; }"- , ".comment { color : #44f; font-weight : normal; }"- , ".conid { color : #000; font-weight : normal; }"- , ".num { color : #00a; font-weight : normal; }"- , ".str { color : #a00; font-weight : normal; }"- , "</style>"- , ""- ]-
src/Network/Salvia/Core/Config.hs view
@@ -6,25 +6,36 @@ import Network.Socket hiding (send, listen) import System.IO --------- server configuration -------------------------------------------------+{- |+The HTTP server configuration specifies some important network settings the+server must know before being able to run. Most fields speak for themselves.+-} data HttpdConfig = HttpdConfig {- hostname :: String -- Server hostname.- , email :: String -- Server admin email address.- , listenAddr :: HostAddress -- Addres to bind to.- , listenPort :: PortNumber -- Port to listen on.- , backlog :: Int -- TCP backlog.- , bufferSize :: Int -- Serve chunck with size.+ hostname :: String -- ^ Server hostname.+ , email :: String -- ^ Server admin email address.+ , listenAddr :: HostAddress -- ^ Addres to bind to.+ , listenPort :: PortNumber -- ^ Port to listen on.+ , backlog :: Int -- ^ TCP backlog.+ , bufferSize :: Int -- ^ Serve chunck with size. } +{- |+The default server configuration sets some safe default values. The server will+by default bind to 0.0.0.0 at port 80. The default value for the TCP backlog is+4, the default socket buffer size is 64KB. This function has to be in IO+because of the translation from a `String` to a `HostAddress` using+`inet_addr`.+-}+ defaultConfig :: IO HttpdConfig defaultConfig = do addr <- inet_addr "0.0.0.0" return $ HttpdConfig { hostname = "hostname"- , email = "www@hostname"+ , email = "admin@localhost" , listenAddr = addr , listenPort = 80 , backlog = 4
+ src/Network/Salvia/Core/Context.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}+module Network.Salvia.Core.Context (+ SendAction+ , SendQueue+ , Context++ , config+ , request+ , response+ , sock+ , address+ , queue++ , mkContext+ ) where++import Data.Record.Label+import Network.Protocol.Http (Message, emptyRequest, emptyResponse)+import Network.Salvia.Core.Config+import Network.Socket (SockAddr)+import System.IO++-------- single request/response context --------------------------------------++-- | A send action is some thing that works on an IO handle.+type SendAction = Handle -> IO ()++{- |+The send queue is an abstraction to make sure all data that belongs to the+message body is sent after the response headers have been sent. Instead of+sending data to client directly over the socket from the context it is+preferable to queue send actions in the context's send queue. The entire send+queue can be flushed to the client at once after the HTTP headers have been+sent at the end of a request handler.+-}++type SendQueue = [SendAction]++{- |+A handler context contains all the information needed by the request handlers+to perform their task and to set up a proper response. All the fields in the+context are accessible using the read/write labels defined below.+-}++data Context =+ Context {+ _config :: HttpdConfig -- ^ The HTTP server configuration.+ , _request :: Message -- ^ The HTTP request header.+ , _response :: Message -- ^ The HTTP response header.+ , _sock :: Handle -- ^ The socket handle for the connection with the client.+ , _address :: SockAddr -- ^ The client addres.+ , _queue :: SendQueue -- ^ The queue of send actions.+ }++$(mkLabels [''Context])++{- | The queue containing all send actions. -}+queue :: Label Context SendQueue++{- | The client address. -}+address :: Label Context SockAddr++{- | The socket to the client. -}+sock :: Label Context Handle++{- |+The server response. Using the appropriate handler the response can be sent to+the client after processing the request.+-}++response :: Label Context Message++{- |+The client request. This request is initially empty and only available after+the message has been parsed by the appropriate handler.+-}++request :: Label Context Message++{- |+The global server configuration. Modifying this has no effect on consecutive+requests.+-}++config :: Label Context HttpdConfig++{- |+Create and default server context with the specified server configuration,+client address and socket.+-}++mkContext :: HttpdConfig -> SockAddr -> Handle -> Context+mkContext c a s = Context {+ _config = c+ , _request = emptyRequest+ , _response = emptyResponse -- 200 OK, by default.+ , _sock = s+ , _address = a+ , _queue = []+ }+
src/Network/Salvia/Core/Handler.hs view
@@ -1,74 +1,32 @@ {-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Network.Salvia.Core.Handler (- SendAction- , SendQueue- , Context (..)-- , config- , request- , response- , sock- , address- , queue-- , mkContext-- , Handler+ Handler , ResourceHandler , UriHandler ) where import Control.Applicative (Applicative, pure, (<*>)) import Control.Monad.State (StateT, ap)-import Data.Record.Label-import Network.Protocol.Http (Message, emptyRequest, emptyResponse) import Network.Protocol.Uri (URI)-import Network.Salvia.Core.Config-import Network.Socket (SockAddr)+import Network.Salvia.Core.Context import System.IO --------- single request/response context ----------------------------------------type SendAction = Handle -> IO ()-type SendQueue = [SendAction]--data Context =- Context {- _config :: HttpdConfig -- ^ The HTTP server configuration.- , _request :: Message -- ^ The HTTP request header.- , _response :: Message -- ^ The HTTP response header.- , _sock :: Handle -- ^ The socket handle for the connection with the client.- , _address :: SockAddr -- ^ The client addres.- , _queue :: SendQueue -- ^ The queue of send actions.- }+{- |+A HTTP request handler lives in `IO` and carries a server context in the+`State` monad. This module also provides an `Applicative` instance for `StateT`+`Context` `IO`.+-} -$(mkLabels [''Context])+type Handler a = StateT Context IO a -queue :: Label Context SendQueue-address :: Label Context SockAddr-sock :: Label Context Handle-response :: Label Context Message-request :: Label Context Message-config :: Label Context HttpdConfig+{- | A resource handler is something that works on some filesystem resource. -} --- Create and empty server context.-mkContext :: HttpdConfig -> SockAddr -> Handle -> Context-mkContext c a s = Context {- _config = c- , _request = emptyRequest- , _response = emptyResponse -- 200 OK, by default.- , _sock = s- , _address = a- , _queue = []- }+type ResourceHandler a = FilePath -> Handler a --------- request handlers -----------------------------------------------------+{- | A URI handler is something that works on an request URI. -} --- HTTP handler types.-type Handler a = StateT Context IO a-type ResourceHandler a = FilePath -> Handler a-type UriHandler a = URI -> Handler a+type UriHandler a = URI -> Handler a -- Make handlers applicative. instance Applicative (StateT Context IO) where
src/Network/Salvia/Core/IO.hs view
@@ -1,20 +1,32 @@-module Network.Salvia.Core.IO (+{-|+This module contains some useful functions for IO over the client socket. Some+functions directly work on the socket and some queue actions into the send+queue. The latter form is more high-level and recommended for common use. This+module is likely to be extended in the future with other useful function that+handle specific message IO.+-} - sendHeaders+module Network.Salvia.Core.IO ( - , send+ -- * Queing send actions to the send queue.+ send , sendStr , sendStrLn , sendBs + -- * Queing spool actions to the send queue. , spool , spoolBs- , spoolAll- , spoolN + -- * Send actions directly using the socket.+ , flushHeaders+ , flushQueue++ -- * Directly manipulate the send queue. , emptyQueue , reset + -- * Reading data from the client request. , contents , contentsUtf8 , uriEncodedPostParamsUTF8@@ -29,6 +41,7 @@ import Data.Record.Label import Network.Protocol.Http import Network.Protocol.Uri (Parameters, parseQueryParams, decode)+import Network.Salvia.Core.Context import Network.Salvia.Core.Handler import System.IO import qualified Data.ByteString.Lazy as B@@ -36,77 +49,87 @@ ------------------------------------------------------------------------------- --- Send the response header to the socket.-sendHeaders :: Handler ()-sendHeaders = do- r <- getM response- s <- getM sock - lift $ hPutStr s (showMessageHeader r)+{- |+Queue one potential send action in the send queue. This will not (yet) be sent+over the socket.+-} --- Queue a potential send action in the send queue. send :: SendAction -> Handler ()-send f = modM queue (++[f]) -- modify (\m -> m { queue = (queue m) ++ [f] })+send f = modM queue (++[f]) --- Queue a String for sending.-sendStr, sendStrLn :: String -> Handler ()-sendStr s = send (flip U.hPutStr s)+{- | Queue the action of sending one UTF-8 encoded `String` over the socket. -}++sendStr :: String -> Handler ()+sendStr s = send (flip U.hPutStr s)++{- |+Queue the action of sending one UTF-8 encoded `String` with extra linefeed+over the socket.+-}++sendStrLn :: String -> Handler () sendStrLn s = send (flip U.hPutStr (s ++ "\n")) --- Queue a ByteString for sending.+{- | Queue the action of sending one lazy `B.ByteString` over the socket. -}+ sendBs :: B.ByteString -> Handler () sendBs bs = send (flip B.hPutStr bs) -{--Queue spooling the entire contents of a stream to the socket using a String-based filter.+{- |+Queue spooling the entire contents of a stream to the socket using a UTF-8+encoded `String` based filter. -}+ spool :: (String -> String) -> Handle -> Handler () spool f fd = send (\s -> U.hGetContents fd >>= \d -> U.hPutStr s (f d)) -{--Queue spooling the entire contents of a stream to the socket using a ByteString-based filter.+{- |+Queue spooling the entire contents of a stream to the socket using a+`B.ByteString` based filter. -}+ spoolBs :: (B.ByteString -> B.ByteString) -> Handle -> Handler () spoolBs f fd = send (\s -> B.hGetContents fd >>= \d -> B.hPut s (f d)) -{--Spool the entire contents from one stream to another stream, after this the-handle will be closed.--}-spoolAll :: Handle -> Handle -> Handler ()-spoolAll f t = lift $ do- B.hGetContents f >>= B.hPut t- hClose t+{- | Send all the response headers directly over the socket. -} -{--Spool a fixed number of bytes from one stream to another stream, after this the-handle will be closed.--}-spoolN :: Handle -> Handle -> Int -> Handler ()-spoolN f t n = lift $ do- B.hGet f n >>= B.hPut t- hClose t+flushHeaders :: Handler ()+flushHeaders = do+ r <- getM response+ s <- getM sock + lift $ hPutStr s (showMessageHeader r) --- Reset the send queue.+{- | Apply all send actions successively to the client socket. -}++flushQueue :: Handler ()+flushQueue =+ do h <- getM sock+ q <- getM queue+ liftIO $+ do mapM_ ($ h) q+ hFlush h++{- | Reset the send queue by throwing away all potential send actions. -}+ emptyQueue :: Handler () emptyQueue = setM queue [] --- Reset both the send queue and the generated response.+{- | Reset both the send queue and the generated server response. -}+ reset :: Handler () reset = do setM response emptyResponse emptyQueue {- |-First naive handler to retreive the request payload as a ByteString. This-probably does not handle all the quirks that the HTTP protocol specifies, but-it does the job for now. When a 'ContentLength' header field is available only-this fixed number of bytes will read from the socket. When neither the-'KeepAlive' and 'ContentLength' header fields are available the entire payload-of the request will be read from the socket. This method is probably only-useful in the case of 'PUT' request, because no decoding of 'POST' data is-handled.+First (possibly naive) handler to retreive the client request body as a+`B.ByteString`. This probably does not handle all the quirks that the HTTP+protocol specifies, but it does the job for now. When a 'contentLength' header+field is available only this fixed number of bytes will read from the socket.+When neither the 'keepAlive' and 'contentLength' header fields are available+the entire payload of the request will be read from the socket. This method is+probably only useful in the case of 'PUT' request, because no decoding of+'POST' data is handled. -} contents :: Handler (Maybe B.ByteString)@@ -115,18 +138,23 @@ kpa <- getM (keepAlive % request) s <- getM sock lift $- case (kpa, len) of+ case (kpa::Maybe Integer, len::Maybe Integer) of (_, Just n) -> liftM Just (B.hGet s (fromIntegral n)) (Nothing, Nothing) -> liftM Just (B.hGetContents s) _ -> return Nothing {- |-Like the `contents' function but decodes the data as UTF8. Soon, time will come-that decoding will be based upon the requested encoding.+Like the `contents' function but decodes the data as UTF-8. Soon, time will+come that decoding will be based upon the requested encoding. -} contentsUtf8 :: Handler (Maybe String) contentsUtf8 = (fmap $ decodeLazy UTF8) `liftM` contents++{- |+Try to parse the supplied request body as URI encoded `POST` parameters in+UTF-8 encoding. Returns as a URI parameter type or nothing when parsing fails.+-} uriEncodedPostParamsUTF8 :: Handler (Maybe Parameters) uriEncodedPostParamsUTF8 = liftM (>>= parseQueryParams . decode) contentsUtf8
src/Network/Salvia/Core/Main.hs view
@@ -1,15 +1,21 @@ module Network.Salvia.Core.Main (start) where +import Control.Concurrent (forkIO) import Control.Monad.State import Network.Salvia.Core.Config (listenAddr, listenPort, backlog, HttpdConfig)-import Network.Salvia.Core.Handler (Handler, mkContext)-import Network.Salvia.Core.Network (server)+import Network.Salvia.Core.Context (mkContext)+import Network.Salvia.Core.Handler (Handler)+import Network.Socket+import System.IO -------- HTTP deamon implementation ------------------------------------------- -{--Given a server configuration and a handler to invoke when receiving client-request the server starts and keep running forever.+{- |+Start a webserver with a specific server configuration and default handler. The+server will go into an infinite loop and will repeatedly accept client+connections on the address and port specified in the configuration. For every+connection the specified handler will be executed with the client address and+socket stored in the handler context. -} start :: HttpdConfig -> Handler () -> IO ()@@ -23,4 +29,31 @@ tcpHandler handle addr = fst `liftM` runStateT httpHandler (mkContext config addr handle)++{-+Start a listening TCP server on the specified address/port combination and+handle every connection with a custom handler.+-}++server :: HostAddress -> PortNumber -> Int -> (Handle -> SockAddr -> IO ()) -> IO ()+server addr port blog handler = do+ sock <- socket AF_INET Stream 0+ setSocketOption sock ReuseAddr 1+ bindSocket sock $ SockAddrInet port addr+ listen sock blog+ acceptLoop sock handler++{-+Accept connections on the listening socket and pass execution to the+application specific connection handler.+-}++acceptLoop :: Socket -> (Handle -> SockAddr -> IO ()) -> IO ()+acceptLoop sock handler = do+ forever $ do+ (sock', addr) <- accept sock+ forkIO $+ do h <- socketToHandle sock' ReadWriteMode+ handler h addr+ putStrLn "quiting"
− src/Network/Salvia/Core/Network.hs
@@ -1,52 +0,0 @@-module Network.Salvia.Core.Network where--import Control.Concurrent (forkIO)-import Control.Monad-import Network.Socket-import System.IO---------- application independent networking -------------------------------------type Server a =- Handle- -> SockAddr- -> IO a--{--Start a listening TCP server on the specified address/port combination and-handle every connection with a custom handler.--}--server :: HostAddress -> PortNumber -> Int -> Server a -> IO ()-server addr port backlog handler = do- sock <- socket AF_INET Stream 0- setSocketOption sock ReuseAddr 1- bindSocket sock $ SockAddrInet port addr- listen sock backlog- acceptLoop sock handler--{--Accept connections on the listening socket and pass execution to the-application specific connection handler.--}--acceptLoop :: Socket -> Server s -> IO ()-acceptLoop sock handler = do- forever $ do- (sock', addr) <- accept sock- forkIO $ do- handle <- socketToHandle sock' ReadWriteMode- -- TODO: Using NoBuffering here may crash the entire program (GHC- -- runtime?) when processing more requests than just a few:- hSetBuffering handle (BlockBuffering (Just (64*1024)))- handler handle addr- -- We can probably just ignore exceptions from hClose, but this for the- -- moment I am interested whether this even happens.- hClose handle--- e <- try (hClose handle)--- case e of--- Left ex -> putStrLn ("Failure during hClose: " ++ show (ex :: IOException))--- Right _ -> return ()- putStrLn "quiting"--
+ src/Network/Salvia/Handler/Banner.hs view
@@ -0,0 +1,28 @@+module Network.Salvia.Handler.Banner (hBanner) where++import Control.Monad.State+import Data.Record.Label+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime)+import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)+import Network.Protocol.Http+import Network.Salvia.Httpd+import System.Locale (defaultTimeLocale)++{- |+The 'hBanner' handler adds the current date-/timestamp and a custom server name+to the response headers.+-}++hBanner ::+ String -- ^ The HTTP server name.+ -> Handler ()+hBanner sv = do+ dt <- lift $ do+ zone <- getCurrentTimeZone+ time <- liftM (utcToLocalTime zone) getCurrentTime+ return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time+ enterM response $ do+ setM date dt+ setM server sv+
+ src/Network/Salvia/Handler/CGI.hs view
@@ -0,0 +1,22 @@+module Network.Salvia.Handler.CGI (hCGI) where++import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO+import System.Process (runProcess, waitForProcess)++{- |+Handle CGI scripts, not yet working properly.+-}++hCGI :: ResourceHandler ()+hCGI name = do+ setM (status % response) OK+ h <- getM sock+ lift $ do+ p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)+ waitForProcess p+ return ()+
+ src/Network/Salvia/Handler/Close.hs view
@@ -0,0 +1,51 @@+module Network.Salvia.Handler.Close (+ hCloseConn+ , hKeepAlive+ ) where++import Control.Monad.State+import Data.Maybe+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO++{- |+Run a handler once and close the connection afterwards.+-}++hCloseConn :: Handler () -> Handler ()+hCloseConn h = h >> getM sock >>= liftIO . hClose++{- |+Run a handler and keep the connection open for potential consecutive requests.+The connection will only be closed after a request finished and one or more of+the following criteria are met:++* There is no `contentLength` set in the response headers. When this is the+ case the connection cannot be kept alive.++* The client has set the `connection` header field to 'close'.++* The connection has already been closed, possible due to IO errors.+-}++hKeepAlive :: Handler () -> Handler ()+hKeepAlive handler =+ do handler++ h <- getM sock+ conn <- getM (connection % request)+ len <- getM (contentLength % response)+ closed <- liftIO (hIsClosed h)++ if or [closed, conn == "Close", isNothing (len::Maybe Integer) ]+ then liftIO (hClose h)+ else resetContext >> hKeepAlive handler++resetContext :: Handler ()+resetContext =+ do setM request emptyRequest+ setM response emptyResponse+ setM queue []+
+ src/Network/Salvia/Handler/Cookie.hs view
@@ -0,0 +1,44 @@+module Network.Salvia.Handler.Cookie (+ hSetCookies+ , hGetCookies++ , newCookie+ ) where++import Control.Applicative hiding (empty)+import Control.Monad.State+import Data.Record.Label+import Data.Time.Format+import Data.Time.LocalTime+import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires)+import Network.Protocol.Http (cookie)+import Network.Salvia.Httpd+import System.Locale (defaultTimeLocale)++{- | Set the `cookie` HTTP response header (Set-Cookie) with the specified `Cookies`. -}++hSetCookies :: Cookies -> Handler ()+hSetCookies = setM (cookie % response) . showCookies++{- | Try to get the cookies from the HTTP `cookie` request header. -}++hGetCookies :: Handler (Maybe Cookies)+hGetCookies = parseCookies <$> getM (cookie % request)++{- |+Convenient method for creating cookies that expire in the near future and are+bound to the domain and port this server runs on. The path will be locked to+root.+-}++newCookie :: LocalTime -> Handler Cookie+newCookie expire = do+ httpd <- getM config+ return $ empty {+ path = Just "/"+-- , domain = Just $ '.' : hostname httpd+ , port = [fromEnum $ listenPort httpd]+ , expires = Just $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire+ }++
+ src/Network/Salvia/Handler/Counter.hs view
@@ -0,0 +1,11 @@+module Network.Salvia.Handler.Counter (hCounter) where++import Control.Concurrent.STM+import Control.Monad.State+import Network.Salvia.Httpd++{- | This handler simply increases the request counter variable. -}++hCounter :: TVar Int -> Handler ()+hCounter c = lift $ atomically $ readTVar c >>= writeTVar c . (+1)+
+ src/Network/Salvia/Handler/Directory.hs view
@@ -0,0 +1,64 @@+module Network.Salvia.Handler.Directory (+ hDirectory+ , hDirectoryResource+ ) where++import Control.Monad.State+import Data.List (sort)+import Data.Record.Label+import Misc.Misc (bool)+import Network.Protocol.Http+import Network.Protocol.Uri (path)+import Network.Salvia.Handler.File (hResource)+import Network.Salvia.Handler.Redirect+import Network.Salvia.Httpd+import System.Directory (doesDirectoryExist, getDirectoryContents)++{- |+Serve a simple HTML directory listing for the specified directory on the+filesystem.+-}++hDirectoryResource :: ResourceHandler ()+hDirectoryResource dirName = do+ (u, p) <- bothM (uri % request) (getM path)+ if (null p) || last p /= '/'+ then hRedirect (lmod path (++"/") u)+ else dirHandler dirName++{- |+Like `hDirectoryResource` but uses the path of the current request URI.+-}++hDirectory :: Handler ()+hDirectory = hResource hDirectoryResource++dirHandler:: ResourceHandler ()+dirHandler dirName = do+ p <- getM (path % uri % request)+ filenames <- lift $ getDirectoryContents dirName+ processed <- lift $ mapM (processFilename dirName) (sort filenames)+ let b = listing p processed+ enterM response $ do+ setM contentType ("text/html", Nothing)+ setM contentLength (Just $ length b)+ setM status OK+ sendStr b++-- Add trailing slash to a directory name.+processFilename :: FilePath -> FilePath -> IO FilePath+processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f)++-- Turn a list of filenames into HTML directory listing.+listing :: FilePath -> [FilePath] -> String+listing dirName fileNames =+ concat [+ "<html><head><title>Index of "+ , dirName+ , "</title></head><body><h1>Index of "+ , dirName+ , "</h1><ul>"+ , fileNames >>= \f -> concat ["<li><a href='", f, "'>", f, "</a></li>"]+ , "</ul></body></html>"+ ]+
+ src/Network/Salvia/Handler/Dispatching.hs view
@@ -0,0 +1,48 @@+module Network.Salvia.Handler.Dispatching (+ Dispatcher+ , ListDispatcher+ , hDispatch+ , hListDispatch+ ) where++import Data.Record.Label+import Network.Salvia.Httpd++{- |+The dispatcher type takes one value to dispatch on and two handlers. The first+handler will be used when the predicate on the dispatch value returned `True`,+the second (default) handler will be used when the predicate returs+`False`.+-}++type Dispatcher a b = a -> Handler b -> Handler b -> Handler b++{- |+A list dispatcher takes a mapping from dispatch values and handlers and one+default handler.+-}++type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b++{- |+Dispatch on an arbitrary part of the context using an arbitrary predicate. When+the predicate returns true on the value selected with the `Label` the first+handler will be invoked, otherwise the second handler will be used.+-}++hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b+hDispatch f match a handler _default = do+ ctx <- getM f+ if a `match` ctx+ then handler+ else _default++{- |+Turns a dispatcher function into a list dispatcher. This enables handler+routing based on arbitrary values from the context. When non of the predicates+in the `ListDispatcher` type hold the default handler will be invoked.+-}++hListDispatch :: Dispatcher a b -> ListDispatcher a b+hListDispatch disp = flip $ foldr $ uncurry disp+
+ src/Network/Salvia/Handler/Environment.hs view
@@ -0,0 +1,78 @@+module Network.Salvia.Handler.Environment (+ hDefaultEnv+ , hSessionEnv+ ) where++import Control.Concurrent.STM+import Network.Protocol.Http+import Network.Salvia.Handler.Banner+import Network.Salvia.Handler.Counter+import Network.Salvia.Handler.Close+import Network.Salvia.Handler.Error+import Network.Salvia.Handler.Head+import Network.Salvia.Handler.Log+import Network.Salvia.Handler.Parser+import Network.Salvia.Handler.Printer+import Network.Salvia.Handler.Session+import Network.Salvia.Httpd+import System.IO++{- |+This is the default stateless handler evnironment. It takes care of request+parsing (`hParser`), response printing (`hPrinter`), request logging (`hLog`),+connection keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and+printing the `salvia-httpd` server banner (`hBanner`).+-}++hDefaultEnv+ :: Handler () -- ^ Handler to run in the default environment.+ -> Handler ()+hDefaultEnv handler =+ hKeepAlive $ + hParser (1000 * 15)+ (wrapper Nothing . parseError)+ (wrapper Nothing $ hHead handler)++{- |+This function is a more advanced version of the `hDefaultEnv` handler+environment that takes a global state into account. It takes a shared variable+containg the connection counter (used by `hCounter`) and a variable containing+all session information (used by `hSession`). Handlers that run in this+environment take should be parametrized with a session.+-}++hSessionEnv+ :: TVar Int -- ^ Request count variable.+ -> Sessions a -- ^ Session collection variable.+ -> SessionHandler a () -- ^ Handler parametrized with current session.+ -> Handler ()+hSessionEnv count sessions handler =+ hKeepAlive $ + hParser (1000 * 15)+ (wrapper (Just count) . parseError)+ (wrapper (Just count) $+ do session <- hSession sessions 300+ hHead (handler session))++-- Helper functions.++before :: Handler ()+before = hBanner "salvia-httpd"++after :: Maybe (TVar Int) -> Handler ()+after mc = + do hPrinter+ maybe+ (hLog stdout)+ (\c -> hCounter c >> hLogWithCounter c stdout)+ mc++wrapper :: Maybe (TVar Int) -> Handler a -> Handler ()+wrapper c h = before >> h >> after c++parseError :: String -> Handler ()+parseError err = + do hError BadRequest+ sendStrLn []+ sendStrLn err+
+ src/Network/Salvia/Handler/Error.hs view
@@ -0,0 +1,58 @@+module Network.Salvia.Handler.Error (+ hError+ , hCustomError+ , hIOError+ , safeIO+ ) where++import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO.Error++{- |+The 'hError' handler enables the creation of a default style of error responses+for the specified HTTP `Status` code.+-}++hError :: Status -> Handler ()+hError e = hCustomError e+ (concat ["[", show (codeFromStatus e), "] ", show e, "\n"])++{- | Like `hError` but with a custom error message. -}++hCustomError :: Status -> String -> Handler ()+hCustomError e m = do+ enterM response $ do+ setM status e+ setM contentLength (Just $ length m)+ setM contentType ("text/plain", Nothing)+ sendStr m++{- |+Map an `IOError` to a default style error response.++The mapping from an IO error to an error response is rather straightforward:++> | isDoesNotExistError e = hError NotFound+> | isAlreadyInUseError e = hError ServiceUnavailable+> | isPermissionError e = hError Forbidden+> | True = hError InternalServerError+-}++hIOError :: IOError -> Handler ()+hIOError e+ | isDoesNotExistError e = hError NotFound+ | isAlreadyInUseError e = hError ServiceUnavailable+ | isPermissionError e = hError Forbidden+ | True = hError InternalServerError++{- |+Execute an handler with the result of an IO action. When the IO actions fails a+default error handler will be executed.+-}++safeIO :: IO a -> (a -> Handler ()) -> Handler ()+safeIO io h = lift (try io) >>= either hIOError h+
+ src/Network/Salvia/Handler/ExtensionDispatcher.hs view
@@ -0,0 +1,21 @@+module Network.Salvia.Handler.ExtensionDispatcher (+ hExtension+ , hExtensionRouter+ ) where++import Data.Record.Label+import Network.Protocol.Http (uri)+import Network.Protocol.Uri (extension, path)+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Httpd (request)++{- | Request dispatcher based on the request path file extenstion. -}++hExtension :: Dispatcher (Maybe String) a+hExtension = hDispatch (extension % path % uri % request) (==)++{- | List dispatcher version of `hExtension`. -}++hExtensionRouter :: ListDispatcher (Maybe String) a+hExtensionRouter = hListDispatch hExtension+
+ src/Network/Salvia/Handler/Fallback.hs view
@@ -0,0 +1,33 @@+module Network.Salvia.Handler.Fallback (hOr, hEither) where++import Control.Applicative+import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd++{- |+Until I figure out how to do this correctly, this handler somewow implements+the MonadPlus/Alternative instance using a custom function.++When the first handler fails the response will be reset and the second handler+is executed. Failure is indicated by an HTTP response `Status` bigger than or+equal to 400 (`BadRequest`). See `statusFailure`.+-}++hOr :: Handler a -> Handler a -> Handler a+hOr h0 h1 = do+ a <- h0+ st <- getM (status % response)+ if statusFailure st+ then reset >> h1+ else return a++{- |+Like the `hOr` function, but the types of the alternatives may differ because+the values are packed up in an `Either`.+-}++hEither :: Handler a -> Handler b -> Handler (Either a b)+hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)+
+ src/Network/Salvia/Handler/File.hs view
@@ -0,0 +1,88 @@+module Network.Salvia.Handler.File (+ hFile+ , hFileResource++ , hFileFilter+ , hFileResourceFilter++ , hResource+ , hUri+ ) where++import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Mime+import Network.Protocol.Uri (mimetype, path, parseURI)+import Network.Salvia.Handler.Error+import Network.Salvia.Httpd+import System.IO++{- |+Serve a file from the filesystem indicated by the specified filepath. When+there is some kind of `IOError` the `safeIO` function will be used to produce a+corresponding error response. The `contentType` will be the mime-type based on+the filename extension using the `mimetype` function. The `contentLength` will+be set the file's size.+-}++-- TODO: what to do with encoding?+hFileResource :: ResourceHandler ()+hFileResource file = do+ let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)+ safeIO (openBinaryFile file ReadMode)+ $ \fd -> do+ fs <- lift $ hFileSize fd+ enterM response $ do+ setM contentType (m, Just "utf-8")+ setM contentLength (Just fs)+ setM status OK+ spoolBs id fd++{- |+Like the `hFileResource` handler, but with a custom filter over the content.+This function will assume the content is an UTF-8 encoded text file. No+`contentLength` header will be set using this handler.+-}++-- TODO: what to do with encoding?+hFileResourceFilter :: (String -> String) -> ResourceHandler ()+hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter+ let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)+ safeIO (openBinaryFile file ReadMode)+ $ \fd -> do+ enterM response $ do+ setM contentType (m, Just "utf-8")+ setM status OK+ spool fFilter fd++{- |+Turn a resource handler into a regular handler that utilizes the path part of+the request URI as the resource identifier.+-}++hResource :: ResourceHandler a -> Handler a+hResource rh = getM (path % uri % request) >>= rh++{- |+Turn a URI handler into a regular handler that utilizes the request URI as the+resource identifier.+-}++hUri :: UriHandler a -> Handler a+hUri rh = getM (uri % request) >>= rh++{- |+Like `hFileResource` but uses the path of the current request URI.+-}++hFile :: Handler ()+hFile = hResource hFileResource++{- |+Like `hFileResourceFilter` but uses the path of the current request URI.+-}++hFileFilter :: (String -> String) -> Handler ()+hFileFilter = hResource . hFileResourceFilter+
+ src/Network/Salvia/Handler/FileSystem.hs view
@@ -0,0 +1,56 @@+module Network.Salvia.Handler.FileSystem (+ hFileSystem+ , hFileSystemNoIndexes+ , hFileTypeDispatcher+ ) where++import Control.Monad.State+import Data.Record.Label+import Misc.Misc (bool)+import Network.Protocol.Http+import Network.Protocol.Uri (jail, path)+import Network.Salvia.Handler.Directory+import Network.Salvia.Handler.Error+import Network.Salvia.Handler.File+import Network.Salvia.Httpd+import System.Directory (doesDirectoryExist)++{- |+Dispatch based on file type; regular files or directories. The first handler+specified will be invoked in case the resource to be served is an directory,+the second handler otherwise. The path from the request URI will be appended to+the directory resource specified as a parameter, this new path will be used to+lookup the real resource on the file system. Every request will be jailed in+the specified directory resource to prevent users from requesting arbitrary+parts of the file system.+-}++hFileTypeDispatcher :: ResourceHandler () -> ResourceHandler () -> ResourceHandler () +hFileTypeDispatcher hdir hfile dir =+ getM (path % uri % request) >>=+ hJailedDispatch dir hdir hfile . (dir ++)++{- |+Serve single directory by combining the `hDirectoryResource` and+`hFileResource` handlers in the `hFileTypeDispatcher`.+-}++hFileSystem :: ResourceHandler ()+hFileSystem = hFileTypeDispatcher hDirectoryResource hFileResource++{- |+Serve single directory like `hFileSystem` but do not show directory indices.+Instead of an directory index an `Forbidden` response will be created.+-}++-- Show file contents, do not show directory indexes.+hFileSystemNoIndexes :: ResourceHandler ()+hFileSystemNoIndexes = hFileTypeDispatcher (const $ hError Forbidden) hFileResource++hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler () +hJailedDispatch dir hdir hfile file = do+ case jail dir file of+ Nothing -> hError Forbidden+ Just f -> bool (hdir file) (hfile file)+ =<< lift (doesDirectoryExist f) +
+ src/Network/Salvia/Handler/Head.hs view
@@ -0,0 +1,23 @@+module Network.Salvia.Handler.Head (hHead) where++import Control.Applicative+import Control.Monad.State (put)+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd++{- |+The 'hHead' handler makes sure no response body is sent to the client when the+request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the+specified sub handler will be executed under the assumption that the request+was a 'GET' request, otherwise this handler will act as the identify function.+-}++hHead :: Handler a -> Handler a+hHead handler = do+ m <- getM (method % request)+ case m of+ HEAD -> withM (method % request) (put GET) $+ handler <* emptyQueue+ _ -> handler+
+ src/Network/Salvia/Handler/Log.hs view
@@ -0,0 +1,47 @@+module Network.Salvia.Handler.Log (+ hLog+ , hLogWithCounter+ ) where++import Control.Concurrent.STM+import Control.Monad.State+import Data.Record.Label+import Misc.Terminal (red, green, reset)+import Network.Protocol.Http+import Network.Salvia.Httpd (Handler, request, response, address)+import System.IO++{- |+A simple logger that prints a summery of the request information to the+specified file handle.+-}++hLog :: Handle -> Handler ()+hLog = logger Nothing++{- | Like `hLog` but also prints the request count since server startup. -}++hLogWithCounter :: TVar Int -> Handle -> Handler ()+hLogWithCounter a = logger (Just a)++logger :: Maybe (TVar Int) -> Handle -> Handler ()+logger count handle = do+ c <- case count of+ Nothing -> return ""+ Just c' -> liftIO (show `liftM` atomically (readTVar c'))+ mt <- getM (method % request)+ ur <- getM (uri % request)+ st <- getM (status % response)+ addr <- getM address+ let code = codeFromStatus st+ clr = if code >= 400 then red else green+ liftIO $ hPutStrLn handle $ concat [+ concat ["[", show addr, "] ", c, "\t"]+ , show mt, "\t"+ , show ur, " -> "+ , clr+ , show code, " "+ , show st+ , reset+ ]+
+ src/Network/Salvia/Handler/Login.hs view
@@ -0,0 +1,276 @@+module Network.Salvia.Handler.Login (++ -- * Basic types.+ Username+ , Password+ , Action+ , Actions+ , User (..)+ , Users+ , UserDatabase+ , TUserDatabase++ -- * User Sessions.+ , UserPayload (..)+ , UserSession+ , TUserSession+ , UserSessionHandler++ -- * Handlers.+ , hSignup+ , hLogin+ , hLogout+ , hLoginfo++ , hAuthorized+ , hAuthorizedUser++ -- * Helper functions.+ , readUserDatabase++ ) where++import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)+import Control.Monad.State (lift, liftM)+import Data.Digest.Pure.MD5 (md5)+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Record.Label+import Misc.Misc (atomModTVar, safeHead)+import Network.Protocol.Http (Status (Unauthorized, OK), status)+import Network.Salvia.Handler.Error (hCustomError, hError)+import Network.Salvia.Handler.Session+import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)+import Network.Protocol.Uri+import Data.ByteString.Lazy.UTF8 (fromString)++-------------------------------------------------------------------------------++type Username = String+type Password = String+type Action = String+type Actions = [Action]++{- |+User containg a username, password and a list of actions this user is allowed+to perform within the system.+-}++data User = User {+ username :: Username+ , password :: Password+ , email :: String+ , actions :: Actions+ } deriving (Eq, Show)++type Users = [User]++{- |+A user database containing a list of users, a list of default actions the guest+or `no-user' user is allowed to perform and a polymorphic reference to the+place the database originates from. This source field can be used by update+functions synchronizing changes back to the database.+-}++data UserDatabase src =+ UserDatabase {+ dbUsers :: Users+ , dbGuest :: Actions+ , dbSource :: src+ } deriving Show++type TUserDatabase src = TVar (UserDatabase src)++{- |+A user payload instance contains user related session information and can be+used as the payload for regular sessions. It contains a reference to the user+it is bound to, a flag to indicate whether the user is logged in or not and a+possible user specific session payload.+-}++data UserPayload a = UserPayload {+ upUser :: User+ , upLoggedIn :: Bool+ , upPayload :: Maybe a+ } deriving (Eq, Show)++type UserSession a = Session (UserPayload a)+type TUserSession a = TSession (UserPayload a)++{- | A handler that requires a session with a user specific payload. -}++type UserSessionHandler a b = SessionHandler (UserPayload a) b++-------------------------------------------------------------------------------++{-|+Read a user data from file. Format: /username password email action*/.+-}++readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)+readUserDatabase file = do++ -- First line contains the default `guest` actions, tail lines contain users.+ gst:ls <- lines `liftM` readFile file++ atomically $ newTVar $ UserDatabase+ (catMaybes $ map parseUserLine ls)+ (words gst)+ file+ where+ parseUserLine line =+ case words line of+ user:pass:mail:acts -> Just (User user pass mail acts)+ _ -> Nothing++printUserLine :: User -> String+printUserLine u = intercalate " " ([+ username u+ , password u+ , email u+ ] ++ actions u)++{- |+The signup handler is used to create a new entry in the user database. It reads+a new username and password from the HTTP POST parameters and adds a new entry+in the database when no user with such name exists. The user gets the specified+initial set of actions assigned. On failure an `Unauthorized' error will be+produced.+-}++hSignup :: TUserDatabase FilePath -> Actions -> Handler ()+hSignup tdb acts = do+ db <- lift . atomically $ readTVar tdb+ params <- uriEncodedPostParamsUTF8+ case freshUserInfo params (dbUsers db) acts of+ Nothing -> hCustomError Unauthorized "signup failed"+ Just u -> do+ lift $ do+ atomically+ $ writeTVar tdb+ $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)+ appendFile (dbSource db) (printUserLine u)++freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User+freshUserInfo params us acts = do+ p <- params+ user <- "username" `lookup` p >>= id+ pass <- "password" `lookup` p >>= id+ mail <- "email" `lookup` p >>= id+ case safeHead $ filter ((==user).username) us of+ Nothing -> return $ User user (show $ md5 $ fromString pass) mail acts+ Just _ -> Nothing++-------------------------------------------------------------------------------++{- |+The login handler. Read the username and password values from the post data and+use that to authenticate the user. When the user can be found in the database+the user is logged in and stored in the session payload. Otherwise a+`Unauthorized' response will be sent and the user has not logged in.+-}++hLogin :: UserDatabase b -> UserSessionHandler a ()+hLogin db session = do+ params <- uriEncodedPostParamsUTF8+ maybe+ (hCustomError Unauthorized "login failed")+ (loginSuccessful session)+ (authenticate params db)++authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User+authenticate params db = do+ p <- params+ user <- "username" `lookup` p >>= id+ pass <- "password" `lookup` p >>= id+ case safeHead $ filter ((==user).username) (dbUsers db) of+ Nothing -> Nothing+ Just u ->+ if password u == (show $ md5 $ fromString pass)+ then return u+ else Nothing++-- Login user and create `Ok' response on successful user.+loginSuccessful :: TUserSession a -> User -> Handler ()+loginSuccessful session user = do+ lift $ atomModTVar (\s -> s {sPayload = Just (UserPayload user True Nothing)}) session+ setM (status % response) OK+ sendStrLn "login successful"++-------------------------------------------------------------------------------++{- | Logout the current user by emptying the session payload. -}++hLogout :: TUserSession a -> Handler ()+hLogout session = do+ lift $ atomModTVar (\s -> s {sPayload = Nothing}) session+ return ()++-------------------------------------------------------------------------------++{- |+The `loginfo' handler exposes the current user session to the world using a+simple text based file. The file contains information about the current session+identifier, session start and expiration date and the possible user payload+that is included.+-}++hLoginfo :: UserSessionHandler a ()+hLoginfo session = do+ s' <- lift $ atomically $ readTVar session++ sendStrLn $ "sID=" ++ show (sID s')+ sendStrLn $ "start=" ++ show (sStart s')+ sendStrLn $ "expire=" ++ show (sExpire s')++ case sPayload s' of+ Nothing -> return ()+ Just (UserPayload (User uname _ mail acts) _ _) -> do+ sendStrLn $ "username=" ++ uname+ sendStrLn $ "email=" ++ mail+ sendStrLn $ "actions=" ++ intercalate " " acts++-------------------------------------------------------------------------------++{- |+Execute a handler only when the user for the current session is authorized to+do so. The user must have the specified action contained in its actions list in+order to be authorized. Otherwise an `Unauthorized' error will be produced.+When no user can be found in the current session or this user is not logged in+the guest account from the user database is used for authorization.+-}++hAuthorized ::+ UserDatabase b -- ^ The user database to read guest account from.+ -> Action -- ^ The actions that should be authorized.+ -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized.+ -> UserSessionHandler a () -- ^ This handler requires a user session.++hAuthorized db action handler session = do+ load <- liftM sPayload (lift $ atomically $ readTVar session)+ case load of+ Just (UserPayload user _ _)+ | action `elem` actions user -> handler (Just user)+ Nothing+ | action `elem` dbGuest db -> handler Nothing+ _ -> hError Unauthorized++{- |+Execute a handler only when the user for the current session is authorized to+do so. The user must have the specified action contained in its actions list in+order to be authorized. Otherwise an `Unauthorized' error will be produced. The+guest user will not be used in any case.+-}++hAuthorizedUser ::+ Action -- ^ The actions that should be authorized.+ -> (User -> Handler ()) -- ^ The handler to perform when authorized.+ -> UserSessionHandler a () -- ^ This handler requires a user session.++hAuthorizedUser action handler session = do+ load <- liftM sPayload (lift $ atomically $ readTVar session)+ case load of+ Just (UserPayload user _ _)+ | action `elem` actions user -> handler user+ _ -> hError Unauthorized+
+ src/Network/Salvia/Handler/MethodRouter.hs view
@@ -0,0 +1,78 @@+module Network.Salvia.Handler.MethodRouter (+ hMethod+ , hMethodRouter++ , hOPTIONS+ , hGET+ , hHEAD+ , hPOST+ , hPUT+ , hDELETE+ , hTRACE+ , hCONNECT+ ) where++import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Handler.Error+import Network.Salvia.Httpd++{- |+Request dispatcher based on the HTTP request `Method`. When the method does not+match an HTTP `NotFound` will be created and `Nothing` will be returned.+-}++hMethod :: Method -> Handler a -> Handler (Maybe a)+hMethod m h = hMethod' m+ (Just `fmap` h)+ (const Nothing `fmap` hError NotFound)++{- | Request list dispatcher based on the `hMethod` dispatcher. -}++hMethodRouter :: ListDispatcher Method ()+hMethodRouter = hListDispatch hMethod'++{- | Only invoke a handler on an `OPTIONS` request. -}++hOPTIONS :: Handler a -> Handler (Maybe a)+hOPTIONS = hMethod OPTIONS++{- | Only invoke a handler on a `GET` request. -}++hGET :: Handler a -> Handler (Maybe a)+hGET = hMethod GET++{- | Only invoke a handler on a `HEAD` request. -}++hHEAD :: Handler a -> Handler (Maybe a)+hHEAD = hMethod HEAD++{- | Only invoke a handler on a `POST` request. -}++hPOST :: Handler a -> Handler (Maybe a)+hPOST = hMethod POST++{- | Only invoke a handler on a `PUT` request. -}++hPUT :: Handler a -> Handler (Maybe a)+hPUT = hMethod PUT++{- | Only invoke a handler on a `DELETE` request. -}++hDELETE :: Handler a -> Handler (Maybe a)+hDELETE = hMethod DELETE++{- | Only invoke a handler on a `TRACE` request. -}++hTRACE :: Handler a -> Handler (Maybe a)+hTRACE = hMethod TRACE++{- | Only invoke a handler on a `CONNECT` request. -}++hCONNECT :: Handler a -> Handler (Maybe a)+hCONNECT = hMethod CONNECT++hMethod' :: Dispatcher Method a+hMethod' = hDispatch (method % request) (==)+
+ src/Network/Salvia/Handler/Parser.hs view
@@ -0,0 +1,51 @@+module Network.Salvia.Handler.Parser (hParser) where++import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO+import System.Timeout++{- |+The 'hParser' handler is used to parse the raw request message into the+'Message' data type. This handler is generally used as (one of) the first+handlers in an environment. The first handler argument is executed when the+request is invalid, possibly due to parser errors, and is parametrized with the+error string. The second handler argument is executed when the request is+valid. When the message could be parsed within the time specified with the+first argument the function silently returns.+-}++hParser ::+ Int -- ^ Timeout in milliseconds.+ -> (String -> Handler ()) -- ^ The fail handler.+ -> Handler () -- ^ The success handler.+ -> Handler ()++hParser t onfail onsuccess = do+ h <- getM sock+ -- TODO use try and fail with bad request or reject silently.+ mMsg <- liftIO $ timeout (t * 1000) $+ -- TODO: Using NoBuffering here may crash the entire program (GHC+ -- runtime?) when processing more requests than just a few:+ do hSetBuffering h (BlockBuffering (Just (64*1024)))+ fmap Just (readHeader h) `catch` const (return Nothing)+ case join mMsg of+ Nothing -> return ()+ Just msg -> + do case parseRequest (msg "") of+ Left err -> onfail (show err)+ Right x -> do+ setM request x+ onsuccess++-- Read all lines until the first empty line.+readHeader :: Handle -> IO (String -> String)+readHeader h = do+ l <- hGetLine h+ let lf = showChar '\n'+ if l `elem` ["", "\r"]+ then return lf+ else liftM ((showString l . lf) .) (readHeader h)+
+ src/Network/Salvia/Handler/PathRouter.hs view
@@ -0,0 +1,45 @@+module Network.Salvia.Handler.PathRouter (+ hPath+ , hPathRouter+ , hPrefix+ , hPrefixRouter++ , hParameters+ ) where++import Control.Monad.State+import Data.List (isPrefixOf)+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri (path, queryParams, Parameters)+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Httpd++{- | Request dispatcher based on the request path. -}++hPath :: Dispatcher String a+hPath p h = hDispatch (path % uri % request) (==) p (chop p h)++{- | List dispatcher version of `hPath`. -}++hPathRouter :: ListDispatcher String b+hPathRouter = hListDispatch hPath++{- | Request dispatcher based on a prefix of the request path. -}++hPrefix :: Dispatcher String a+hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)++{- | List dispatcher version of `hPrefix`. -}++hPrefixRouter :: ListDispatcher String b+hPrefixRouter = hListDispatch hPrefix++{- | Helper function to fetch the URI parameters from the request. -}++hParameters :: Handler Parameters+hParameters = getM (uri % request) >>= return . queryParams ++chop :: String -> Handler a -> Handler a+chop a = withM (path % uri % request) (modify (drop $ length a))+
+ src/Network/Salvia/Handler/Printer.hs view
@@ -0,0 +1,15 @@+module Network.Salvia.Handler.Printer (hPrinter) where++import Network.Salvia.Httpd++{- |+The 'hPrinter' handler print the entire response including the headers to the+client. This handler is generally used as (one of) the last handler in a+handler environment.+-}++hPrinter :: Handler ()+hPrinter =+ do flushHeaders+ flushQueue+
+ src/Network/Salvia/Handler/Put.hs view
@@ -0,0 +1,26 @@+module Network.Salvia.Handler.Put (hPut) where++import Control.Monad.State+import Network.Protocol.Http+import Network.Salvia.Handler.Error+import Network.Salvia.Httpd+import System.IO+import qualified Data.ByteString.Lazy as B++{- |+First naive handler for the HTTP `PUT` request. This probably does not handle+all the quirks that the HTTP protocol specifies, but it does the job for now.+When a 'contentLength' header field is available only this fixed number of+bytes will be spooled from socket to the resource. When both the `keepAlive'+and 'contentLength' header fields are not available the entire payload of the+request is spooled to the resource.+-}++hPut :: ResourceHandler ()+hPut name =+ safeIO (openBinaryFile name WriteMode)+ $ (contents >>=) . maybe putError . putOk+ where+ putError = hError NotImplemented+ putOk fd c = lift (B.hPut fd c >> hClose fd)+
+ src/Network/Salvia/Handler/Redirect.hs view
@@ -0,0 +1,18 @@+module Network.Salvia.Handler.Redirect (hRedirect) where++import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri (URI)+import Network.Salvia.Httpd++{- |+Redirect a client to another location by creating a `MovedPermanently` response+message with the specified `URI` in the `location' header.+-}++hRedirect :: URI -> Handler ()+hRedirect u =+ enterM response $ do+ setM location (Just u)+ setM status MovedPermanently+
+ src/Network/Salvia/Handler/Rewrite.hs view
@@ -0,0 +1,60 @@+module Network.Salvia.Handler.Rewrite (+ hRewrite+ , hRewritePath+ , hRewriteHost+ , hRewriteExt+ , hWithDir+ , hWithoutDir+ ) where++import Control.Monad.State+import Data.List (isPrefixOf)+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri (URI, host, path, extension)+import Network.Salvia.Httpd++{- |+Run an handler in a modified context in which the request `URI` has been+changed by the specified modifier function. After the handler completes the `URI`+remains untouched.+-}++hRewrite :: (URI -> URI) -> Handler a -> Handler a+hRewrite f = withM (uri % request) (modify f)++-- express these below in terms of the above?++{- | Run handler in a context with a modified host. -}++hRewriteHost :: (String -> String) -> Handler a -> Handler a+hRewriteHost f = withM (host % uri % request) (modify f)++{- | Run handler in a context with a modified path. -}++hRewritePath :: (String -> String) -> Handler a -> Handler a+hRewritePath f = withM (path % uri % request) (modify f)++{- | Run handler in a context with a modified file extension. -}++hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a+hRewriteExt f = withM (extension % path % uri % request) (modify f)++{- |+Run handler in a context with a modified path. The specified prefix will be+prepended to the path.+-}++hWithDir :: String -> Handler a -> Handler a+hWithDir d = hRewritePath (d++)++{- |+Run handler in a context with a modified path. The specified prefix will be+stripped form the path.+-}++hWithoutDir :: String -> Handler a -> Handler a+hWithoutDir d h = do+ p <- getM (path % uri % request)+ (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h+
+ src/Network/Salvia/Handler/Session.hs view
@@ -0,0 +1,192 @@+module Network.Salvia.Handler.Session (+ hSession++ , SessionID+ , Session (..)+ , TSession+ , SessionHandler+ , Sessions++ , mkSessions+ ) where++import Control.Applicative hiding (empty)+import Control.Concurrent.STM+import Control.Monad.State+import Data.Time.LocalTime+import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)+import Network.Protocol.Cookie hiding (empty)+import Network.Salvia.Handler.Cookie+import Network.Salvia.Httpd+import Prelude hiding (lookup)+import System.Random+import qualified Data.Map as M++-------------------------------------------------------------------------------++{- | A session identifier. Should be unique for every session. -}++newtype SessionID = SID Integer+ deriving (Eq, Ord)++{- | The session data type with polymorphic payload. -}++data Session a = Session {+ sID :: SessionID -- ^ A globally unique session identifier.+ , sStart :: LocalTime -- ^ The time the session started.+ , sExpire :: LocalTime -- ^ The time after which the session is expired.+ , sPayload :: Maybe a -- ^ The information this session stores.+ } deriving Show++{- | A shared session. -}++type TSession a = TVar (Session a)++{- | A handler that expects a session. -}++type SessionHandler a b = TSession a -> Handler b++{- | Create a new, empty, shared session. -}++mkSession :: SessionID -> LocalTime -> IO (TSession a)+mkSession sid e = do+ s <- now+ atomically $ newTVar $ Session sid s e Nothing++-------------------------------------------------------------------------------++{- | A mapping from unique session IDs to shared session variables. -}++type Sessions a = TVar (M.Map SessionID (TSession a))++instance Show SessionID where+ show (SID sid) = show sid++{- | Create a new, empty, store of sessions. -}++mkSessions :: IO (Sessions a)+mkSessions = atomically $ newTVar M.empty++-------------------------------------------------------------------------------++{- |+The session handler. This handler will try to return an existing session from+the sessions map based on a session identifier found in the HTTP `cookie`. When+such a session can be found the expiration date will be updated to a number of+seconds in the future. When no session can be found a new one will be created.+A cookie will be set that informs the client of the current session.+-}++hSession+ :: Sessions a -- ^ Map of shared session variables.+ -> Integer -- ^ Number of seconds to be added to the session expiritation time.+ -> Handler (TSession a)+hSession smap expiration = do++ -- Get the session identifier from an existing cookie or create a new one.+ prev <- getSessionID <$> hGetCookies++ -- Compute current time and expiration time.+ (n, ex) <- lift $ liftM2 (,) now (later expiration)++ -- Either create a new session or try to reuse current one.+ tsession <- + maybe+ (newSession smap ex)+ (existingSession smap ex n)+ prev++ setSessionCookie tsession ex+ return tsession++-------------------------------------------------------------------------------++{-+Given the (possible wrong) request cookie, try to recover the existing --+session identifier.+-}++getSessionID :: Maybe Cookies -> Maybe SessionID+getSessionID prev = do+ ck <- prev+ sid <- cookie "sid" ck+ sid' <- safeRead $ value sid+ return (SID sid')+ +{-+Generate a fresh, random session identifier using the default system random+generator.+-}++genSessionID :: IO SessionID+genSessionID = do+ g <- getStdGen+ let (sid, g') = random g+ setStdGen g'+ return (SID (abs sid))+++{-+This handler sets the HTTP cookie for the specified session. It will use a+default cookie with an additional `sid' attribute with the session identifier+as value. The session expiration date will be used as the cookie expire field.+-}++setSessionCookie :: TSession a -> LocalTime -> Handler ()+setSessionCookie tsession ex = do+ ck <- newCookie ex+ sid <- lift $ liftM sID $ atomReadTVar tsession+ hSetCookies $+ cookies [ck {+ name = "sid"+ , value = show sid+ }]++{-+Handler when no (valid) session is available. Create a new session with a+specified expiration date. The session will be stored in the session map.+-}++newSession :: Sessions a -> LocalTime -> Handler (TSession a)+newSession sessions ex = lift $ do++ -- Fresh session identifier.+ sid <- genSessionID++ -- Fresh session.+ session <- mkSession sid ex++ -- Place in session mapping usinf session identifier as key.+ atomModTVar (M.insert sid session) sessions+ return session++{-+Handler for existing sessions. Given an existing session identifier lookup a+session from the session map. When no session is available, or the session is+expired, create a new one using the `newSession' function. Otherwise the+expiration date of the existing session is updated.+-}++existingSession ::+ Sessions a -> LocalTime -> LocalTime+ -> SessionID -> Handler (TSession a)+existingSession sessions ex n sid = do++ -- Lookup the session in the session map given the session identifier.+ mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)+ case mtsession of++ -- Unrecognized session identifiers are penalised by a fresh session.+ Nothing -> newSession sessions ex+ Just tsession -> do+ expd <- lift $ liftM sExpire (atomReadTVar tsession)+ if expd < n++ -- Session is expired, create a new one.+ then newSession sessions ex++ -- Existing session, update expiration date.+ else lift $ do+ atomModTVar (\s -> s {sExpire = ex}) tsession+ return tsession+
+ src/Network/Salvia/Handler/VirtualHosting.hs view
@@ -0,0 +1,34 @@+module Network.Salvia.Handler.VirtualHosting (+ hHostRouter+ , hVirtualHosting+ ) where++import Data.Ord+import Data.List+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Httpd hiding (hostname)++{- |+List dispatcher based on the host part of the hostname request header.+Everything not part of the real hostname (like the port number) will be+ignored.+-}++hVirtualHosting :: ListDispatcher String a+hVirtualHosting = (hListDispatch disp) . parse+ where+ disp = hDispatch (hostname % request) cmp+ parse = map (\(a, b) -> (parseAuthority a, b))+ cmp a b = (==EQ) $ comparing (fmap (lget _host)) a b++{- |+List dispatcher based on the hostname request header. This header field is+parsed and interpreted as an `Authority` field.+-}++hHostRouter :: ListDispatcher (Maybe Authority) a+hHostRouter = hListDispatch $ hDispatch (hostname % request) (==)+
+ src/Network/Salvia/Handlers.hs view
@@ -0,0 +1,213 @@+module Network.Salvia.Handlers (++ -- * Fundamental protocol handlers.++ -- ** Default handler environments.++ hDefaultEnv+ , hSessionEnv++ -- ** Parse client requests.++ , hParser++ -- ** Print server responses.++ , hPrinter++ -- ** HTTP header banner.++ , hBanner++ -- ** Closing or keeping alive connections.++ , hCloseConn+ , hKeepAlive++ -- ** Enable HTTP HEAD requests.+ + , hHead++ -- * Error handling and logging.++ -- ** Default error handlers.++ , hError+ , hCustomError+ , hIOError+ , safeIO++ -- ** Logging of client requests.++ , hLog+ , hLogWithCounter++ -- ** Fallback handlers.++ , hOr+ , hEither++ -- ** Request counter.++ , hCounter++ -- * Redirecting and rewriting.++ -- ** Redirecting the client.++ , hRedirect++ -- ** Request URI rewriting.++ , hRewrite+ , hRewriteHost+ , hRewritePath+ , hRewriteExt+ , hWithDir+ , hWithoutDir++ -- * File and directory serving.++ -- ** Serve static file resources.++ , hFileResource+ , hFileResourceFilter+ , hResource+ , hUri+ , hFile+ , hFileFilter++ -- ** Serve directory indices.++ , hDirectory+ , hDirectoryResource++ -- ** Serve file system directory.++ , hFileTypeDispatcher+ , hFileSystem+ , hFileSystemNoIndexes++ -- ** Enable PUTing resources to the files ystem.++ , hPut++ -- ** Serving CGI scripts.++ , hCGI++ -- * Dispatching.++ -- ** Custom request dispatchers.++ , Dispatcher+ , ListDispatcher+ , hDispatch+ , hListDispatch++ -- ** Dispatch based on request method.++ , hMethod+ , hMethodRouter++ , hOPTIONS+ , hGET+ , hHEAD+ , hPOST+ , hPUT+ , hDELETE+ , hTRACE+ , hCONNECT++ -- ** Dispatch based on request path.++ , hPath+ , hPathRouter+ , hPrefix+ , hPrefixRouter+ , hParameters++ -- ** Dispatch based on filename extension.++ , hExtension+ , hExtensionRouter++ -- ** Dispatch based on host name.++ , hHostRouter+ , hVirtualHosting++ -- * Session and user management.++ -- ** Cookie handling.++ , hSetCookies+ , hGetCookies+ , newCookie++ -- ** Session management.++ , hSession++ , SessionID+ , Session (..)+ , TSession+ , SessionHandler+ , Sessions++ , mkSessions++ -- ** User management.++ , Username+ , Password+ , Action+ , Actions+ , User (..)+ , Users+ , UserDatabase+ , TUserDatabase++ , UserPayload (..)+ , UserSession+ , TUserSession+ , UserSessionHandler++ , hSignup+ , hLogin+ , hLogout+ , hLoginfo++ , hAuthorized+ , hAuthorizedUser++ , readUserDatabase++ ) where++import Network.Salvia.Handler.Banner+import Network.Salvia.Handler.CGI+import Network.Salvia.Handler.Close+import Network.Salvia.Handler.Cookie+import Network.Salvia.Handler.Counter+import Network.Salvia.Handler.Directory+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Handler.Environment+import Network.Salvia.Handler.Error+import Network.Salvia.Handler.ExtensionDispatcher+import Network.Salvia.Handler.Fallback+import Network.Salvia.Handler.File+import Network.Salvia.Handler.FileSystem+import Network.Salvia.Handler.Head+import Network.Salvia.Handler.Log+import Network.Salvia.Handler.Login+import Network.Salvia.Handler.MethodRouter+import Network.Salvia.Handler.Parser+import Network.Salvia.Handler.PathRouter+import Network.Salvia.Handler.Printer+import Network.Salvia.Handler.Put+import Network.Salvia.Handler.Redirect+import Network.Salvia.Handler.Rewrite+import Network.Salvia.Handler.Session+import Network.Salvia.Handler.VirtualHosting+
− src/Network/Salvia/Handlers/Banner.hs
@@ -1,26 +0,0 @@-module Network.Salvia.Handlers.Banner (hBanner) where--import Control.Monad.State-import Data.Record.Label-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (formatTime)-import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)-import Network.Protocol.Http-import Network.Salvia.Httpd-import System.Locale (defaultTimeLocale)---- | The 'hBanner' handler adds the current date-/timestamp and a custom server--- name to the response headers.--hBanner ::- String -- ^ The HTTP server name.- -> Handler ()-hBanner sv = do- dt <- lift $ do- zone <- getCurrentTimeZone- time <- liftM (utcToLocalTime zone) getCurrentTime- return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time- enterM response $ do- setM date dt- setM server sv-
− src/Network/Salvia/Handlers/CGI.hs
@@ -1,18 +0,0 @@-module Network.Salvia.Handlers.CGI (hCGI) where--import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd-import System.IO-import System.Process (runProcess, waitForProcess)--hCGI :: FilePath -> Handler ()-hCGI name = do- setM (status % response) OK- h <- getM sock- lift $ do- p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)- waitForProcess p- return ()-
− src/Network/Salvia/Handlers/Cookie.hs
@@ -1,37 +0,0 @@-module Network.Salvia.Handlers.Cookie (- hSetCookies- , hGetCookies-- , newCookie- ) where--import Control.Applicative hiding (empty)-import Control.Monad.State-import Data.Record.Label-import Data.Time.Format-import Data.Time.LocalTime-import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires)-import Network.Protocol.Http (cookie)-import Network.Salvia.Httpd-import System.Locale (defaultTimeLocale)--hSetCookies :: Cookies -> Handler ()-hSetCookies = setM (cookie % response) . showCookies--hGetCookies :: Handler (Maybe Cookies)-hGetCookies = parseCookies <$> getM (cookie % request)---- Convenient method for creating cookies that expire in the near future and--- are bound to the domain and port this server runs on. The path will be--- locked to root.-newCookie :: LocalTime -> Handler Cookie-newCookie expire = do- httpd <- getM config- return $ empty {- path = Just "/"--- , domain = Just $ '.' : hostname httpd- , port = [fromEnum $ listenPort httpd]- , expires = Just $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire- }--
− src/Network/Salvia/Handlers/Counter.hs
@@ -1,10 +0,0 @@-module Network.Salvia.Handlers.Counter (hCounter) where--import Control.Concurrent.STM-import Control.Monad.State-import Network.Salvia.Httpd--hCounter :: TVar Int -> Handler ()-hCounter c = lift $ atomically- $ readTVar c >>= writeTVar c . (+1)-
− src/Network/Salvia/Handlers/Default.hs
@@ -1,30 +0,0 @@-module Network.Salvia.Handlers.Default (hDefault) where--import Control.Concurrent.STM-import Network.Protocol.Http-import Network.Salvia.Handlers.Banner-import Network.Salvia.Handlers.Counter-import Network.Salvia.Handlers.Error-import Network.Salvia.Handlers.Head-import Network.Salvia.Handlers.Log-import Network.Salvia.Handlers.Parser-import Network.Salvia.Handlers.Printer-import Network.Salvia.Handlers.Session-import Network.Salvia.Httpd-import System.IO--hDefault :: Show a => TVar Int -> Sessions a -> SessionHandler a () -> Handler ()-hDefault count sessions handler = do- hBanner "salvia-httpd"- hParser onerror $ do- session <- hSession sessions 300- hHead $ handler session- hPrinter- hLog count stdout- hCounter count- where- onerror err = do- hError BadRequest- sendStrLn []- sendStrLn err-
− src/Network/Salvia/Handlers/Directory.hs
@@ -1,55 +0,0 @@-module Network.Salvia.Handlers.Directory (- hDirectory- , hDirectoryResource- ) where--import Control.Monad.State-import Data.List (sort)-import Data.Record.Label-import Misc.Misc (bool)-import Network.Protocol.Http-import Network.Protocol.Uri (path)-import Network.Salvia.Handlers.File (hResource)-import Network.Salvia.Handlers.Redirect-import Network.Salvia.Httpd-import System.Directory (doesDirectoryExist, getDirectoryContents)--hDirectory :: Handler ()-hDirectory = hResource hDirectoryResource--hDirectoryResource :: ResourceHandler ()-hDirectoryResource dirName = do- (u, p) <- bothM (uri % request) (getM path)- if (null p) || last p /= '/'- then hRedirect (lmod path (++"/") u)- else dirHandler dirName--dirHandler:: ResourceHandler ()-dirHandler dirName = do- p <- getM (path % uri % request)- filenames <- lift $ getDirectoryContents dirName- processed <- lift $ mapM (processFilename dirName) (sort filenames)- let b = listing p processed- enterM response $ do- setM contentType ("text/html", Nothing)- setM contentLength (Just $ fromIntegral $ length b)- setM status OK- sendStr b---- Add trailing slash to a directory name.-processFilename :: FilePath -> FilePath -> IO FilePath-processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f)---- Turn a list of filenames into HTML directory listing.-listing :: FilePath -> [FilePath] -> String-listing dirName fileNames =- concat [- "<html><head><title>Index of "- , dirName- , "</title></head><body><h1>Index of "- , dirName- , "</h1><ul>"- , fileNames >>= \f -> concat ["<li><a href='", f, "'>", f, "</a></li>"]- , "</ul></body></html>"- ]-
− src/Network/Salvia/Handlers/Dispatching.hs
@@ -1,23 +0,0 @@-module Network.Salvia.Handlers.Dispatching (- Dispatcher- , ListDispatcher- , hDispatch- , hListDispatch- ) where--import Data.Record.Label-import Network.Salvia.Httpd--type Dispatcher a b = a -> Handler b -> Handler b -> Handler b-type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b--hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b-hDispatch f match a handler _default = do- ctx <- getM f- if a `match` ctx- then handler- else _default--hListDispatch :: Dispatcher a b -> ListDispatcher a b-hListDispatch disp = flip $ foldr $ uncurry disp-
− src/Network/Salvia/Handlers/Error.hs
@@ -1,47 +0,0 @@-module Network.Salvia.Handlers.Error (- hError- , hCustomError- , hIOError- , safeIO- ) where--import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd-import System.IO.Error--{- |-The 'hError' handler enables the creation of a default style of error responses-for the specified HTTP status code.--}--hError ::- Status -- ^ The HTTP status code.- -> Handler ()-hError e = hCustomError e- (concat ["[", show (codeFromStatus e), "] ", show e, "\n"])--hCustomError ::- Status -- ^ The HTTP status code.- -> String -- ^ Custom error message.- -> Handler ()-hCustomError e m = do- enterM response $ do- setM status e- setM contentType ("text/plain", Nothing)- sendStr m---- | Map IO errors to a default style error response.-hIOError :: IOError -> Handler ()-hIOError e- | isDoesNotExistError e = hError NotFound- | isAlreadyInUseError e = hError ServiceUnavailable- | isPermissionError e = hError Forbidden- | True = hError InternalServerError---- | Execute an handler with the result of an IO action. When the IO actions--- fails a default error handler will be executed.-safeIO :: IO a -> (a -> Handler ()) -> Handler ()-safeIO io h = lift (try io) >>= either hIOError h-
− src/Network/Salvia/Handlers/ExtensionDispatcher.hs
@@ -1,17 +0,0 @@-module Network.Salvia.Handlers.ExtensionDispatcher (- hExtension- , hExtensionRouter- ) where--import Data.Record.Label-import Network.Protocol.Http (uri)-import Network.Protocol.Uri (extension, path)-import Network.Salvia.Handlers.Dispatching-import Network.Salvia.Httpd (request)--hExtension :: Dispatcher (Maybe String) a-hExtension = hDispatch (extension % path % uri % request) (==)--hExtensionRouter :: ListDispatcher (Maybe String) a-hExtensionRouter = hListDispatch hExtension-
− src/Network/Salvia/Handlers/Fallback.hs
@@ -1,25 +0,0 @@-module Network.Salvia.Handlers.Fallback (hOr, hEither) where--import Control.Applicative-import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd--{- |-Until I figure out how to do this correctly, this handler somewow implements-the MonadPlus/Alternative instance using a custom function. When the first-handler fails the response will be reset and the second handler is executed.--}--hOr :: Handler a -> Handler a -> Handler a-hOr h0 h1 = do- a <- h0- st <- getM (status % response)- if statusFailure st- then reset >> h1- else return a--hEither :: Handler a -> Handler b -> Handler (Either a b)-hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)-
− src/Network/Salvia/Handlers/File.hs
@@ -1,69 +0,0 @@-module Network.Salvia.Handlers.File (- hFile- , hFileResource-- , hFileFilter- , hFileResourceFilter-- , hResource- , hUri- ) where--import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Mime-import Network.Protocol.Uri (mimetype, path, parseURI)-import Network.Salvia.Handlers.Error-import Network.Salvia.Httpd-import System.IO--hFile :: Handler ()-hFile = hResource hFileResource--hFileFilter :: (String -> String) -> Handler ()-hFileFilter = hResource . hFileResourceFilter--{--Turn a resource handler into a regular handler that utilizes the path part-of the request URI as the resource identifier.--}--hResource :: ResourceHandler a -> Handler a-hResource rh = getM (path % uri % request) >>= rh--{--Turn a URI handler into a regular handler that utilizes the request URI as the-resource identifier.--}--hUri :: UriHandler a -> Handler a-hUri rh = getM (uri % request) >>= rh---------- HTTP deamon implementation ----------------------------------------------- Create a response message containing the file contents.--- TODO: what to do with encoding?-hFileResource :: ResourceHandler ()-hFileResource file = do- let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)- safeIO (openBinaryFile file ReadMode)- $ \fd -> do- fs <- lift $ hFileSize fd- enterM response $ do- setM contentType (m, Just "utf-8")- setM contentLength (Just fs)- setM status OK- spoolBs id fd---- TODO: what to do with encoding?-hFileResourceFilter :: (String -> String) -> ResourceHandler ()-hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter- let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)- safeIO (openBinaryFile file ReadMode)- $ \fd -> do- enterM response $ do- setM contentType (m, Just "utf-8")- setM status OK- spool fFilter fd-
− src/Network/Salvia/Handlers/FileSystem.hs
@@ -1,38 +0,0 @@-module Network.Salvia.Handlers.FileSystem (- hFileSystem- , hFileSystemNoIndexes- , hFileTypeDispatcher- ) where--import Control.Monad.State-import Data.Record.Label-import Misc.Misc (bool)-import Network.Protocol.Http-import Network.Protocol.Uri (jail, path)-import Network.Salvia.Handlers.Directory-import Network.Salvia.Handlers.Error-import Network.Salvia.Handlers.File-import Network.Salvia.Httpd-import System.Directory (doesDirectoryExist)---- Show file contents and show directory indexes.-hFileSystem :: ResourceHandler ()-hFileSystem dir = hFileTypeDispatcher dir hDirectoryResource hFileResource---- Show file contents, do not show directory indexes.-hFileSystemNoIndexes :: ResourceHandler ()-hFileSystemNoIndexes dir = hFileTypeDispatcher dir (const $ hError Forbidden) hFileResource---- Dispatch based on file type, regular files or directories.-hFileTypeDispatcher :: FilePath -> ResourceHandler () -> ResourceHandler () -> Handler () -hFileTypeDispatcher dir hdir hfile =- getM (path % uri % request) >>=- hJailedDispatch dir hdir hfile . (dir ++)--hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler () -hJailedDispatch dir hdir hfile file = do- case jail dir file of- Nothing -> hError Forbidden- Just f -> bool (hdir file) (hfile file)- =<< lift (doesDirectoryExist f) -
− src/Network/Salvia/Handlers/Head.hs
@@ -1,23 +0,0 @@-module Network.Salvia.Handlers.Head (hHead) where--import Control.Applicative-import Control.Monad.State (put)-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd--{- |-The 'hHead' handler makes sure no response body is sent to the client when the-request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the-specified sub handler will be executed under the assumption that the request-was a 'GET' request, otherwise this handler will act as the identify function.--}--hHead :: Handler a -> Handler a-hHead handler = do- m <- getM (method % request)- case m of- HEAD -> withM (method % request) (put GET) $- handler <* emptyQueue- _ -> handler-
− src/Network/Salvia/Handlers/Log.hs
@@ -1,31 +0,0 @@-module Network.Salvia.Handlers.Log (hLog) where--import Control.Concurrent.STM-import Control.Monad.State-import Data.Record.Label-import Misc.Terminal (red, green, reset)-import Network.Protocol.Http-import Network.Salvia.Httpd (Handler, request, response, address)-import System.IO---- TODO: handle should be tvar as well-hLog :: TVar Int -> Handle -> Handler Handle-hLog count handle = do- c <- lift $ atomically $ readTVar count- mt <- getM (method % request)- ur <- getM (uri % request)- st <- getM (status % response)- addr <- getM address- let code = codeFromStatus st- clr = if code >= 400 then red else green- lift $ hPutStrLn handle $ concat [- concat ["[", show addr, "] ", show c, "\t"]- , show mt, "\t"- , show ur, " -> "- , clr- , show code, " "- , show st- , reset- ]- return handle-
− src/Network/Salvia/Handlers/Login.hs
@@ -1,272 +0,0 @@-module Network.Salvia.Handlers.Login (-- -- * Basic types.- Username- , Password- , Action- , Actions- , User (..)- , Users- , UserDatabase- , TUserDatabase-- -- * User Sessions.- , UserPayload (..)- , UserSession- , TUserSession- , UserSessionHandler-- -- * Handlers.- , hSignup- , hLogin- , hLogout- , hLoginfo-- , hAuthorized- , hAuthorizedUser-- -- * Helper functions.- , readUserDatabase-- ) where--import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)-import Control.Monad.State (lift, liftM)-import Data.Digest.OpenSSL.MD5 (md5sum)-import Data.List (intercalate)-import Data.Maybe (catMaybes)-import Data.Record.Label-import Misc.Misc (atomModTVar, safeHead)-import Network.Protocol.Http (Status (Unauthorized, OK), status)-import Network.Salvia.Handlers.Error (hCustomError, hError)-import Network.Salvia.Handlers.Session-import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)-import Network.Protocol.Uri-import Data.ByteString.UTF8 (fromString)-----------------------------------------------------------------------------------type Username = String-type Password = String-type Action = String-type Actions = [Action]--{- |-User containg a username, password and a list of actions this user is allowed-to perform within the system.--}--data User = User {- username :: Username- , password :: Password- , email :: String- , actions :: Actions- } deriving (Eq, Show)--type Users = [User]--{- |-A user database containing a list of users, a list of default actions the guest-or `no-user' user is allowed to perform and a polymorphic reference to the-place the database originates from. This source field cab be used by update-functions synchronizing changes back to the database.--}--data UserDatabase src =- UserDatabase {- dbUsers :: Users- , dbGuest :: Actions- , dbSource :: src- } deriving Show--type TUserDatabase src = TVar (UserDatabase src)--{- |-A user payload instance contains user related session information and can be-used as the payload for regular sessions. It contains a reference to the user-it is bound to, a flag to indicate whether the user is logged in or not and a-possible user specific session payload.--}--data UserPayload a = UserPayload {- upUser :: User- , upLoggedIn :: Bool- , upPayload :: Maybe a- } deriving (Eq, Show)--type UserSession a = Session (UserPayload a)-type TUserSession a = TSession (UserPayload a)---- A handler that requires a session with a user specific payload.-type UserSessionHandler a b = SessionHandler (UserPayload a) b------------------------------------------------------------------------------------- Read user data file.--- Format: username password action*--readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)-readUserDatabase file = do-- -- First line contains the default `guest` actions, tail lines contain users.- gst:ls <- lines `liftM` readFile file-- atomically $ newTVar $ UserDatabase- (catMaybes $ map parseUserLine ls)- (words gst)- file- where- parseUserLine line =- case words line of- user:pass:mail:acts -> Just (User user pass mail acts)- _ -> Nothing--printUserLine :: User -> String-printUserLine u = intercalate " " ([- username u- , password u- , email u- ] ++ actions u)--{- |-The signup handler is used to create a new entry in the user database. It reads-a new username and password from the HTTP POST parameters and adds a new entry-in the database when no user with such name exists. The user gets the specified-initial set of actions assigned. On failure an `Unauthorized' error will be-produced.--}--hSignup :: TUserDatabase FilePath -> Actions -> Handler ()-hSignup tdb acts = do- db <- lift . atomically $ readTVar tdb- params <- uriEncodedPostParamsUTF8- case freshUserInfo params (dbUsers db) acts of- Nothing -> hCustomError Unauthorized "signup failed"- Just u -> do- lift $ do- atomically- $ writeTVar tdb- $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)- appendFile (dbSource db) (printUserLine u)--freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User-freshUserInfo params us acts = do- p <- params- user <- "username" `lookup` p >>= id- pass <- "password" `lookup` p >>= id- mail <- "email" `lookup` p >>= id- case safeHead $ filter ((==user).username) us of- Nothing -> return $ User user (md5sum $ fromString pass) mail acts- Just _ -> Nothing-----------------------------------------------------------------------------------{- |-The login handler. Read the username and password values from the post data and-use that to authenticate the user. When the user can be found in the database-the user is logged in and stored in the session payload. Otherwise a-`Unauthorized' response will be sent and the user has not logged in.--}--hLogin :: UserDatabase b -> UserSessionHandler a ()-hLogin db session = do- params <- uriEncodedPostParamsUTF8- maybe- (hCustomError Unauthorized "login failed")- (loginSuccessful session)- (authenticate params db)--authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User-authenticate params db = do- p <- params- user <- "username" `lookup` p >>= id- pass <- "password" `lookup` p >>= id- case safeHead $ filter ((==user).username) (dbUsers db) of- Nothing -> Nothing- Just u ->- if password u == md5sum (fromString pass)- then return u- else Nothing---- Login user and create `Ok' response on successful user.-loginSuccessful :: TUserSession a -> User -> Handler ()-loginSuccessful session user = do- lift $ atomModTVar (\s -> s {payload = Just (UserPayload user True Nothing)}) session- setM (status % response) OK- sendStrLn "login successful"-----------------------------------------------------------------------------------hLogout :: TUserSession a -> Handler ()-hLogout session = do- lift $ atomModTVar (\s -> s {payload = Nothing}) session- return ()-----------------------------------------------------------------------------------{- |-The `loginfo' handler exposes the current user session to the world using a-simple text based file. The file contains information about the current session-identifier, session start and expiration date and the possible user payload-that is included.--}--hLoginfo :: UserSessionHandler a ()-hLoginfo session = do- s' <- lift $ atomically $ readTVar session-- sendStrLn $ "sID=" ++ show (sID s')- sendStrLn $ "start=" ++ show (start s')- sendStrLn $ "expire=" ++ show (expire s')-- case payload s' of- Nothing -> return ()- Just (UserPayload (User uname _ mail acts) _ _) -> do- sendStrLn $ "username=" ++ uname- sendStrLn $ "email=" ++ mail- sendStrLn $ "actions=" ++ intercalate " " acts-----------------------------------------------------------------------------------{- |-Execute a handler only when the user for the current session is authorized to-do so. The user must have the specified action contained in its actions list in-order to be authorized. Otherwise an `Unauthorized' error will be produced.-When no user can be found in the current session or this user is not logged in-the guest account from the user database is used for authorization.--}--hAuthorized ::- UserDatabase b -- ^ The user database to read guest account from.- -> Action -- ^ The actions that should be authorized.- -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized.- -> UserSessionHandler a () -- ^ This handler requires a user session.--hAuthorized db action handler session = do- load <- liftM payload (lift $ atomically $ readTVar session)- case load of- Just (UserPayload user _ _)- | action `elem` actions user -> handler (Just user)- Nothing- | action `elem` dbGuest db -> handler Nothing- _ -> hError Unauthorized--{- |-Execute a handler only when the user for the current session is authorized to-do so. The user must have the specified action contained in its actions list in-order to be authorized. Otherwise an `Unauthorized' error will be produced. The-guest user will not be used in any case.--}--hAuthorizedUser ::- Action -- ^ The actions that should be authorized.- -> (User -> Handler ()) -- ^ The handler to perform when authorized.- -> UserSessionHandler a () -- ^ This handler requires a user session.--hAuthorizedUser action handler session = do- load <- liftM payload (lift $ atomically $ readTVar session)- case load of- Just (UserPayload user _ _)- | action `elem` actions user -> handler user- _ -> hError Unauthorized-
− src/Network/Salvia/Handlers/MethodRouter.hs
@@ -1,42 +0,0 @@-module Network.Salvia.Handlers.MethodRouter (- hMethod- , hMethodRouter-- , hOPTIONS- , hGET- , hHEAD- , hPOST- , hPUT- , hDELETE- , hTRACE- , hCONNECT- ) where--import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Handlers.Dispatching-import Network.Salvia.Handlers.Error-import Network.Salvia.Httpd--hMethod' :: Dispatcher Method a-hMethod' = hDispatch (method % request) (==)--hMethodRouter :: ListDispatcher Method a-hMethodRouter = hListDispatch hMethod'--hMethod :: Method -> Handler () -> Handler ()-hMethod m k = hMethod' m k (hError NotFound)---- Shortcut handlers that only work for specific method types or fail.-hOPTIONS, hGET, hHEAD, hPOST, hPUT, hDELETE, hTRACE, hCONNECT- :: Handler () -> Handler ()--hOPTIONS = hMethod OPTIONS-hGET = hMethod GET-hHEAD = hMethod HEAD-hPOST = hMethod POST-hPUT = hMethod PUT-hDELETE = hMethod DELETE-hTRACE = hMethod TRACE-hCONNECT = hMethod CONNECT-
− src/Network/Salvia/Handlers/Parser.hs
@@ -1,41 +0,0 @@-module Network.Salvia.Handlers.Parser (hParser) where--import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd-import System.IO-import Text.ParserCombinators.Parsec (parse)--{- |-The 'hParser' handler is used to parse the raw request message into the-'Message' data type. This handler is generally used as (one of) the first-handlers in a configuration. The first handler argument is executed when the-request is invalid, possibly due to parser errors. The second handler argument-is executed when the request is valid.--}--hParser ::- (String -> Handler a) -- ^ The fail handler.- -> Handler a -- ^ The succeed handler.- -> Handler a--hParser onfail onsuccess = do- h <- getM sock- -- TODO use try and fail with bad request or reject silently.- msg <- lift $ readHeader h `catch` error "AAAAp"- case parse pRequest "" (msg "") of- Left err -> onfail (show err)- Right x -> do- setM request x- onsuccess---- Read all lines until the first empty line.-readHeader :: Handle -> IO (String -> String)-readHeader h = do- l <- hGetLine h- let lf = showChar '\n'- if l `elem` ["", "\r"]- then return lf- else liftM ((showString l . lf) .) (readHeader h)-
− src/Network/Salvia/Handlers/PathRouter.hs
@@ -1,37 +0,0 @@-module Network.Salvia.Handlers.PathRouter (- hPath- , hPathRouter- , hPrefix- , hPrefixRouter-- , hParameters- ) where--import Control.Monad.State-import Data.List (isPrefixOf)-import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Uri (path, queryParams, Parameters)-import Network.Salvia.Handlers.Dispatching-import Network.Salvia.Httpd--chop :: String -> Handler a -> Handler a-chop a = withM (path % uri % request) (modify (drop $ length a))--hPath :: Dispatcher String a-hPath p h = hDispatch (path % uri % request) (==) p (chop p h)--hPathRouter :: ListDispatcher String b-hPathRouter = hListDispatch hPath--hPrefix :: Dispatcher String a-hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)--hPrefixRouter :: ListDispatcher String b-hPrefixRouter = hListDispatch hPrefix---- Path related utilities.--hParameters :: Handler Parameters-hParameters = getM (uri % request) >>= return . queryParams -
− src/Network/Salvia/Handlers/Printer.hs
@@ -1,23 +0,0 @@-module Network.Salvia.Handlers.Printer (hPrinter) where--import Control.Monad.State-import Data.Record.Label (getM)-import Network.Salvia.Httpd--{- |-The 'hPrinter' handler print the entire response including the headers to the-client. This handler is generally used as (one of) the last handler in a-configuration.--}--hPrinter :: Handler ()-hPrinter = do-- -- Send the entire HTTP response header.- sendHeaders-- -- Process all send actions in queue.- s <- getM sock- q <- getM queue- lift $ mapM_ ($ s) q-
− src/Network/Salvia/Handlers/Put.hs
@@ -1,26 +0,0 @@-module Network.Salvia.Handlers.Put (hPut) where--import Control.Monad.State-import Network.Protocol.Http-import Network.Salvia.Handlers.Error-import Network.Salvia.Httpd-import System.IO-import qualified Data.ByteString.Lazy as B--{- |-First naive handler for the PUT request. This probably does not handle all the-quirks that the HTTP protocol specifies, but it does the job for now. When a-'ContentLength' header field is available only this fixed number of bytes will-be spooled from socket to the resource. When both the KeepAlive' and-'ContentLength' header fields are not available the entire payload of the-request is spooled to the resource.---}--hPut :: ResourceHandler ()-hPut name =- safeIO (openBinaryFile name WriteMode)- $ (contents >>=) . maybe putError . putOk- where- putError = hError NotImplemented- putOk fd c = lift (B.hPut fd c >> hClose fd)-
− src/Network/Salvia/Handlers/Redirect.hs
@@ -1,13 +0,0 @@-module Network.Salvia.Handlers.Redirect (hRedirect) where--import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Uri (URI)-import Network.Salvia.Httpd--hRedirect :: URI -> Handler ()-hRedirect u =- enterM response $ do- setM location (Just u)- setM status MovedPermanently-
− src/Network/Salvia/Handlers/Rewrite.hs
@@ -1,38 +0,0 @@-module Network.Salvia.Handlers.Rewrite (- hRewrite- , hRewritePath- , hRewriteHost- , hRewriteExt- , hWithDir- , hWithoutDir- ) where--import Control.Monad.State-import Data.List (isPrefixOf)-import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Uri (URI, host, path, extension)-import Network.Salvia.Httpd--hRewrite :: (URI -> URI) -> Handler a -> Handler a-hRewrite f = withM (uri % request) (modify f)---- express these below in terms of the above?--hRewriteHost :: (String -> String) -> Handler a -> Handler a-hRewriteHost f = withM (host % uri % request) (modify f)--hRewritePath :: (String -> String) -> Handler a -> Handler a-hRewritePath f = withM (path % uri % request) (modify f)--hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a-hRewriteExt f = withM (extension % path % uri % request) (modify f)--hWithDir :: String -> Handler a -> Handler a-hWithDir d = hRewritePath (d++)--hWithoutDir :: String -> Handler a -> Handler a-hWithoutDir d h = do- p <- getM (path % uri % request)- (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h-
− src/Network/Salvia/Handlers/Session.hs
@@ -1,180 +0,0 @@-module Network.Salvia.Handlers.Session (- hSession-- , SessionID- , Session (..)- , TSession- , SessionHandler- , Sessions-- , mkSessions- ) where--import Control.Applicative hiding (empty)-import Control.Concurrent.STM-import Control.Monad.State-import Data.Time.LocalTime-import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)-import Network.Protocol.Cookie hiding (empty)-import Network.Salvia.Handlers.Cookie-import Network.Salvia.Httpd hiding (start)-import Prelude hiding (lookup)-import System.Random-import qualified Data.Map as M------------------------------------------------------------------------------------- A session identifier. Should be unique for every session.-newtype SessionID = SID Integer- deriving (Eq, Ord)---- The session data type with polymorph payload.-data Session a = Session {- sID :: SessionID- , start :: LocalTime- , expire :: LocalTime- , payload :: Maybe a- } deriving Show---- A shared session.-type TSession a = TVar (Session a)---- A handler that expects a session.-type SessionHandler a b = TSession a -> Handler b---- Create a new, empty, shared session.-mkSession :: SessionID -> LocalTime -> IO (TSession a)-mkSession sid e = do- s <- now- atomically $ newTVar $ Session sid s e Nothing-----------------------------------------------------------------------------------type Sessions a = TVar (M.Map SessionID (TSession a))--instance Show SessionID where- show (SID sid) = show sid--mkSessions :: IO (Sessions a)-mkSessions = atomically $ newTVar M.empty-----------------------------------------------------------------------------------{--The session handler. This handler will try to return an existing session from-the sessions map based on a session identifier found in the HTTP cookie. When-such a session can be found the expiration date will be updated to a number of-seconds in the future. When no session can be found a new one will be created.-A cookie will be set that informs the client of the current session.--}--hSession :: Sessions a -> Integer -> Handler (TSession a)-hSession smap expiration = do-- -- Get the session identifier from an existing cookie or create a new one.- prev <- getSessionID <$> hGetCookies-- -- Compute current time and expiration time.- (n, ex) <- lift $ liftM2 (,) now (later expiration)-- -- Either create a new session or try to reuse current one.- tsession <- - maybe- (newSession smap ex)- (existingSession smap ex n)- prev-- setSessionCookie tsession ex- return tsession-----------------------------------------------------------------------------------{--Given the (possible wrong) request cookie, try to recover the existing ---session identifier.--}--getSessionID :: Maybe Cookies -> Maybe SessionID-getSessionID prev = do- ck <- prev- sid <- cookie "sid" ck- sid' <- safeRead $ value sid- return (SID sid')- -{--Generate a fresh, random session identifier using the default system random-generator.--}--genSessionID :: IO SessionID-genSessionID = do- g <- getStdGen- let (sid, g') = random g- setStdGen g'- return (SID (abs sid))---{--This handler sets the HTTP cookie for the specified session. It will use a-default cookie with an additional `sid' attribute with the session identifier-as value. The session expiration date will be used as the cookie expire field.--}--setSessionCookie :: TSession a -> LocalTime -> Handler ()-setSessionCookie tsession ex = do- ck <- newCookie ex- sid <- lift $ liftM sID $ atomReadTVar tsession- hSetCookies $- cookies [ck {- name = "sid"- , value = show sid- }]--{--Handler when no (valid) session is available. Create a new session with a-specified expiration date. The session will be stored in the session map.--}--newSession :: Sessions a -> LocalTime -> Handler (TSession a)-newSession sessions ex = lift $ do-- -- Fresh session identifier.- sid <- genSessionID-- -- Fresh session.- session <- mkSession sid ex-- -- Place in session mapping usinf session identifier as key.- atomModTVar (M.insert sid session) sessions- return session--{--Handler for existing sessions. Given an existing session identifier lookup a-session from the session map. When no session is available, or the session is-expired, create a new one using the `newSession' function. Otherwise the-expiration date of the existing session is updated.--}--existingSession ::- Sessions a -> LocalTime -> LocalTime- -> SessionID -> Handler (TSession a)-existingSession sessions ex n sid = do-- -- Lookup the session in the session map given the session identifier.- mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)- case mtsession of-- -- Unrecognized session identifiers are penalised by a fresh session.- Nothing -> newSession sessions ex- Just tsession -> do- expd <- lift $ liftM expire (atomReadTVar tsession)- if expd < n-- -- Session is expired, create a new one.- then newSession sessions ex-- -- Existing session, update expiration date.- else lift $ do- atomModTVar (\s -> s {expire = ex}) tsession- return tsession-
− src/Network/Salvia/Handlers/VirtualHosting.hs
@@ -1,16 +0,0 @@-module Network.Salvia.Handlers.VirtualHosting (hVirtualHosting) where--import Data.List (isPrefixOf)-import Data.Record.Label-import Network.Protocol.Http (hostname)-import Network.Salvia.Handlers.Dispatching (Dispatcher, ListDispatcher, hListDispatch, hDispatch)-import Network.Salvia.Httpd (request)---- isSuffixOf?--hVirtualHosting1 :: Dispatcher String a-hVirtualHosting1 = hDispatch (hostname % request) isPrefixOf--hVirtualHosting :: ListDispatcher String a-hVirtualHosting = hListDispatch hVirtualHosting1-
src/Network/Salvia/Httpd.hs view
@@ -5,7 +5,7 @@ , defaultConfig -- Httpd.Core.Handler- , Context (..)+ , Context , config , request , response@@ -20,15 +20,17 @@ , UriHandler -- Httpd.Core.IO- , sendHeaders , send , sendStr , sendStrLn , sendBs+ , spool , spoolBs- , spoolAll- , spoolN++ , flushHeaders+ , flushQueue+ , emptyQueue , reset @@ -42,6 +44,7 @@ ) where import Network.Salvia.Core.Config+import Network.Salvia.Core.Context import Network.Salvia.Core.Handler import Network.Salvia.Core.IO import Network.Salvia.Core.Main