packages feed

salvia (empty) → 0.0.4

raw patch · 42 files changed

+3906/−0 lines, 42 filesdep +basedep +bimapdep +bytestringsetup-changed

Dependencies added: base, bimap, bytestring, clevercss, containers, directory, encoding, filepath, hscolour, mtl, network, old-locale, parsec, process, random, stm, time, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+
+ salvia.cabal view
@@ -0,0 +1,71 @@+Name:             salvia+Version:          0.0.4+Description:      Lightweight Haskell Web Server Framework+Synopsis:         Lightweight Haskell Web Server Framework +Category:         Network, Web+License:          BSD3+License-file:     LICENSE+Author:           Sebastiaan Visser+Maintainer:       sfvisser@cs.uu.nl+Build-Type:       Simple+Build-Depends:    base,+                  bimap,+                  bytestring,+                  clevercss,+                  containers,+                  directory,+                  encoding,+                  filepath,+                  hscolour,+                  mtl ==1.1.0.2,+                  network,+                  old-locale,+                  parsec,+                  process,+                  random,+                  stm,+                  time,+                  utf8-string+GHC-Options:      -threaded -Wall -fno-warn-orphans+Extensions:       CPP+HS-Source-Dirs:   src+Other-modules:    Misc.Misc,+                  Misc.Terminal+Exposed-modules:  Network.Protocol.Cookie,+                  Network.Protocol.Http,+                  Network.Protocol.Mime,+                  Network.Protocol.Uri,+                  Network.Salvia.Httpd,+                  Network.Salvia.Core.Config,+                  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+
+ src/Misc/Misc.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Misc.Misc (+    eitherToMaybe+  , bool+  , pMaybe+  , (@@)+  , safeLast+  , guardMaybe+  , ifM+  , split+  , withReverse+  , intersperseS+  , trim+  , normalCase+  , intRead+  , now+  , later+  , safeRead+  , safeHead+  , atomModTVar+  , atomReadTVar+  , atomWithTVar+  ) where++import Control.Applicative +import Control.Concurrent.STM+import Control.Monad.Identity+import Data.Char+import Data.Time.Clock+import Data.Time.LocalTime+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))++-------[ common utilities ]----------------------------------------------------++bool :: a -> a -> Bool -> a+bool a b c = if c then a else b++safeRead :: Read a => String -> Maybe a+safeRead s = case reads s of+  [(x, "")] -> Just x+  _         -> Nothing++intRead :: String -> Maybe Int+intRead = safeRead++-- Conversions.++guardMaybe :: Bool -> Maybe ()+guardMaybe = bool (Just ()) Nothing++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just++-------[ list utilities ]------------------------------------------------------++safeList :: ([a] -> b) -> [a] -> Maybe b+safeList _ [] = Nothing+safeList f xs = Just $ f xs++safeHead :: [a] -> Maybe a+safeHead = safeList head++safeLast :: [a] -> Maybe a+safeLast = safeList last++withReverse :: ([a] -> [b]) -> [a] -> [b]+withReverse f = reverse . f . reverse++trimWith :: (a -> Bool) -> [a] -> [a]+trimWith f = withReverse (dropWhile f) . dropWhile f++split :: Eq a => a -> [a] -> [[a]]+split c = splitWith (==c)++splitWith :: (a -> Bool) -> [a] -> [[a]]+splitWith f xs =+  case span (not . f) (dropWhile f xs) of+   ([], []) -> []+   (a,  []) -> [a]+   (a,  b)  -> a : splitWith f b++-------[ text manipulation ]---------------------------------------------------++normalCase :: String -> String+normalCase ""     = ""+normalCase (x:xs) = toUpper x : map toLower xs++-- Trim all heading and trailing whitespace.+trim :: String -> String+trim = trimWith (`elem` " \t\n\r")++-- ShowS functions.++intersperseS :: ShowS -> [ShowS] -> ShowS+intersperseS _ []  = id+intersperseS _ [s] = s+intersperseS c xs  = foldl1 (\a -> ((a.c).)) xs++-------[ second arity functor ]------------------------------------------------++class Functor2 f where+  fmap2 :: (a -> c) -> (b -> d) -> f a b -> f c d++instance Functor2 (,) where+  fmap2 f g (a, b) = (f a, g b)++instance Functor2 Either where+  fmap2 f _ (Left  a) = Left  (f a)+  fmap2 _ g (Right b) = Right (g b)++-------[ monadic expressions ]-------------------------------------------------++ifM :: Monad m => m Bool -> (a -> a) -> a -> m a+ifM t f g = t >>= (\b -> return $ if b then f g else g)++-------[ parsec extensions ]---------------------------------------------------++-- Helper function to quickly apply a parser.+(@@) :: GenParser Char () a -> String -> Maybe a+(@@) p b = either (const Nothing) Just $ parse (p <* eof) "" b++-- Option parser with maybe result.+pMaybe :: GenParser a b c -> GenParser a b (Maybe c)+pMaybe = option Nothing . liftM Just++-- Make parsec both applicative and alternative.+instance Applicative (GenParser s a) where+  pure  = return+  (<*>) = ap++instance Alternative (GenParser s a) where+  empty = mzero+  (<|>) = mplus++-------[ time utils ]----------------------------------------------------------++later :: Integer -> IO LocalTime+later howlong = do+  zone <- getCurrentTimeZone+  time <- liftM (addUTCTime $ fromInteger howlong) getCurrentTime+  return $ utcToLocalTime zone time++now :: IO LocalTime+now = later 0++-------[ concurrency utils ]---------------------------------------------------++atomModTVar :: (a -> a) -> TVar a -> IO a+atomModTVar f v = atomically $ do+  t <- readTVar v+  writeTVar v (f t)+  return (f t)++atomReadTVar :: TVar a -> IO a+atomReadTVar = atomically . readTVar++atomWithTVar :: (a -> b) -> TVar a -> IO b+atomWithTVar f v = atomically+  $ liftM f (readTVar v)+
+ src/Misc/Terminal.hs view
@@ -0,0 +1,211 @@+module Misc.Terminal (++    esc++  , clearAll+  , clearEol+  , clear   ++  , move+  , moveUp     +  , moveDown   +  , moveBack   +  , moveForward++  , save+  , load++  , clr+  , fg+  , bg++  , normal   +  , bold     +  , faint    +  , standout +  , underline+  , blink    +  , inverse  +  , invisible++  , Color (..)++  , reset+  , black  +  , red    +  , green  +  , yellow +  , blue   +  , magenta+  , cyan   +  , white  ++  , blackBold  +  , redBold    +  , greenBold  +  , yellowBold +  , blueBold   +  , magentaBold+  , cyanBold   +  , whiteBold  ++  , blackBg  +  , redBg    +  , greenBg  +  , yellowBg +  , blueBg   +  , magentaBg+  , cyanBg   +  , whiteBg  +  , resetBg  ++  , width+  , height+  , geometry+  ) where++import Control.Applicative+import Data.List (intercalate)+import System.Environment (getEnvironment)++--------[ ansi escape sequence generation ]------------------------------------++-- Generic function for producing ANSI escape sequences.+esc :: String -> [String] -> String -> String+esc a args b = concat ["\ESC[", a, intercalate ";" $ args, b]++-- Clear screen and end-of-line+clearAll, clearEol, clear :: String+clearAll = esc "2J" [] ""+clearEol = esc "K"  [] "" +clear    = clearAll ++ move 1 1++-- Move the cursor to the specified row and column.+move :: Int -> Int -> String+move row col = esc "" [show col, show row] "H"++-- Relative cursor movements.+moveUp, moveDown, moveBack, moveForward :: Int -> String++moveUp      rs = esc "" [show rs] "A"+moveDown    rs = esc "" [show rs] "B"+moveBack    cs = esc "" [show cs] "D"+moveForward cs = esc "" [show cs] "C"++-- Load and store the current cursor position.+save :: String+save = esc "s" [] ""++load :: String+load = esc "u" [] ""++-- Generic function for creating (foreground) color sequences.+clr :: [String] -> String+clr codes = esc "" codes "m"++-- Create foreground and background colors.+fg :: Color -> [String]+fg c = [show ((num c :: Int) + 30)]++bg :: Color -> [String]+bg c = [show ((num c :: Int) + 40)]++-- Style modifiers.+normal, bold, faint, standout, underline, blink, inverse, invisible+  :: [String] -> [String]++normal    = ("0":)+bold      = ("1":)+faint     = ("2":)+standout  = ("3":)+underline = ("4":)+blink     = ("5":)+inverse   = ("7":)+invisible = ("8":)++--------[ ansi color listing ]-------------------------------------------------++data Color =+    Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | Reset+  deriving (Show, Eq)++-- Ansi codes offsets for color values.+num :: Num a => Color -> a+num Black   = 0+num Red     = 1+num Green   = 2+num Yellow  = 3+num Blue    = 4+num Magenta = 5+num Cyan    = 6+num White   = 7+num Reset   = 9++--------[ shortcut functions for common actions ]------------------------------++-- Reset all color and style information.+reset :: String+reset = esc "" ["0", "39", "49"] "m"++-- Shortcut for setting foreground colors.+black, red, green, yellow, blue,+  magenta, cyan, white :: String++black   = clr $ fg Black+red     = clr $ fg Red+green   = clr $ fg Green+yellow  = clr $ fg Yellow+blue    = clr $ fg Blue+magenta = clr $ fg Magenta+cyan    = clr $ fg Cyan+white   = clr $ fg White++-- Shortcut for setting bold foreground colors.+blackBold, redBold, greenBold, yellowBold, blueBold,+  magentaBold, cyanBold, whiteBold :: String++blackBold   = clr $ bold $ fg Black+redBold     = clr $ bold $ fg Red+greenBold   = clr $ bold $ fg Green+yellowBold  = clr $ bold $ fg Yellow+blueBold    = clr $ bold $ fg Blue+magentaBold = clr $ bold $ fg Magenta+cyanBold    = clr $ bold $ fg Cyan+whiteBold   = clr $ bold $ fg White++-- Shortcut for setting background colors.+blackBg, redBg, greenBg, yellowBg, blueBg,+  magentaBg, cyanBg, whiteBg, resetBg :: String++blackBg   = clr $ bg Black+redBg     = clr $ bg Red+greenBg   = clr $ bg Green+yellowBg  = clr $ bg Yellow+blueBg    = clr $ bg Blue+magentaBg = clr $ bg Magenta+cyanBg    = clr $ bg Cyan+whiteBg   = clr $ bg White+resetBg   = clr $ bg Reset++--------[ terminal geometry ]--------------------------------------------------++-- Try to read terminal width from environment variable.+width :: IO Int+width = (maybe 80 read . lookup "COLUMNS") <$> getEnvironment++-- Try to read terminal height from environment variable.+height :: IO Int+height = (maybe 24 read . lookup "LINES") <$> getEnvironment++-- Try to read terminal width and height from environment variables.+geometry :: IO (Int, Int)+geometry = (,) <$> width <*> height+
+ src/Network/Protocol/Cookie.hs view
@@ -0,0 +1,165 @@+module Network.Protocol.Cookie (+    Cookie (..)+  , empty++  , Cookies+  , cookies+  , cookie+  , showCookies++  , parseCookies+  ) where++import Control.Monad ()+import Control.Applicative hiding (empty)+import Data.Char (toLower)+import Data.List (intercalate)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))+import qualified Data.Map as M++import Misc.Misc (intersperseS, (@@), trim)+import Network.Protocol.Uri (URI)++-- For more information:+-- http://www.ietf.org/rfc/rfc2109.txt++-------[ HTTP cookie data type ]-----------------------------------------------++data Cookie =+  Cookie {+    name       :: String+  , value      :: String+  , comment    :: Maybe String+  , commentURL :: Maybe URI+  , discard    :: Bool+  , domain     :: Maybe String+  , maxAge     :: Maybe Int+  , expires    :: Maybe String+  , path       :: Maybe String+  , port       :: [Int]+  , secure     :: Bool+  , version    :: Int+  }++-- Create an empty cookie.+empty :: Cookie+empty = Cookie {+    name       = ""+  , value      = ""+  , comment    = Nothing+  , commentURL = Nothing+  , discard    = False+  , domain     = Nothing+  , maxAge     = Nothing+  , expires    = Nothing+  , path       = Nothing+  , port       = []+  , secure     = False+  , version    = 0+  }++-- A set 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.+cookies :: [Cookie] -> Cookies+cookies = M.fromList . map (\a -> (name a, a))++cookie :: String -> Cookies -> Maybe Cookie+cookie n = M.lookup (map toLower n)++-------[ cookie show instance ]------------------------------------------------++instance Show Cookie where+  show = flip showsCookie ""++-- Show a semicolon separated list of attribute/value pairs. Only meta pairs+-- with significant values will be pretty printed.+showsCookie :: Cookie -> ShowS+showsCookie c =+    pair     (name c)     (value c)+  . opt      "comment"    (comment c)+  . opt      "commentURL" (fmap show $ commentURL c)+  . bool     "discard"    (discard c)+  . opt      "domain"     (domain c)+  . opt      "maxAge"     (fmap show $ maxAge c)+  . opt      "expires"    (expires c)+  . opt      "path"       (path c)+  . list     "port"       (map show $ port c)+  . bool     "secure"     (secure c)+  . opt      "version"    (optval $ version c)+  where+    attr a       = showString a+    val v        = showString ("=" ++ v)+    end          = showString "; "+    single a     = attr a . end+    pair a v     = attr a . val v . end+    opt a        = maybe id (pair a)+    list _ []    = id+    list a xs    = pair a $ intercalate "," xs+    bool _ False = id+    bool a True  = single a+    optval 0     = Nothing+    optval i     = Just (show i)++-- Show multiple cookies, pretty printed using a comma separator.+showCookies :: Cookies -> String+showCookies = ($"")+  . intersperseS (showString ", ")+  . map (shows . snd)+  . M.toList++-------[ 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.+-}++pCookie :: GenParser Char st [Cookie]+pCookie = map ck <$> pCookieValues+  where+    ck ((n, v), m) =+      empty {+        name   = n+      , value  = v+      , domain = "$domain" `M.lookup` m+      , path   = "$path"   `M.lookup` m+      , port   = maybe [] pPorts $+                 "$port"   `M.lookup` m+      }++-- Parse a list of comma separated portnumbers. Returns a list of integers or+-- an empty list on failure.+pPorts :: String -> [Int]+pPorts = either (const []) id . parse p ""+   where+    p = char '"'+     *> sepBy1 (read <$> many1 digit) (char ',')+     <* char '"'++-- Parse a collection of cookie name/value pairs.+pCookieValues :: GenParser Char st [((String, String), M.Map String String)]+pCookieValues =+      flip sepBy1 sep ((,)+  <$> pair key+  <*> (M.fromList+  <$> filter (not . null . fst)+  <$> many (try (sep *> pair skey))))+  where+    f      = trim . map toLower+    key    = f <$> many1 (noneOf "=;")+    skey   = f <$> ((:) <$> char '$' <*> many (noneOf "=;"))+    val    = trim <$> many (noneOf ";")+    pair k = (,) <$> k <*> (char '=' *> val)+    sep    = char ';' *> many (oneOf " \t\r\n")+
+ src/Network/Protocol/Http.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.Protocol.Http(++    Status (..)+  , Method (..)+  , methods+  , Version (..)+  , Headers+  , Direction (..)+  , Message (..)++  , utf8+  , http10+  , http11+  , emptyRequest+  , emptyResponse++  , method+  , setMethod+  , uri+  , setUri+  , modUri+  , status+  , setStatus+  , setVersion+  , setBody+  , modBody+  , header+  , setHeader+  , modHeader+  , getLocation+  , getHost+  , getContentLength+  , getKeepAlive+  , getCookie+  , setContentType+  , setContentLength+  , setLocation+  , setDate+  , setServer+  , setCookie+  , normalizeHeader++  , pRequest+  , pResponse++  , showVersion+  , showHeaders+  , showMessageHeader++  , statusCodes+  , statusFailure+  , statusFromCode+  , codeFromStatus+  ) where++import Control.Applicative hiding (empty)+import Data.Char+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))+import qualified Data.Bimap as Bm+import qualified Data.Map as M++import Misc.Misc+import Network.Protocol.Uri (URI, mkURI, pUriReference)+import Network.Protocol.Cookie ()++-------- 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 Headers = M.Map String String++data Direction =+    Request  {_method :: Method, _uri :: URI}+  | Response {_status :: Status}++data Message =+  Message {+    direction :: Direction+  , version :: Version+  , headers :: Headers+  , body :: String+  }++utf8 :: String+utf8 = "utf-8"++-------- HTTP message creation and alteration ---------------------------------++-- 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 ""++method :: Message -> Method+method = _method . direction++setMethod :: Method -> Message -> Message+setMethod e m = m { direction = Request e (uri m) }++uri :: Message -> URI+uri = _uri . direction++setUri :: URI -> Message -> Message+setUri u m = m { direction = Request (method m) u }++modUri :: (URI -> URI) -> Message -> Message+modUri f m = setUri (f $ uri m) m++status :: Message -> Status+status = _status . direction++setStatus :: Status -> Message -> Message+setStatus s m = m { direction = Response s }++setVersion :: Version -> Message -> Message+setVersion v m = m { version = v }++setBody :: String -> Message -> Message+setBody b m = m { body = b }++modBody :: (String -> String) -> Message -> Message+modBody f m = setBody (f $ body m) m++header :: String -> Message -> String+header k = maybe "" id . M.lookup (normalizeHeader k) . headers++setHeader :: String -> String -> Message -> Message+setHeader k a (Message r v h b) = Message r v (M.insert (normalizeHeader k) a h) b++modHeader :: String -> (String -> String) -> Message -> Message+modHeader k f m = setHeader k (f $ header k m) m++getLocation :: Message -> String+getLocation = header "Location"++getHost :: Message -> String+getHost = header "Host"++getContentLength :: Message -> Maybe Int+getContentLength = intRead . header "Content-Length"++getKeepAlive :: Message -> Maybe Int+getKeepAlive = intRead . header "Keep-Alive"++getCookie :: Message -> String+getCookie = header "Cookie"++setContentType :: String -> Maybe String -> Message -> Message+setContentType t c = setHeader "Content-Type" (t ++ maybe "" ("; charset="++) c)++setContentLength :: Num a => a -> Message -> Message+setContentLength l = setHeader "Content-Length" (show l)++setLocation :: URI -> Message -> Message+setLocation l = setHeader "Location" (show l)++setDate :: String -> Message -> Message+setDate d = setHeader "Date" d++setServer :: String -> Message -> Message+setServer n  = setHeader "Server" n++setCookie :: String -> Message -> Message+setCookie c = setHeader "Set-Cookie" c++normalizeHeader :: String -> String+normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-')++-------- 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, 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++codeFromStatus :: Status -> Int+codeFromStatus st =+    fromMaybe 0 -- total, should not happen+  $ Bm.lookupR st statusCodes+
+ src/Network/Protocol/Mime.hs view
@@ -0,0 +1,653 @@+module Network.Protocol.Mime where++import Data.Map++-------- file extension to mime type mapping ----------------------------------++mime :: String -> Maybe String+mime ext = Data.Map.lookup ext extensionToMime++defaultMime :: String+defaultMime = "text/plain"++extensionToMime :: Map String String+extensionToMime = fromList [+    ("123",       "application/vnd.lotus-1-2-3")+  , ("3dml",      "text/vnd.in3d.3dml")+  , ("3g2",       "video/3gpp2")+  , ("3gp",       "video/3gpp")+  , ("ace",       "application/x-ace-compressed")+  , ("acu",       "application/vnd.acucobol")+  , ("acutc",     "application/vnd.acucorp")+  , ("aep",       "application/vnd.audiograph")+  , ("afp",       "application/vnd.ibm.modcap")+  , ("ai",        "application/postscript")+  , ("aif",       "audio/x-aiff")+  , ("aifc",      "audio/x-aiff")+  , ("aiff",      "audio/x-aiff")+  , ("ami",       "application/vnd.amiga.ami")+  , ("apr",       "application/vnd.lotus-approach")+  , ("asc",       "application/pgp-signature")+  , ("asf",       "application/vnd.ms-asf")+  , ("asf",       "video/x-ms-asf")+  , ("asm",       "text/x-asm")+  , ("aso",       "application/vnd.accpac.simply.aso")+  , ("asx",       "video/x-ms-asf")+  , ("atc",       "application/vnd.acucorp")+  , ("atom",      "application/atom+xml")+  , ("atomcat",   "application/atomcat+xml")+  , ("atomsvc",   "application/atomsvc+xml")+  , ("atx",       "application/vnd.antix.game-component")+  , ("au",        "audio/basic")+  , ("bat",       "application/x-msdownload")+  , ("bcpio",     "application/x-bcpio")+  , ("bdm",       "application/vnd.syncml.dm+wbxml")+  , ("bh2",       "application/vnd.fujitsu.oasysprs")+  , ("bin",       "application/octet-stream")+  , ("bmi",       "application/vnd.bmi")+  , ("bmp",       "image/bmp")+  , ("box",       "application/vnd.previewsystems.box")+  , ("boz",       "application/x-bzip2")+  , ("bpk",       "application/octet-stream")+  , ("btif",      "image/prs.btif")+  , ("bz",        "application/x-bzip")+  , ("bz2",       "application/x-bzip2")+  , ("c",         "text/x-c")+  , ("c4d",       "application/vnd.clonk.c4group")+  , ("c4f",       "application/vnd.clonk.c4group")+  , ("c4g",       "application/vnd.clonk.c4group")+  , ("c4p",       "application/vnd.clonk.c4group")+  , ("c4u",       "application/vnd.clonk.c4group")+  , ("cab",       "application/vnd.ms-cab-compressed")+  , ("cc",        "text/x-c")+  , ("ccxml",     "application/ccxml+xml")+  , ("cdbcmsg",   "application/vnd.contact.cmsg")+  , ("cdf",       "application/x-netcdf")+  , ("cdkey",     "application/vnd.mediastation.cdkey")+  , ("cdx",       "chemical/x-cdx")+  , ("cdxml",     "application/vnd.chemdraw+xml")+  , ("cdy",       "application/vnd.cinderella")+  , ("cer",       "application/pkix-cert")+  , ("cgm",       "image/cgm")+  , ("chat",      "application/x-chat")+  , ("chm",       "application/vnd.ms-htmlhelp")+  , ("chrt",      "application/vnd.kde.kchart")+  , ("cif",       "chemical/x-cif")+  , ("cii",       "application/vnd.anser-web-certificate-issue-initiation")+  , ("cil",       "application/vnd.ms-artgalry")+  , ("cla",       "application/vnd.claymore")+  , ("class",     "application/octet-stream")+  , ("clkk",      "application/vnd.crick.clicker.keyboard")+  , ("clkp",      "application/vnd.crick.clicker.palette")+  , ("clkt",      "application/vnd.crick.clicker.template")+  , ("clkw",      "application/vnd.crick.clicker.wordbank")+  , ("clkx",      "application/vnd.crick.clicker")+  , ("clp",       "application/x-msclip")+  , ("cmc",       "application/vnd.cosmocaller")+  , ("cmdf",      "chemical/x-cmdf")+  , ("cml",       "chemical/x-cml")+  , ("cmp",       "application/vnd.yellowriver-custom-menu")+  , ("cmx",       "image/x-cmx")+  , ("com",       "application/x-msdownload")+  , ("conf",      "text/plain")+  , ("cpio",      "application/x-cpio")+  , ("cpp",       "text/x-c")+  , ("cpt",       "application/mac-compactpro")+  , ("crd",       "application/x-mscardfile")+  , ("crl",       "application/pkix-crl")+  , ("crt",       "application/x-x509-ca-cert")+  , ("csh",       "application/x-csh")+  , ("csml",      "chemical/x-csml")+  , ("csp",       "application/vnd.commonspace")+  , ("css",       "text/css")+  , ("cst",       "application/vnd.commonspace")+  , ("csv",       "text/csv")+  , ("curl",      "application/vnd.curl")+  , ("cww",       "application/prs.cww")+  , ("cxx",       "text/x-c")+  , ("daf",       "application/vnd.mobius.daf")+  , ("davmount",  "application/davmount+xml")+  , ("dcr",       "application/x-director")+  , ("dd2",       "application/vnd.oma.dd2+xml")+  , ("ddd",       "application/vnd.fujixerox.ddd")+  , ("def",       "text/plain")+  , ("der",       "application/x-x509-ca-cert")+  , ("dfac",      "application/vnd.dreamfactory")+  , ("dic",       "text/x-c")+  , ("dir",       "application/x-director")+  , ("dis",       "application/vnd.mobius.dis")+  , ("dist",      "application/octet-stream")+  , ("distz",     "application/octet-stream")+  , ("djv",       "image/vnd.djvu")+  , ("djvu",      "image/vnd.djvu")+  , ("dll",       "application/x-msdownload")+  , ("dmg",       "application/octet-stream")+  , ("dms",       "application/octet-stream")+  , ("dna",       "application/vnd.dna")+  , ("doc",       "application/msword")+  , ("dot",       "application/msword")+  , ("dp",        "application/vnd.osgi.dp")+  , ("dpg",       "application/vnd.dpgraph")+  , ("dsc",       "text/prs.lines.tag")+  , ("dtd",       "application/xml-dtd")+  , ("dump",      "application/octet-stream")+  , ("dvi",       "application/x-dvi")+  , ("dwf",       "model/vnd.dwf")+  , ("dwg",       "image/vnd.dwg")+  , ("dxf",       "image/vnd.dxf")+  , ("dxp",       "application/vnd.spotfire.dxp")+  , ("dxr",       "application/x-director")+  , ("ecelp4800", "audio/vnd.nuera.ecelp4800")+  , ("ecelp7470", "audio/vnd.nuera.ecelp7470")+  , ("ecelp9600", "audio/vnd.nuera.ecelp9600")+  , ("ecma",      "application/ecmascript")+  , ("edm",       "application/vnd.novadigm.edm")+  , ("edx",       "application/vnd.novadigm.edx")+  , ("efif",      "application/vnd.picsel")+  , ("ei6",       "application/vnd.pg.osasli")+  , ("elc",       "application/octet-stream")+  , ("eml",       "message/rfc822")+  , ("eol",       "audio/vnd.digital-winds")+  , ("eot",       "application/vnd.ms-fontobject")+  , ("eps",       "application/postscript")+  , ("es3",       "application/vnd.eszigno3+xml")+  , ("esf",       "application/vnd.epson.esf")+  , ("et3",       "application/vnd.eszigno3+xml")+  , ("etx",       "text/x-setext")+  , ("exe",       "application/x-msdownload")+  , ("ext",       "application/vnd.novadigm.ext")+  , ("ez",        "application/andrew-inset")+  , ("ez2",       "application/vnd.ezpix-album")+  , ("ez3",       "application/vnd.ezpix-package")+  , ("f",         "text/x-fortran")+  , ("f77",       "text/x-fortran")+  , ("f90",       "text/x-fortran")+  , ("fbs",       "image/vnd.fastbidsheet")+  , ("fdf",       "application/vnd.fdf")+  , ("fe_launch", "application/vnd.denovo.fcselayout-link")+  , ("fg5",       "application/vnd.fujitsu.oasysgp")+  , ("fgd",       "application/x-director")+  , ("fli",       "video/x-fli")+  , ("flo",       "application/vnd.micrografx.flo")+  , ("flw",       "application/vnd.kde.kivio")+  , ("flx",       "text/vnd.fmi.flexstor")+  , ("fly",       "text/vnd.fly")+  , ("fm",        "application/vnd.framemaker")+  , ("fnc",       "application/vnd.frogans.fnc")+  , ("for",       "text/x-fortran")+  , ("fpx",       "image/vnd.fpx")+  , ("frame",     "application/vnd.framemaker")+  , ("fsc",       "application/vnd.fsc.weblaunch")+  , ("fst",       "image/vnd.fst")+  , ("ftc",       "application/vnd.fluxtime.clip")+  , ("fti",       "application/vnd.anser-web-funds-transfer-initiation")+  , ("fvt",       "video/vnd.fvt")+  , ("fzs",       "application/vnd.fuzzysheet")+  , ("g3",        "image/g3fax")+  , ("gac",       "application/vnd.groove-account")+  , ("gdl",       "model/vnd.gdl")+  , ("ghf",       "application/vnd.groove-help")+  , ("gif",       "image/gif")+  , ("gim",       "application/vnd.groove-identity-message")+  , ("gph",       "application/vnd.flographit")+  , ("gqf",       "application/vnd.grafeq")+  , ("gqs",       "application/vnd.grafeq")+  , ("gram",      "application/srgs")+  , ("grv",       "application/vnd.groove-injector")+  , ("grxml",     "application/srgs+xml")+  , ("gtar",      "application/x-gtar")+  , ("gtm",       "application/vnd.groove-tool-message")+  , ("gtw",       "model/vnd.gtw")+  , ("h",         "text/x-c")+  , ("h261",      "video/h261")+  , ("h263",      "video/h263")+  , ("h264",      "video/h264")+  , ("hbci",      "application/vnd.hbci")+  , ("hdf",       "application/x-hdf")+  , ("hh",        "text/x-c")+  , ("hlp",       "application/winhlp")+  , ("hpgl",      "application/vnd.hp-hpgl")+  , ("hpid",      "application/vnd.hp-hpid")+  , ("hps",       "application/vnd.hp-hps")+  , ("hqx",       "application/mac-binhex40")+  , ("htke",      "application/vnd.kenameaapp")+  , ("htm",       "text/html")+  , ("html",      "text/html")+  , ("hvd",       "application/vnd.yamaha.hv-dic")+  , ("hvp",       "application/vnd.yamaha.hv-voice")+  , ("hvs",       "application/vnd.yamaha.hv-script")+  , ("ico",       "image/vnd.microsoft.icon")+  , ("ics",       "text/calendar")+  , ("ief",       "image/ief")+  , ("ifb",       "text/calendar")+  , ("ifm",       "application/vnd.shana.informed.formdata")+  , ("iges",      "model/iges")+  , ("igl",       "application/vnd.igloader")+  , ("igs",       "model/iges")+  , ("igx",       "application/vnd.micrografx.igx")+  , ("iif",       "application/vnd.shana.informed.interchange")+  , ("imp",       "application/vnd.accpac.simply.imp")+  , ("ims",       "application/vnd.ms-ims")+  , ("in",        "text/plain")+  , ("ipk",       "application/vnd.shana.informed.package")+  , ("irm",       "application/vnd.ibm.rights-management")+  , ("irp",       "application/vnd.irepository.package+xml")+  , ("iso",       "application/octet-stream")+  , ("itp",       "application/vnd.shana.informed.formtemplate")+  , ("ivp",       "application/vnd.immervision-ivp")+  , ("ivu",       "application/vnd.immervision-ivu")+  , ("jad",       "text/vnd.sun.j2me.app-descriptor")+  , ("jam",       "application/vnd.jam")+  , ("java",      "text/x-java-source")+  , ("jisp",      "application/vnd.jisp")+  , ("jlt",       "application/vnd.hp-jlyt")+  , ("jpe",       "image/jpeg")+  , ("jpeg",      "image/jpeg")+  , ("jpg",       "image/jpeg")+  , ("jpgm",      "video/jpm")+  , ("jpgv",      "video/jpeg")+  , ("jpm",       "video/jpm")+  , ("js",        "application/javascript")+  , ("json",      "application/json")+  , ("kar",       "audio/midi")+  , ("karbon",    "application/vnd.kde.karbon")+  , ("kfo",       "application/vnd.kde.kformula")+  , ("kia",       "application/vnd.kidspiration")+  , ("kml",       "application/vnd.google-earth.kml+xml")+  , ("kmz",       "application/vnd.google-earth.kmz")+  , ("kne",       "application/vnd.kinar")+  , ("knp",       "application/vnd.kinar")+  , ("kon",       "application/vnd.kde.kontour")+  , ("kpr",       "application/vnd.kde.kpresenter")+  , ("kpt",       "application/vnd.kde.kpresenter")+  , ("ksp",       "application/vnd.kde.kspread")+  , ("ktr",       "application/vnd.kahootz")+  , ("ktz",       "application/vnd.kahootz")+  , ("kwd",       "application/vnd.kde.kword")+  , ("kwt",       "application/vnd.kde.kword")+  , ("latex",     "application/x-latex")+  , ("lbd",       "application/vnd.llamagraphics.life-balance.desktop")+  , ("lbe",       "application/vnd.llamagraphics.life-balance.exchange+xml")+  , ("les",       "application/vnd.hhe.lesson-player")+  , ("lha",       "application/octet-stream")+  , ("list",      "text/plain")+  , ("list3820",  "application/vnd.ibm.modcap")+  , ("listafp",   "application/vnd.ibm.modcap")+  , ("log",       "text/plain")+  , ("lrm",       "application/vnd.ms-lrm")+  , ("ltf",       "application/vnd.frogans.ltf")+  , ("lvp",       "audio/vnd.lucent.voice")+  , ("lwp",       "application/vnd.lotus-wordpro")+  , ("lzh",       "application/octet-stream")+  , ("m13",       "application/x-msmediaview")+  , ("m14",       "application/x-msmediaview")+  , ("m1v",       "video/mpeg")+  , ("m2a",       "audio/mpeg")+  , ("m2v",       "video/mpeg")+  , ("m3a",       "audio/mpeg")+  , ("m3u",       "audio/x-mpegurl")+  , ("m4u",       "video/vnd.mpegurl")+  , ("ma",        "application/mathematica")+  , ("mag",       "application/vnd.ecowin.chart")+  , ("maker",     "application/vnd.framemaker")+  , ("man",       "text/troff")+  , ("mathml",    "application/mathml+xml")+  , ("mb",        "application/mathematica")+  , ("mbk",       "application/vnd.mobius.mbk")+  , ("mbox",      "application/mbox")+  , ("mc1",       "application/vnd.medcalcdata")+  , ("mcd",       "application/vnd.mcd")+  , ("mdb",       "application/x-msaccess")+  , ("mdi",       "image/vnd.ms-modi")+  , ("me",        "text/troff")+  , ("mesh",      "model/mesh")+  , ("mfm",       "application/vnd.mfmp")+  , ("mgz",       "application/vnd.proteus.magazine")+  , ("mid",       "audio/midi")+  , ("midi",      "audio/midi")+  , ("mif",       "application/vnd.mif")+  , ("mime",      "message/rfc822")+  , ("mj2",       "video/mj2")+  , ("mjp2",      "video/mj2")+  , ("mlp",       "application/vnd.dolby.mlp")+  , ("mmd",       "application/vnd.chipnuts.karaoke-mmd")+  , ("mmf",       "application/vnd.smaf")+  , ("mmr",       "image/vnd.fujixerox.edmics-mmr")+  , ("mny",       "application/x-msmoney")+  , ("mov",       "video/quicktime")+  , ("mp2",       "audio/mpeg")+  , ("mp2a",      "audio/mpeg")+  , ("mp3",       "audio/mpeg")+  , ("mp4",       "video/mp4")+  , ("mp4a",      "audio/mp4")+  , ("mp4s",      "application/mp4")+  , ("mp4v",      "video/mp4")+  , ("mpc",       "application/vnd.mophun.certificate")+  , ("mpe",       "video/mpeg")+  , ("mpeg",      "video/mpeg")+  , ("mpg",       "video/mpeg")+  , ("mpg4",      "video/mp4")+  , ("mpga",      "audio/mpeg")+  , ("mpkg",      "application/vnd.apple.installer+xml")+  , ("mpm",       "application/vnd.blueice.multipass")+  , ("mpn",       "application/vnd.mophun.application")+  , ("mpp",       "application/vnd.ms-project")+  , ("mpt",       "application/vnd.ms-project")+  , ("mpy",       "application/vnd.ibm.minipay")+  , ("mqy",       "application/vnd.mobius.mqy")+  , ("mrc",       "application/marc")+  , ("ms",        "text/troff")+  , ("mscml",     "application/mediaservercontrol+xml")+  , ("mseq",      "application/vnd.mseq")+  , ("msf",       "application/vnd.epson.msf")+  , ("msh",       "model/mesh")+  , ("msi",       "application/x-msdownload")+  , ("msl",       "application/vnd.mobius.msl")+  , ("mts",       "model/vnd.mts")+  , ("mus",       "application/vnd.musician")+  , ("mvb",       "application/x-msmediaview")+  , ("mwf",       "application/vnd.mfer")+  , ("mxf",       "application/mxf")+  , ("mxl",       "application/vnd.recordare.musicxml")+  , ("mxml",      "application/xv+xml")+  , ("mxs",       "application/vnd.triscape.mxs")+  , ("mxu",       "video/vnd.mpegurl")+  , ("n-gage",    "application/vnd.nokia.n-gage.symbian.install")+  , ("nb",        "application/mathematica")+  , ("nc",        "application/x-netcdf")+  , ("ngdat",     "application/vnd.nokia.n-gage.data")+  , ("nlu",       "application/vnd.neurolanguage.nlu")+  , ("nml",       "application/vnd.enliven")+  , ("nnd",       "application/vnd.noblenet-directory")+  , ("nns",       "application/vnd.noblenet-sealer")+  , ("nnw",       "application/vnd.noblenet-web")+  , ("npx",       "image/vnd.net-fpx")+  , ("nsf",       "application/vnd.lotus-notes")+  , ("oa2",       "application/vnd.fujitsu.oasys2")+  , ("oa3",       "application/vnd.fujitsu.oasys3")+  , ("oas",       "application/vnd.fujitsu.oasys")+  , ("obd",       "application/x-msbinder")+  , ("oda",       "application/oda")+  , ("odc",       "application/vnd.oasis.opendocument.chart")+  , ("odf",       "application/vnd.oasis.opendocument.formula")+  , ("odg",       "application/vnd.oasis.opendocument.graphics")+  , ("odi",       "application/vnd.oasis.opendocument.image")+  , ("odp",       "application/vnd.oasis.opendocument.presentation")+  , ("ods",       "application/vnd.oasis.opendocument.spreadsheet")+  , ("odt",       "application/vnd.oasis.opendocument.text")+  , ("ogg",       "application/ogg")+  , ("oprc",      "application/vnd.palm")+  , ("org",       "application/vnd.lotus-organizer")+  , ("otc",       "application/vnd.oasis.opendocument.chart-template")+  , ("otf",       "application/vnd.oasis.opendocument.formula-template")+  , ("otg",       "application/vnd.oasis.opendocument.graphics-template")+  , ("oth",       "application/vnd.oasis.opendocument.text-web")+  , ("oti",       "application/vnd.oasis.opendocument.image-template")+  , ("otm",       "application/vnd.oasis.opendocument.text-master")+  , ("otp",       "application/vnd.oasis.opendocument.presentation-template")+  , ("ots",       "application/vnd.oasis.opendocument.spreadsheet-template")+  , ("ott",       "application/vnd.oasis.opendocument.text-template")+  , ("oxt",       "application/vnd.openofficeorg.extension")+  , ("p",         "text/x-pascal")+  , ("p10",       "application/pkcs10")+  , ("p12",       "application/x-pkcs12")+  , ("p7b",       "application/x-pkcs7-certificates")+  , ("p7c",       "application/pkcs7-mime")+  , ("p7m",       "application/pkcs7-mime")+  , ("p7r",       "application/x-pkcs7-certreqresp")+  , ("p7s",       "application/pkcs7-signature")+  , ("pas",       "text/x-pascal")+  , ("pbd",       "application/vnd.powerbuilder6")+  , ("pbm",       "image/x-portable-bitmap")+  , ("pcl",       "application/vnd.hp-pcl")+  , ("pclxl",     "application/vnd.hp-pclxl")+  , ("pct",       "image/x-pict")+  , ("pcx",       "image/x-pcx")+  , ("pdb",       "application/vnd.palm")+  , ("pdb",       "chemical/x-pdb")+  , ("pdf",       "application/pdf")+  , ("pfr",       "application/font-tdpfr")+  , ("pfx",       "application/x-pkcs12")+  , ("pgm",       "image/x-portable-graymap")+  , ("pgn",       "application/x-chess-pgn")+  , ("pgp",       "application/pgp-encrypted")+  , ("pic",       "image/x-pict")+  , ("pkg",       "application/octet-stream")+  , ("pki",       "application/pkixcmp")+  , ("pkipath",   "application/pkix-pkipath")+  , ("plb",       "application/vnd.3gpp.pic-bw-large")+  , ("plc",       "application/vnd.mobius.plc")+  , ("plf",       "application/vnd.pocketlearn")+  , ("pls",       "application/pls+xml")+  , ("pml",       "application/vnd.ctc-posml")+  , ("png",       "image/png")+  , ("pnm",       "image/x-portable-anymap")+  , ("portpkg",   "application/vnd.macports.portpkg")+  , ("pot",       "application/vnd.ms-powerpoint")+  , ("ppd",       "application/vnd.cups-ppd")+  , ("ppm",       "image/x-portable-pixmap")+  , ("pps",       "application/vnd.ms-powerpoint")+  , ("ppt",       "application/vnd.ms-powerpoint")+  , ("pqa",       "application/vnd.palm")+  , ("prc",       "application/vnd.palm")+  , ("pre",       "application/vnd.lotus-freelance")+  , ("prf",       "application/pics-rules")+  , ("ps",        "application/postscript")+  , ("psb",       "application/vnd.3gpp.pic-bw-small")+  , ("psd",       "image/vnd.adobe.photoshop")+  , ("ptid",      "application/vnd.pvi.ptid1")+  , ("pub",       "application/x-mspublisher")+  , ("pvb",       "application/vnd.3gpp.pic-bw-var")+  , ("pwn",       "application/vnd.3m.post-it-notes")+  , ("qam",       "application/vnd.epson.quickanime")+  , ("qbo",       "application/vnd.intu.qbo")+  , ("qfx",       "application/vnd.intu.qfx")+  , ("qps",       "application/vnd.publishare-delta-tree")+  , ("qt",        "video/quicktime")+  , ("qwd",       "application/vnd.quark.quarkxpress")+  , ("qwt",       "application/vnd.quark.quarkxpress")+  , ("qxb",       "application/vnd.quark.quarkxpress")+  , ("qxd",       "application/vnd.quark.quarkxpress")+  , ("qxl",       "application/vnd.quark.quarkxpress")+  , ("qxt",       "application/vnd.quark.quarkxpress")+  , ("ra",        "audio/x-pn-realaudio")+  , ("ram",       "audio/x-pn-realaudio")+  , ("rar",       "application/x-rar-compressed")+  , ("ras",       "image/x-cmu-raster")+  , ("rcprofile", "application/vnd.ipunplugged.rcprofile")+  , ("rdf",       "application/rdf+xml")+  , ("rdz",       "application/vnd.data-vision.rdz")+  , ("rep",       "application/vnd.businessobjects")+  , ("rgb",       "image/x-rgb")+  , ("rif",       "application/reginfo+xml")+  , ("rl",        "application/resource-lists+xml")+  , ("rlc",       "image/vnd.fujixerox.edmics-rlc")+  , ("rm",        "application/vnd.rn-realmedia")+  , ("rmi",       "audio/midi")+  , ("rmp",       "audio/x-pn-realaudio-plugin")+  , ("rms",       "application/vnd.jcp.javame.midlet-rms")+  , ("rnc",       "application/relax-ng-compact-syntax")+  , ("roff",      "text/troff")+  , ("rpss",      "application/vnd.nokia.radio-presets")+  , ("rpst",      "application/vnd.nokia.radio-preset")+  , ("rs",        "application/rls-services+xml")+  , ("rsd",       "application/rsd+xml")+  , ("rss",       "application/rss+xml")+  , ("rtf",       "application/rtf")+  , ("rtx",       "text/richtext")+  , ("s",         "text/x-asm")+  , ("saf",       "application/vnd.yamaha.smaf-audio")+  , ("sbml",      "application/sbml+xml")+  , ("sc",        "application/vnd.ibm.secure-container")+  , ("scd",       "application/x-msschedule")+  , ("scm",       "application/vnd.lotus-screencam")+  , ("sdkd",      "application/vnd.solent.sdkm+xml")+  , ("sdkm",      "application/vnd.solent.sdkm+xml")+  , ("sdp",       "application/sdp")+  , ("see",       "application/vnd.seemail")+  , ("sema",      "application/vnd.sema")+  , ("semd",      "application/vnd.semd")+  , ("semf",      "application/vnd.semf")+  , ("setpay",    "application/set-payment-initiation")+  , ("setreg",    "application/set-registration-initiation")+  , ("sfs",       "application/vnd.spotfire.sfs")+  , ("sgm",       "text/sgml")+  , ("sgml",      "text/sgml")+  , ("sh",        "application/x-sh")+  , ("shar",      "application/x-shar")+  , ("shf",       "application/shf+xml")+  , ("sig",       "application/pgp-signature")+  , ("silo",      "model/mesh")+  , ("sit",       "application/x-stuffit")+  , ("sitx",      "application/x-stuffitx")+  , ("skd",       "application/vnd.koan")+  , ("skm",       "application/vnd.koan")+  , ("skp",       "application/vnd.koan")+  , ("skt",       "application/vnd.koan")+  , ("slt",       "application/vnd.epson.salt")+  , ("smi",       "application/smil+xml")+  , ("smil",      "application/smil+xml")+  , ("snd",       "audio/basic")+  , ("so",        "application/octet-stream")+  , ("spc",       "application/x-pkcs7-certificates")+  , ("spf",       "application/vnd.yamaha.smaf-phrase")+  , ("spl",       "application/x-futuresplash")+  , ("spot",      "text/vnd.in3d.spot")+  , ("src",       "application/x-wais-source")+  , ("ssf",       "application/vnd.epson.ssf")+  , ("ssml",      "application/ssml+xml")+  , ("stf",       "application/vnd.wt.stf")+  , ("stk",       "application/hyperstudio")+  , ("str",       "application/vnd.pg.format")+  , ("sus",       "application/vnd.sus-calendar")+  , ("susp",      "application/vnd.sus-calendar")+  , ("sv4cpio",   "application/x-sv4cpio")+  , ("sv4crc",    "application/x-sv4crc")+  , ("svd",       "application/vnd.svd")+  , ("svg",       "image/svg+xml")+  , ("svgz",      "image/svg+xml")+  , ("swf",       "application/x-shockwave-flash")+  , ("t",         "text/troff")+  , ("tao",       "application/vnd.tao.intent-module-archive")+  , ("tar",       "application/x-tar")+  , ("tcl",       "application/x-tcl")+  , ("tex",       "application/x-tex")+  , ("texi",      "application/x-texinfo")+  , ("texinfo",   "application/x-texinfo")+  , ("text",      "text/plain")+  , ("tif",       "image/tiff")+  , ("tiff",      "image/tiff")+  , ("tmo",       "application/vnd.tmobile-livetv")+  , ("torrent",   "application/x-bittorrent")+  , ("tpl",       "application/vnd.groove-tool-template")+  , ("tpt",       "application/vnd.trid.tpt")+  , ("tr",        "text/troff")+  , ("tra",       "application/vnd.trueapp")+  , ("trm",       "application/x-msterminal")+  , ("tsv",       "text/tab-separated-values")+  , ("twd",       "application/vnd.simtech-mindmapper")+  , ("twds",      "application/vnd.simtech-mindmapper")+  , ("txd",       "application/vnd.genomatix.tuxedo")+  , ("txf",       "application/vnd.mobius.txf")+  , ("txt",       "text/plain")+  , ("ufd",       "application/vnd.ufdl")+  , ("ufdl",      "application/vnd.ufdl")+  , ("umj",       "application/vnd.umajin")+  , ("unityweb",  "application/vnd.unity")+  , ("uoml",      "application/vnd.uoml+xml")+  , ("uri",       "text/uri-list")+  , ("uris",      "text/uri-list")+  , ("urls",      "text/uri-list")+  , ("ustar",     "application/x-ustar")+  , ("utz",       "application/vnd.uiq.theme")+  , ("uu",        "text/x-uuencode")+  , ("vcd",       "application/x-cdlink")+  , ("vcf",       "text/x-vcard")+  , ("vcg",       "application/vnd.groove-vcard")+  , ("vcs",       "text/x-vcalendar")+  , ("vcx",       "application/vnd.vcx")+  , ("vis",       "application/vnd.visionary")+  , ("viv",       "video/vnd.vivo")+  , ("vrml",      "model/vrml")+  , ("vsd",       "application/vnd.visio")+  , ("vsf",       "application/vnd.vsf")+  , ("vss",       "application/vnd.visio")+  , ("vst",       "application/vnd.visio")+  , ("vsw",       "application/vnd.visio")+  , ("vtu",       "model/vnd.vtu")+  , ("vxml",      "application/voicexml+xml")+  , ("wav",       "audio/wav")+  , ("wav",       "audio/x-wav")+  , ("wax",       "audio/x-ms-wax")+  , ("wbmp",      "image/vnd.wap.wbmp")+  , ("wbs",       "application/vnd.criticaltools.wbs+xml")+  , ("wbxml",     "application/vnd.wap.wbxml")+  , ("wcm",       "application/vnd.ms-works")+  , ("wdb",       "application/vnd.ms-works")+  , ("wks",       "application/vnd.ms-works")+  , ("wm",        "video/x-ms-wm")+  , ("wma",       "audio/x-ms-wma")+  , ("wmd",       "application/x-ms-wmd")+  , ("wmf",       "application/x-msmetafile")+  , ("wml",       "text/vnd.wap.wml")+  , ("wmlc",      "application/vnd.wap.wmlc")+  , ("wmls",      "text/vnd.wap.wmlscript")+  , ("wmlsc",     "application/vnd.wap.wmlscriptc")+  , ("wmv",       "video/x-ms-wmv")+  , ("wmx",       "video/x-ms-wmx")+  , ("wmz",       "application/x-ms-wmz")+  , ("wpd",       "application/vnd.wordperfect")+  , ("wpl",       "application/vnd.ms-wpl")+  , ("wps",       "application/vnd.ms-works")+  , ("wqd",       "application/vnd.wqd")+  , ("wri",       "application/x-mswrite")+  , ("wrl",       "model/vrml")+  , ("wsdl",      "application/wsdl+xml")+  , ("wspolicy",  "application/wspolicy+xml")+  , ("wtb",       "application/vnd.webturbo")+  , ("wvx",       "video/x-ms-wvx")+  , ("x3d",       "application/vnd.hzn-3d-crossword")+  , ("xar",       "application/vnd.xara")+  , ("xbd",       "application/vnd.fujixerox.docuworks.binder")+  , ("xbm",       "image/x-xbitmap")+  , ("xdm",       "application/vnd.syncml.dm+xml")+  , ("xdp",       "application/vnd.adobe.xdp+xml")+  , ("xdw",       "application/vnd.fujixerox.docuworks")+  , ("xenc",      "application/xenc+xml")+  , ("xfdf",      "application/vnd.adobe.xfdf")+  , ("xfdl",      "application/vnd.xfdl")+  , ("xht",       "application/xhtml+xml")+  , ("xhtml",     "application/xhtml+xml")+  , ("xhvml",     "application/xv+xml")+  , ("xif",       "image/vnd.xiff")+  , ("xla",       "application/vnd.ms-excel")+  , ("xlc",       "application/vnd.ms-excel")+  , ("xlm",       "application/vnd.ms-excel")+  , ("xls",       "application/vnd.ms-excel")+  , ("xlt",       "application/vnd.ms-excel")+  , ("xlw",       "application/vnd.ms-excel")+  , ("xml",       "application/xml")+  , ("xo",        "application/vnd.olpc-sugar")+  , ("xop",       "application/xop+xml")+  , ("xpm",       "image/x-xpixmap")+  , ("xpr",       "application/vnd.is-xpr")+  , ("xps",       "application/vnd.ms-xpsdocument")+  , ("xpw",       "application/vnd.intercon.formnet")+  , ("xpx",       "application/vnd.intercon.formnet")+  , ("xsl",       "application/xml")+  , ("xslt",      "application/xslt+xml")+  , ("xsm",       "application/vnd.syncml+xml")+  , ("xspf",      "application/xspf+xml")+  , ("xul",       "application/vnd.mozilla.xul+xml")+  , ("xvm",       "application/xv+xml")+  , ("xvml",      "application/xv+xml")+  , ("xwd",       "image/x-xwindowdump")+  , ("xyz",       "chemical/x-xyz")+  , ("zaz",       "application/vnd.zzazz.deck+xml")+  , ("zip",       "application/zip")+  , ("zmm",       "application/vnd.handheld-entertainment+xml")+  , ("avi",       "video/x-msvideo")+  , ("movie",     "video/x-sgi-movie")+  , ("ice",       "x-conference/x-cooltalk")+  ]+
+ src/Network/Protocol/Uri.hs view
@@ -0,0 +1,614 @@+module Network.Protocol.Uri (++    URI (..)+  , Scheme+  , IPv4+  , Label+  , Domain+  , RegName+  , Port+  , Query+  , Fragment+  , Hash+  , UserInfo+  , PathSegment+  , Parameters+  , Path (..)+  , Host (..)+  , Authority (..)++  , encode+  , decode++  , mkURI+  , mkScheme+  , mkPath+  , mkAuthority+  , mkQuery+  , mkFragment+  , mkUserinfo+  , mkHost+  , mkPort++  , scheme+  , authority+  , path+  , query+  , fragment+  , userinfo+  , host+  , port+  , domains+  , pathSegments++  , setScheme+  , setAuthority+  , setPath+  , setQuery+  , setFragment+  , setUserinfo+  , setHost+  , setPort++  , modScheme+  , modAuthority+  , modPath+  , modQuery+  , modUserinfo+  , modHost+  , modPort++  , parseURI+  , parseAbsoluteURI+  , parseAuthority+  , parsePath+  , parseHost++  , pUriReference+  , pAbsoluteURI+  , pAuthority+  , pPath+  , pHost++  , parseQueryParams+  , queryParams++  , extension+  , setExtension+  , modExtension++  , relative+  , mimetype+  , normalize+  , jail+  , (/+)++  ) where++import Control.Applicative+import Data.Bits+import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit)+import Data.List (intercalate, isPrefixOf)+import Data.Maybe (mapMaybe, fromJust)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))+import System.FilePath.Posix++import Network.Protocol.Mime+import Misc.Misc++-------[ data type definition of URIs ]----------------------------------------++type Scheme      = String+type IPv4        = [Int] -- actually 4-tupel+type Label       = String+type Domain      = [Label]+type RegName     = String+type Port        = Int+type Query       = String+type Fragment    = String+type Hash        = String+type UserInfo    = String+type PathSegment = String+type Parameters  = [(String, Maybe String)]++data Path = Path {+    _absolute :: Bool+  , _segments :: [PathSegment]+  }+  deriving Eq++data Host =+    Hostname { _domain  :: Domain }+  | RegName  { _regname :: String }+  | IPv4     { _ipv4    :: IPv4   }+  deriving Eq++data Authority = Authority {+    _userinfo :: UserInfo+  , _host     :: Host+  , _port     :: Port+  }+  deriving Eq++data URI = URI {+    _relative  :: Bool+  , _scheme    :: Scheme+  , _authority :: Authority+  , _path      :: Path+  , _query     :: Query+  , _fragment  :: Fragment+  }+  deriving Eq++{-+testUri0 :: URI+testUri0 = fromJust $ parseURI "http://sebas@hs.spugium.net:8080/wiki/first%20section/chapter-2;pdf?additional=vars"++testUri1 :: URI+testUri1 = fromJust $ parseURI "http://cs.uu.nl/docs/../docs/vakken/../vakken/"+-}++-------[ creating, selection and modifying URIs ]------------------------------++-- pseudo constructors for `empty values'++mkURI :: URI+mkURI = URI False mkScheme mkAuthority mkPath mkQuery mkFragment++mkScheme :: Scheme+mkScheme = ""++mkPath :: Path+mkPath = Path False []++mkAuthority :: Authority+mkAuthority = Authority "" mkHost mkPort++mkQuery :: Query+mkQuery = ""++mkFragment :: Fragment+mkFragment = ""++mkUserinfo :: UserInfo+mkUserinfo = ""++mkHost :: Host+mkHost = Hostname []++mkPort :: Port+mkPort = (-1)++-- getter functions+scheme :: URI -> Scheme+scheme = _scheme++authority :: URI -> String+authority = show . _authority++path :: URI -> FilePath+path = decode . show . _path++query :: URI -> Query+query = decode . _query++fragment :: URI -> Fragment+fragment = _fragment++userinfo :: URI -> UserInfo+userinfo = _userinfo . _authority++host :: URI -> String+host = show . _host . _authority++port :: URI -> Port+port = _port . _authority++domains :: URI -> Domain+domains = _domain . _host . _authority++pathSegments :: URI -> [PathSegment]+pathSegments = _segments . _path ++-- setter functions+setScheme :: Scheme -> URI -> URI+setScheme s u = u { _scheme = s }++setAuthority :: String -> URI -> URI+setAuthority a u = u { _authority = fromJust $ parseAuthority a }++setPath :: String -> URI -> URI+setPath p u = u { _path = fromJust $ parsePath p }++setQuery :: Query -> URI -> URI+setQuery q u = u { _query = q }++setFragment :: Fragment -> URI -> URI+setFragment q u = u { _fragment  = q }++setUserinfo :: UserInfo -> URI -> URI+setUserinfo i u = u { _authority = (_authority u) { _userinfo = i }}++setHost :: String -> URI -> URI+setHost h u = u { _authority = (_authority u) { _host = fromJust $ parseHost h }}++setPort :: Port -> URI -> URI+setPort p u = u { _authority = (_authority u) { _port = p }}++-- modifier functions+modScheme :: (Scheme -> Scheme) -> URI -> URI+modScheme f u = setScheme (f $ scheme u) u++modAuthority :: (String -> String) -> URI -> URI+modAuthority f u = setAuthority (f $ authority u) u++modPath :: (String -> String) -> URI -> URI+modPath f u = setPath (f $ encode $ path u) u++modQuery :: (Query -> Query) -> URI -> URI+modQuery f u = setQuery (f $ query u) u++modUserinfo :: (UserInfo -> UserInfo) -> URI -> URI+modUserinfo f u = setUserinfo  (f $ userinfo u) u++modHost :: (String -> String) -> URI -> URI+modHost f u = setHost (f $ host u) u++modPort :: (Port -> Port) -> URI -> URI+modPort f u = setPort (f $ port u) u++-------[ path encoding and decoding ]------------------------------------------++encode :: String -> String+encode = concatMap encodeChr+  where+    encodeChr c+      | unreserved c || genDelims c || subDelims c = [c]+      | otherwise = '%' :+          intToDigit (shiftR (ord c) 4) :+          intToDigit ((ord c) .&. 0x0F) : []++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:ds) = d : decode ds++-------[ show instance for URIs ]----------------------------------------------++-- TODO: cleanup and test this mess: QuickCheck property for testing:+-- parse $ show u == u /\ show $ parse u' = u'++-- TODO: ShowS++instance Show Path where+  show (Path a s) =+       (if a then "/" else "")+    ++ (intercalate "/" s)++instance Show Host where+  show (Hostname d) = if null d then "" else intercalate "." d+  show (IPv4     a) = intercalate "." $ map show a+  show (RegName  r) = r++instance Show Authority where+  show (Authority u h p) =+       (if hst h then "//" else "")+    ++ (if null u then "" else u ++ "@")+    ++  show h+    ++ (if p == -1 then "" else ":" ++ show p)+    where hst (Hostname d) = not $ null d+          hst (RegName  d) = not $ null d+          hst _            = True++instance Show URI where+  show (URI r s a p q f) =+       (if not r then (if null s then "" else s ++ ":") else "")+    ++ (show a)+    ++ (show p)+    ++ (if null q then "" else "?" ++ q)+    ++ (if null f then "" else "#" ++ f)++-------[ global URI parse interface ]------------------------------------------++-- Top level parsers.+parseURI :: String -> Maybe URI+parseURI = eitherToMaybe . parse pUriReference ""++parseAbsoluteURI :: String -> Maybe URI+parseAbsoluteURI = eitherToMaybe . parse pAbsoluteURI ""++parseAuthority :: String -> Maybe Authority+parseAuthority = eitherToMaybe . parse pAuthority ""++parsePath :: String -> Maybe Path+parsePath = eitherToMaybe . parse pPath ""++parseHost :: String -> Maybe Host+parseHost = eitherToMaybe . parse pHost ""++-------[ parsing URIs according to rfc2396 ]-----------------------------------++-- D.2.  Modifications+pAlpha, pDigit, pAlphanum :: GenParser Char st Char++pAlpha    = letter+pDigit    = digit+pAlphanum = alphaNum++-- 2.3.  Unreserved Characters+unreserved :: Char -> Bool+unreserved c = isAlphaNum c || elem c "-._~"++pUnreserved :: GenParser Char st Char+pUnreserved  = pAlphanum <|> oneOf "-._~"++-- 2.2.  Reserved Characters+genDelims :: Char -> Bool+genDelims = flip elem ":/?#[]@"++subDelims :: Char -> Bool+subDelims = flip elem "!$&'()*+,;="++{-+pReserved :: GenParser Char st Char+pReserved  = pGenDelims <|> pSubDelims+pGenDelims :: GenParser Char st Char+pGenDelims = oneOf ":/?#[]@"+-}++pSubDelims :: GenParser Char st Char+pSubDelims = oneOf "!$&'()*+,;="++-- 2.1.  Percent-Encoding+pPctEncoded :: GenParser Char st String+pPctEncoded = (:) <$> char '%' <*> pHex++pHex :: GenParser Char st String+pHex = (\a b -> a:b:[])+    <$> hexDigit+    <*> hexDigit++-- 3.  Syntax Components++-- With the hier-part integrated.+pUri :: GenParser Char st URI+pUri = (\a (b,c) d e -> URI False a b c d e)+  <$> (pScheme <* string ":")+  <*> (ap <|> p)+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)+  where+    ap = (,) <$> (string "//" *> pAuthority) <*> pPathAbempty+    p  = ((,) mkAuthority) <$> (pPathAbsolute <|> pPathRootless {-<|> pPathEmpty-})++-- 3.1.  Scheme+pScheme :: GenParser Char st Scheme+pScheme = (:) <$> pAlpha <*> many (pAlphanum <|> oneOf "+_.")++-- 3.2.  Authority+pAuthority :: GenParser Char st Authority+pAuthority = Authority+  <$> option mkUserinfo (try (pUserinfo <* string "@"))+  <*> pHost+  <*> option mkPort (string ":" *> pPort)++-- 3.2.1.  User Information+pUserinfo :: GenParser Char st String+pUserinfo = concat <$> many (+      (pure <$> pUnreserved)+  <|> (         pPctEncoded)+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf ":")+  )++-- 3.2.2.  Host+pHost :: GenParser Char st Host+pHost = diff <$> pRegName -- <|> RegName <$> pRegName+  where+    diff  a = maybe (RegName a) sep (pHostname @@ a)+    sep   a = bool (Hostname a) (ipreg a) $ hst a+    ipreg a = bool (IPv4 $ map read a) (RegName $ intercalate "." a) $ ip a+    hst     = not . all isDigit . head . dropWhile null . reverse+    ip    a = length a == 4 && length (mapMaybe (pDecOctet @@) a) == 4++{-+pfff, ipv6 is sooo not gonna make it..++pIPLiteral = "[" ( IPv6address <|> IPvFuture  ) "]"++pIPvFuture = "v" 1*HEXDIG "." 1*( unreserved <|> subDelims <|> ":" )++pIPv6address =+                                 6( h16 ":" ) ls32+  <|>                       "::" 5( h16 ":" ) ls32+  <|> [               h16 ] "::" 4( h16 ":" ) ls32+  <|> [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+  <|> [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+  <|> [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32+  <|> [ *4( h16 ":" ) h16 ] "::"              ls32+  <|> [ *5( h16 ":" ) h16 ] "::"              h16+  <|> [ *6( h16 ":" ) h16 ] "::"++pH16           = 1*4HEXDIG+pLs32          = ( h16 ":" h16 ) <|> IPv4address+-}++{-+pIPv4address :: GenParser Char st [Int]+pIPv4address = (:) <$> pDecOctet <*> (count 3 $ char '.' *> pDecOctet)+-}++pDecOctet :: GenParser Char st Int+pDecOctet = read <$> choice [+    try ((\a b c -> [a,b,c]) <$> char '2' <*> char '5'      <*> oneOf "012345")+  , try ((\a b c -> [a,b,c]) <$> char '2' <*> oneOf "01234" <*> digit)+  , try ((\a b c -> [a,b,c]) <$> char '1' <*> digit         <*> digit)+  , try ((\a b   -> [a,b])   <$>              digit         <*> digit)+  ,     (pure                <$>                                digit)+  ]++pRegName :: GenParser Char st Label+pRegName = concat <$> many1 (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims))++-- Not actually part of the rfc3986, but comptability with the rfc2396.+-- This information can be useful, so why throw away.+pHostname :: GenParser Char st Domain+pHostname = sepBy (option "" pDomainlabel) (string ".")++pDomainlabel :: GenParser Char st Label+pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-")++-- 3.2.3.  Port+pPort :: GenParser Char st Port+pPort = read <$> some pDigit++-- 3.4.  Query+pQuery :: GenParser Char st String+pQuery = concat <$> many (pPchar <|> pure <$> oneOf "/?")++-- 3.5.  Fragment+pFragment :: GenParser Char st String+pFragment = concat <$> many (pPchar <|> pure <$> oneOf "/?" )++-- 3.3.  Path++pPath, pPathAbempty, pPathAbsolute, pPathNoscheme, pPathRootless, pPathEmpty+  :: GenParser Char st Path++pPath =+      try pPathAbsolute -- begins with "/" but not "//"+  <|> try pPathNoscheme -- begins with a nonColon segment+  <|> try pPathRootless -- begins with a segment+  <|> pPathEmpty        -- zero characters++pPathAbempty  = (Path True) <$> _pSlashSegments+pPathAbsolute = (char '/' *>) $ (Path True) <$> (option [] $ (:) <$> pSegmentNz <*> _pSlashSegments)+pPathNoscheme = (Path False) <$> ((:) <$> pSegmentNzNc <*> _pSlashSegments)+pPathRootless = (Path False) <$> ((:) <$> pSegmentNz    <*> _pSlashSegments)+pPathEmpty    = (Path False []) <$ string ""++pSegment, pSegmentNz, pSegmentNzNc :: GenParser Char st String+pSegment     = concat <$> many pPchar+pSegmentNz   = concat <$> some pPchar+pSegmentNzNc = concat <$> some (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf "@" ))++_pSlashSegments :: GenParser Char st [PathSegment]+_pSlashSegments = (many $ (:) <$> char '/' *> pSegment)++pPchar :: GenParser Char st String+pPchar = choice [+    pure <$> pUnreserved+  , pPctEncoded+  , pure <$> pSubDelims+  , pure <$> oneOf ":@"+  ]++-- 4.1.  URI Reference++pUriReference :: GenParser Char st URI+pUriReference = try pAbsoluteURI <|> pRelativeRef++-- 4.2.  Relative Reference++-- With the relative-part integrated.+pRelativeRef :: GenParser Char st URI+pRelativeRef = ($)+  <$> (try pRelativePart+  <|> ((URI True mkScheme mkAuthority)+  <$> (pPathAbsolute <|> pPathRootless <|> pPathEmpty)))+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)++pRelativePart :: GenParser Char st (Query -> Fragment -> URI)+pRelativePart = (URI True mkScheme) <$> (string "//" *> pAuthority) <*> pPathAbempty++-- 4.3.  Absolute URI++pAbsoluteURI :: GenParser Char st URI+pAbsoluteURI = pUri++-------[ parsing query parameters ]--------------------------------------------++-- Parse a pre-decoded query string into key value pairs parameters.++pQueryParams :: GenParser Char st Parameters+pQueryParams = +      filter (not . null . fst)+  <$> sepBy ((,)+  <$> many (noneOf "=&")+  <*> pMaybe (char '='+   *> many (noneOf "&")))+      (char '&')++parseQueryParams :: String -> Maybe Parameters+parseQueryParams = eitherToMaybe . parse pQueryParams  ""++queryParams :: URI -> Parameters+queryParams = maybe [] id . parseQueryParams . query++-------[ filename path utilities ]---------------------------------------------++extension :: URI -> Maybe String+extension u = do+  lst <- safeLast . _segments . _path $ u+  guardMaybe (elem '.' lst)+  return $ withReverse (takeWhile (/='.')) lst++setExtension :: Maybe String -> URI -> URI+setExtension e u =+  let ex = maybe "" ('.':) e in+  (\f -> modPath (\p -> f p ++ ex) u)+  $ maybe id (const $ withReverse (tail . dropWhile (/='.')))+    (extension u)++modExtension :: (String -> String) -> URI -> URI+modExtension f u = setExtension (f `fmap` extension u) u++relative :: URI -> URI+relative = modPath (dropWhile (=='/'))++-- Try to guess the 'correct' mime type for the input file based on the file+-- extension.++mimetype :: URI -> Maybe String+mimetype u = extension u >>= mime++-- 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 absolute $ intercalate "/" $ norm+  where+    fixAbs True          = ('/':)+    fixAbs False         = id+    absolute             = head p == '/'+    norm                 = fixp False $ split '/' p+    fixp False xs        = let ys = merge xs in fixp (xs == ys) ys+    fixp True  xs        = xs+    merge ("":xs)        = merge xs+    merge (".":xs)       = merge xs+    merge ("..":"..":xs) = ".." : ".." : merge xs+    merge (_:"..":xs)    = merge xs+    merge (x:xs)         = x : merge xs+    merge xs             = xs++jail :: FilePath -> FilePath -> 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++(/+) :: FilePath -> FilePath -> FilePath+a /+ b = normalize (a ++ "/" ++ b)+
+ src/Network/Salvia/Advanced/CleverCSS.hs view
@@ -0,0 +1,32 @@+module Network.Salvia.Advanced.CleverCSS (+    hFilterCSS+  , hCleverCSS+  , hParametrizedCleverCSS+  ) where++import Text.CSS.CleverCSS (cleverCSSConvert)++import Network.Salvia.Handlers.ExtensionDispatcher (hExtension)+import Network.Salvia.Handlers.File (hFile, hFileFilter)+import Network.Salvia.Handlers.Rewrite (hRewriteExt)+import Network.Salvia.Handlers.PathRouter (hParameters)+import Network.Salvia.Handlers.Fallback (hOr)+import Network.Protocol.Uri (Parameters)+import Network.Salvia.Httpd (Handler)++hFilterCSS :: Handler () -> Handler () -> Handler ()+hFilterCSS cssfilter handler = do+  hExtension (Just "css")+    (hFile `hOr` cssfilter)+    handler++hCleverCSS :: Handler ()+hCleverCSS = do+  params <- hParameters+  hParametrizedCleverCSS params++hParametrizedCleverCSS :: Parameters -> Handler ()+hParametrizedCleverCSS p = do+  hRewriteExt ('c':) (hFileFilter convert)+  where convert = either id id . flip (cleverCSSConvert "") (map (fmap $ maybe "" id) p)+
+ src/Network/Salvia/Advanced/ExtendedFileSystem.hs view
@@ -0,0 +1,17 @@+module Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem) where++import Network.Salvia.Handlers.File (hFile)+import Network.Salvia.Handlers.Directory (hDirectory)+import Network.Salvia.Handlers.FileSystem (hFileTypeDispatcher)+import Network.Salvia.Httpd (Handler)+import Network.Salvia.Advanced.HsColour (hHighlightHaskell, hHsColour)+import Network.Salvia.Advanced.CleverCSS (hFilterCSS, hCleverCSS)++hExtendedFileSystem :: FilePath -> Handler ()+hExtendedFileSystem dir =+  hFileTypeDispatcher dir+    hDirectory+    (hHighlightHaskell hHsColour+      $ hFilterCSS hCleverCSS+      $ hFile)+
+ src/Network/Salvia/Advanced/HsColour.hs view
@@ -0,0 +1,55 @@+module Network.Salvia.Advanced.HsColour (+    hHighlightHaskell+  , hHsColour+  , hHsColourCustomStyle++  , defaultStyleSheet+  ) where++import Language.Haskell.HsColour.CSS++import Network.Salvia.Handlers.ExtensionDispatcher+import Network.Salvia.Handlers.File+import Network.Protocol.Http (setContentType, utf8)+import Network.Salvia.Httpd++hHighlightHaskell :: Handler () -> Handler () -> Handler ()+hHighlightHaskell highlighter = +  hExtensionRouter [+    (Just "hs",  highlighter)+  , (Just "lhs", highlighter)+  , (Just "ag",  highlighter)+  ] ++hHsColour :: Handler ()+hHsColour = hHsColourCustomStyle (Left defaultStyleSheet)++-- Left means direct inclusion of stylesheet, right means link to external+-- stylesheet.++hHsColourCustomStyle :: Either String String -> Handler ()+hHsColourCustomStyle style = do+  sendStr (either id makeStyleLink style)+  hFileFilter (hscolour False True "")+  modResponse+    $ setContentType ("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
@@ -0,0 +1,33 @@+module Network.Salvia.Core.Config (+    HttpdConfig (..)+  , defaultConfig+  ) where++import Network.Socket hiding (send, listen)+import System.IO++-------- server configuration -------------------------------------------------++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.+   }++defaultConfig :: IO HttpdConfig+defaultConfig = do+  addr <- inet_addr "0.0.0.0"+  return+    $ HttpdConfig {+      hostname   = "hostname"+    , email      = "www@hostname"+    , listenAddr = addr+    , listenPort = 80+    , backlog    = 4+    , bufferSize = 64 * 1024+    }+
+ src/Network/Salvia/Core/Handler.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.Salvia.Core.Handler (+    SendAction+  , SendQueue+  , Context (..)+  , makeContext++  , Handler+  , ResourceHandler+  , UriHandler+  , putRequest, putResponse, putQueue+  , modRequest, modResponse, modQueue+  , withRequest, withResponse+  ) where++import Control.Applicative (Applicative, pure, (<*>))+import Control.Monad.State (StateT, ap, modify, gets)+import Network.Socket (SockAddr)+import System.IO++import Network.Salvia.Core.Config+import Network.Protocol.Http (Message, emptyRequest, emptyResponse)+import Network.Protocol.Uri (URI)++-------- single request/response context --------------------------------------++type SendAction = Handle -> IO ()+type SendQueue  = [SendAction]++data Context =+  Context {+  -- | The HTTP server configuration.+    config   :: HttpdConfig+  -- | The HTTP request header.+  , request  :: Message+  -- | The HTTP response header.+  , response :: Message+  -- | The socket handle for the connection with the client.+  , sock     :: Handle+  -- | The client addres.+  , address  :: SockAddr+  -- | The queue of send actions.+  , queue    :: SendQueue+  }++-- Create and empty server context.+makeContext :: HttpdConfig -> SockAddr -> Handle -> Context+makeContext c a s = Context {+    config   = c+  , request  = emptyRequest+  , response = emptyResponse  -- 200 OK, by default.+  , sock     = s+  , address  = a+  , queue    = []+  }++-------- request handlers -----------------------------------------------------++-- HTTP handler types.+type Handler         a = StateT Context IO a+type ResourceHandler a = FilePath -> Handler a+type UriHandler      a = URI -> Handler a++-- Make handlers applicative.+instance Applicative (StateT Context IO) where+  pure  = return+  (<*>) = ap++-- Domain specific setters and modifiers.++putRequest :: Message -> Handler ()+putRequest  r = modify (\m -> m { request  = r })++modRequest :: (Message -> Message) -> Handler ()+modRequest  f = gets request  >>= putRequest  . f++putResponse :: Message -> Handler ()+putResponse r = modify (\m -> m { response = r })++modResponse :: (Message -> Message) -> Handler ()+modResponse f = gets response >>= putResponse . f++putQueue :: SendQueue -> Handler ()+putQueue    q = modify (\m -> m { queue = q })++modQueue :: (SendQueue -> SendQueue) -> Handler ()+modQueue    f = gets queue >>= putQueue . f++-- Execute handlers in a modified environment, but restore the original state.+-- This is comparable to the `local' function from the Reader monad.+withModified :: (Monad m) => m d -> (t -> m a) -> (d -> m b) -> t -> m c -> m c+withModified get m put f h =+  do { o <- get ; m f ; r <- h ; put o ; return r }++withRequest :: (Message -> Message) -> Handler a -> Handler a+withRequest = withModified (gets request) modRequest putRequest++withResponse :: (Message -> Message) -> Handler a -> Handler a+withResponse = withModified (gets response) modResponse putResponse+
+ src/Network/Salvia/Core/IO.hs view
@@ -0,0 +1,134 @@+module Network.Salvia.Core.IO (++    sendHeaders++  , send+  , sendStr+  , sendStrLn+  , sendBs++  , spool+  , spoolBs+  , spoolAll+  , spoolN++  , emptyQueue+  , reset++  , contents+  , contentsUtf8+  , uriEncodedPostParamsUTF8++  ) where++-- TODO: we are mixing two encoding libs. fix.++import Control.Monad.State+import Data.Encoding (decodeLazy)+import Data.Encoding.UTF8+import System.IO+import qualified Data.ByteString.Lazy as B+import qualified System.IO.UTF8 as U++import Network.Protocol.Http+import Network.Protocol.Uri (Parameters, parseQueryParams, decode)+import Network.Salvia.Core.Handler++-------------------------------------------------------------------------------++-- Send the response header to the socket.+sendHeaders :: Handler ()+sendHeaders = do+  r <- gets response+  s <- gets sock +  lift $ hPutStr s (showMessageHeader r)++-- Queue a potential send action in the send queue.+send :: SendAction -> Handler ()+send f = modify (\m -> m { queue = (queue m) ++ [f] })++-- Queue a String for sending.+sendStr, sendStrLn :: String -> Handler ()+sendStr s   = send (flip U.hPutStr s)+sendStrLn s = send (flip U.hPutStr (s ++ "\n"))++-- Queue a ByteString for sending.+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.+-}+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.+-}+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++{-+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++-- Reset the send queue.+emptyQueue :: Handler ()+emptyQueue = putQueue []++-- Reset both the send queue and the generated response.+reset :: Handler ()+reset = do+  putResponse 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.+-}++contents :: Handler (Maybe B.ByteString)+contents = do+  r <- gets request+  s <- gets sock+  let len = getContentLength r+      kpa = getKeepAlive     r+  lift $+    case (kpa, len) of+      (_,       Just n)  -> liftM Just (B.hGet s 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.+-}++contentsUtf8 :: Handler (Maybe String)+contentsUtf8 = (fmap $ decodeLazy UTF8) `liftM` contents++uriEncodedPostParamsUTF8 :: Handler (Maybe Parameters)+uriEncodedPostParamsUTF8 = liftM (>>= parseQueryParams . decode) contentsUtf8+
+ src/Network/Salvia/Core/Main.hs view
@@ -0,0 +1,27 @@+module Network.Salvia.Core.Main (start) where++import Control.Monad.State++import Network.Salvia.Core.Config (listenAddr, listenPort, backlog, HttpdConfig)+import Network.Salvia.Core.Handler (Handler, makeContext)+import Network.Salvia.Core.Network (server)++-------- HTTP deamon implementation -------------------------------------------++{-+Given a server configuration and a handler to invoke when receiving client+request the server starts and keep running forever.+-}++start :: HttpdConfig -> Handler () -> IO ()+start config httpHandler =+  server+    (listenAddr config)+    (listenPort config)+    (backlog config)+    tcpHandler+  where+    tcpHandler handle addr = +      fst `liftM` runStateT httpHandler+        (makeContext config addr handle)+
+ src/Network/Salvia/Core/Network.hs view
@@ -0,0 +1,53 @@+module Network.Salvia.Core.Network where++import Control.Concurrent (forkIO)+-- import Control.Exception (try)+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/Handlers/Banner.hs view
@@ -0,0 +1,26 @@+module Network.Salvia.Handlers.Banner (hBanner) where++import Control.Monad.State+import Data.Time.Clock (getCurrentTime)+import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)+import Data.Time.Format (formatTime)+import System.Locale (defaultTimeLocale)++import Network.Salvia.Httpd+import Network.Protocol.Http++-- | 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 server = do+  date <- lift $ do+    zone <- getCurrentTimeZone+    time <- liftM (utcToLocalTime zone) getCurrentTime+    return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time+  modResponse+    $ setDate   date+    . setServer server+
+ src/Network/Salvia/Handlers/CGI.hs view
@@ -0,0 +1,19 @@+module Network.Salvia.Handlers.CGI (hCGI) where++import Control.Monad.State+import System.IO+import System.Process (runProcess, waitForProcess)++import Network.Salvia.Httpd+import Network.Protocol.Http++hCGI :: FilePath -> Handler ()+hCGI name = do+  modResponse+    $ setStatus OK+  h <- gets sock+  lift $ do+    p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)+    waitForProcess p+    return ()+
+ src/Network/Salvia/Handlers/Cookie.hs view
@@ -0,0 +1,37 @@+module Network.Salvia.Handlers.Cookie (+    hSetCookies+  , hGetCookies++  , newCookie+  ) where++import Control.Applicative hiding (empty)+import Control.Monad.State+import Data.Time.Format+import Data.Time.LocalTime+import System.Locale (defaultTimeLocale)++import Network.Salvia.Httpd+import Network.Protocol.Cookie+import Network.Protocol.Http (getCookie, setCookie)++hSetCookies :: Cookies -> Handler ()+hSetCookies = modResponse . setCookie . showCookies++hGetCookies :: Handler (Maybe Cookies)+hGetCookies = parseCookies <$> getCookie <$> gets 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 <- gets 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 view
@@ -0,0 +1,11 @@+module Network.Salvia.Handlers.Counter (hCounter) where++import Control.Monad.State+import Control.Concurrent.STM++import Network.Salvia.Httpd++hCounter :: TVar Int -> Handler ()+hCounter c = lift $ atomically+  $ readTVar c >>= writeTVar c . (+1)+
+ src/Network/Salvia/Handlers/Default.hs view
@@ -0,0 +1,32 @@+module Network.Salvia.Handlers.Default (hDefault) where++import System.IO+import Control.Concurrent.STM++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 Network.Protocol.Http++hDefault :: TVar Int -> Sessions a -> SessionHandler a () -> Handler ()+hDefault count sessions handler = do+  hBanner "salvia-httpd"+  hParser onerror+    $ hHead $ do+      session <- hSession sessions 300+      handler session+  hPrinter+  hLog count stdout+  hCounter count+  where+    onerror err = do+      hError BadRequest+      sendStrLn []+      sendStrLn err+
+ src/Network/Salvia/Handlers/Directory.hs view
@@ -0,0 +1,55 @@+module Network.Salvia.Handlers.Directory (+    hDirectory+  , hDirectoryResource+  ) where++import Control.Monad.State+import Data.List (sort)+import System.Directory (doesDirectoryExist, getDirectoryContents)++import Network.Salvia.Httpd+import Network.Salvia.Handlers.Redirect+import Network.Salvia.Handlers.File (hResource)+import Network.Protocol.Http+import Network.Protocol.Uri (path, modPath)+import Misc.Misc (bool)++hDirectory :: Handler ()+hDirectory = hResource hDirectoryResource++hDirectoryResource :: ResourceHandler ()+hDirectoryResource dirName = do+  req <- gets request+  if (null $ path $ uri req) || (last $ path $ uri req) /= '/'+   then hRedirect (modPath (++"/") $ uri req)+   else dirHandler dirName++dirHandler:: ResourceHandler ()+dirHandler dirName = do+  req <- gets request+  filenames <- lift $ getDirectoryContents dirName+  processed <- lift $ mapM (processFilename dirName) (sort filenames)+  let b = listing (path $ uri req) processed+  modResponse+    $ setContentType   "text/html" Nothing+    . setContentLength (length b)+    . setStatus 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 view
@@ -0,0 +1,24 @@+module Network.Salvia.Handlers.Dispatching (+    Dispatcher+  , ListDispatcher+  , hDispatch+  , hListDispatch+  ) where++import Control.Monad.State++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 c, Show a) => (Context -> c) -> (a -> c -> Bool) -> Dispatcher a b+hDispatch f match a handler _default = do+  ctx <- gets 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 view
@@ -0,0 +1,47 @@+module Network.Salvia.Handlers.Error (+    hError+  , hCustomError+  , hIOError+  , safeIO+  ) where++import System.IO.Error++import Control.Monad.State+import Network.Salvia.Httpd+import Network.Protocol.Http++{- |+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+  modResponse+    $ setStatus e+    . setContentType "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 view
@@ -0,0 +1,16 @@+module Network.Salvia.Handlers.ExtensionDispatcher (+    hExtension+  , hExtensionRouter+  ) where++import Network.Salvia.Httpd (request)+import Network.Protocol.Http (uri)+import Network.Protocol.Uri (extension)+import Network.Salvia.Handlers.Dispatching++hExtension :: Dispatcher (Maybe String) a+hExtension = hDispatch (extension . uri . request) (==)++hExtensionRouter :: ListDispatcher (Maybe String) a+hExtensionRouter = hListDispatch hExtension+
+ src/Network/Salvia/Handlers/Fallback.hs view
@@ -0,0 +1,24 @@+module Network.Salvia.Handlers.Fallback (hOr, hEither) where++import Control.Applicative+import Control.Monad.State+import Network.Salvia.Httpd+import Network.Protocol.Http++{- |+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 <- gets (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 view
@@ -0,0 +1,69 @@+module Network.Salvia.Handlers.File (+    hFile+  , hFileResource++  , hFileFilter+  , hFileResourceFilter++  , hResource+  , hUri+  ) where++import Control.Monad.State+import System.IO++import Network.Salvia.Httpd+import Network.Salvia.Handlers.Error+import Network.Protocol.Http+import Network.Protocol.Uri (mimetype, path, parseURI)+import Network.Protocol.Mime++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 = gets request >>= rh . path . uri++{-+Turn a URI handler into a regular handler that utilizes the request URI as the+resource identifier.+-}++hUri :: UriHandler a -> Handler a+hUri rh = gets request >>= rh . uri++-------- 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)+  safeIO (openBinaryFile file ReadMode)+    $ \fd -> do+      fs <- lift $ hFileSize fd+      modResponse+        $ setContentType m (Just "utf-8")+        . setContentLength fs+        . setStatus 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)+  safeIO (openBinaryFile file ReadMode)+    $ \fd -> do+      modResponse+        $ setContentType m (Just "utf-8")+        . setStatus OK+      spool fFilter fd+
+ src/Network/Salvia/Handlers/FileSystem.hs view
@@ -0,0 +1,41 @@+module Network.Salvia.Handlers.FileSystem (+    hFileSystem+  , hFileSystemNoIndexes+  , hFileTypeDispatcher+  ) where++import Control.Monad.State+import System.Directory (doesDirectoryExist)++import Network.Salvia.Httpd+import Network.Salvia.Handlers.Error+import Network.Salvia.Handlers.File+import Network.Salvia.Handlers.Directory+import Network.Salvia.Handlers.Rewrite+import Network.Protocol.Http+import Network.Protocol.Uri (jail)+import Misc.Misc (bool)++-- Show file contents and show directory indexes.+hFileSystem :: ResourceHandler ()+hFileSystem dir = hFileTypeDispatcher dir hDirectory hFile++-- Show file contents, do not show directory indexes.+hFileSystemNoIndexes :: ResourceHandler ()+hFileSystemNoIndexes dir = hFileTypeDispatcher dir (hError Forbidden) hFile++-- Dispatch based on file type, regular files or directories.+hFileTypeDispatcher :: FilePath -> Handler () -> Handler () -> Handler () +hFileTypeDispatcher dir hdir hfile =+  hWithDir dir+    $ hResource+    $ hJailedDispatch dir hdir hfile++hJailedDispatch :: FilePath -> Handler () -> Handler () -> ResourceHandler () +hJailedDispatch dir hdir hfile file = do+  case jail dir file of+    Nothing -> hError Forbidden+    Just f  -> do+      isDir <- lift (doesDirectoryExist f)+      bool hdir hfile isDir+
+ src/Network/Salvia/Handlers/Head.hs view
@@ -0,0 +1,23 @@+module Network.Salvia.Handlers.Head (hHead) where++import Control.Applicative+import Control.Monad.State++import Network.Salvia.Httpd+import Network.Protocol.Http++{- |+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 <- gets (method . request)+  case m of+    HEAD -> withRequest (setMethod GET) handler+         <* emptyQueue+    _    -> handler+
+ src/Network/Salvia/Handlers/Log.hs view
@@ -0,0 +1,31 @@+module Network.Salvia.Handlers.Log (hLog) where++import Control.Concurrent.STM+import Control.Monad.State+import System.IO++import Network.Salvia.Httpd  (Handler, request, response, address)+import Network.Protocol.Http+import Misc.Terminal (red, green, reset)++-- TODO: handle should be tvar as well+hLog :: TVar Int -> Handle -> Handler Handle+hLog count handle = do+  c    <- lift $ atomically $ readTVar count+  req  <- gets request+  res  <- gets response+  addr <- gets address+  let st   = status res+      code = codeFromStatus st+      clr  = if code >= 400 then red else green+  lift $ hPutStrLn handle $ concat [+      concat ["[", show addr, "] ", show c, "\t"]+    , show $ method req, "\t"+    , show $ uri req , " -> "+    , clr+    , show code, " "+    , show st+    , reset+    ]+  return handle+
+ src/Network/Salvia/Handlers/Login.hs view
@@ -0,0 +1,242 @@+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++  -- * Helper functions.+  , readUserDatabase++  ) where++import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)+import Control.Monad.State (lift, liftM)++import Network.Salvia.Handlers.Error (hCustomError, hError)+import Network.Salvia.Handlers.Session+import Network.Salvia.Httpd hiding (start)+import Network.Protocol.Http (Status (Unauthorized, OK), setStatus)+import Misc.Misc (atomModTVar, safeHead)+import qualified Network.Protocol.Uri as URI++-------------------------------------------------------------------------------++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+  , 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+  }++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:acts -> Just (User user pass acts)+        _              -> Nothing++printUserLine :: User -> String+printUserLine u = intercalate " " ([username u, password 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 freshUserPass 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)++freshUserPass :: Maybe URI.Parameters -> Users -> Actions -> Maybe User+freshUserPass params us acts = do+  p <- params+  user <- "username" `lookup` p >>= id+  pass <- "password" `lookup` p >>= id+  case safeHead $ filter ((==user).username) us of+    Nothing -> return $ User user pass 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 URI.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 == 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+  modResponse $ setStatus 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 :: Show a => UserSessionHandler a ()+hLoginfo s = do+  s' <- lift $ atomically $ readTVar s++  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 _ acts) _ _) -> do+      sendStrLn $ "username=" ++ uname+      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+
+ src/Network/Salvia/Handlers/MethodRouter.hs view
@@ -0,0 +1,41 @@+module Network.Salvia.Handlers.MethodRouter (+    hMethod+  , hMethodRouter++  , hOPTIONS+  , hGET+  , hHEAD+  , hPOST+  , hPUT+  , hDELETE+  , hTRACE+  , hCONNECT+  ) where++import Network.Salvia.Handlers.Dispatching+import Network.Salvia.Handlers.Error+import Network.Salvia.Httpd+import Network.Protocol.Http++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 view
@@ -0,0 +1,41 @@+module Network.Salvia.Handlers.Parser (hParser) where++import System.IO+import Control.Monad.State+import Text.ParserCombinators.Parsec (parse)++import Network.Salvia.Httpd+import Network.Protocol.Http++{- |+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 <- gets 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+      putRequest 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 view
@@ -0,0 +1,37 @@+module Network.Salvia.Handlers.PathRouter (+    hPath+  , hPathRouter+  , hPrefix+  , hPrefixRouter++  , hParameters+  ) where++import Control.Monad.State+import Data.List (isPrefixOf)++import Network.Salvia.Httpd+import Network.Protocol.Http+import Network.Protocol.Uri (modPath, path, queryParams, Parameters)+import Network.Salvia.Handlers.Dispatching++chop :: String -> Handler a -> Handler a+chop a = withRequest $ modUri $ modPath $ drop $ length a++hPath :: Dispatcher String a+hPath p h d = hDispatch (path . uri . request) (==) p (chop p h) d++hPathRouter :: ListDispatcher String b+hPathRouter = hListDispatch hPath++hPrefix :: Dispatcher String a+hPrefix p h d = hDispatch (path . uri . request) isPrefixOf p (chop p h) d++hPrefixRouter :: ListDispatcher String b+hPrefixRouter = hListDispatch hPrefix++-- Path related utilities.++hParameters :: Handler Parameters+hParameters = gets (queryParams . uri . request)+
+ src/Network/Salvia/Handlers/Printer.hs view
@@ -0,0 +1,23 @@+module Network.Salvia.Handlers.Printer (hPrinter) where++import Control.Monad.State++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 <- gets sock+  q <- gets queue+  lift $ mapM_ ($ s) q+
+ src/Network/Salvia/Handlers/Put.hs view
@@ -0,0 +1,27 @@+module Network.Salvia.Handlers.Put (hPut) where++import Control.Monad.State+import System.IO+import qualified Data.ByteString.Lazy as B++import Network.Salvia.Httpd+import Network.Salvia.Handlers.Error+import Network.Protocol.Http++{- |+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 view
@@ -0,0 +1,12 @@+module Network.Salvia.Handlers.Redirect (hRedirect) where++import Network.Salvia.Httpd+import Network.Protocol.Http+import Network.Protocol.Uri (URI)++hRedirect :: URI -> Handler ()+hRedirect u = do+  modResponse+    $ setLocation u+    . setStatus MovedPermanently+
+ src/Network/Salvia/Handlers/Rewrite.hs view
@@ -0,0 +1,38 @@+module Network.Salvia.Handlers.Rewrite (+    hRewrite+  , hRewritePath+  , hRewriteHost+  , hRewriteExt+  , hWithDir+  , hWithoutDir+  ) where++import Data.List (isPrefixOf)+import Control.Monad.State++import Network.Salvia.Httpd+import Network.Protocol.Http+import Network.Protocol.Uri (URI, modPath, modHost, path, modExtension)++hRewrite :: (URI -> URI) -> Handler a -> Handler a+hRewrite f h = withRequest (modUri f) h++hRewriteHost :: (String -> String) -> Handler a -> Handler a+hRewriteHost f h = withRequest (modUri $ modHost f) h++hRewritePath :: (String -> String) -> Handler a -> Handler a+hRewritePath f h = withRequest (modUri $ modPath f) h++hRewriteExt :: (String -> String) -> Handler a -> Handler a+hRewriteExt f = hRewrite (modExtension f)++hWithDir :: String -> Handler a -> Handler a+hWithDir d = hRewritePath (d++)++hWithoutDir :: String -> Handler a -> Handler a+hWithoutDir d h = do+  req <- gets request+  if (d `isPrefixOf` (path $ uri $ req))+    then hRewritePath (drop (length d)) h+    else h+
+ src/Network/Salvia/Handlers/Session.hs view
@@ -0,0 +1,181 @@+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 Prelude hiding (lookup)+import System.Random+import qualified Data.Map as M++import Network.Salvia.Handlers.Cookie+import Network.Salvia.Httpd hiding (start)+import Network.Protocol.Cookie hiding (empty)+import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)++-------------------------------------------------------------------------------++-- 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+  }++-- 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 view
@@ -0,0 +1,16 @@+module Network.Salvia.Handlers.VirtualHosting (hVirtualHosting) where++import Data.List (isPrefixOf)++import Network.Salvia.Httpd+import Network.Protocol.Http+import Network.Salvia.Handlers.Dispatching++-- isSuffixOf?++hVirtualHosting1 :: Dispatcher String a+hVirtualHosting1 = hDispatch (getHost . request) isPrefixOf++hVirtualHosting :: ListDispatcher String a+hVirtualHosting = hListDispatch hVirtualHosting1+
+ src/Network/Salvia/Httpd.hs view
@@ -0,0 +1,44 @@+module Network.Salvia.Httpd (++  -- Httpd.Core.Config+    HttpdConfig (..)+  , defaultConfig++  -- Httpd.Core.Handler+  , Context (..)+  , makeContext++  , Handler+  , ResourceHandler+  , UriHandler+  , putRequest, putResponse, putQueue+  , modRequest, modResponse, modQueue+  , withRequest, withResponse++  -- Httpd.Core.IO+  , sendHeaders+  , send+  , sendStr+  , sendStrLn+  , sendBs+  , spool+  , spoolBs+  , spoolAll+  , spoolN+  , emptyQueue+  , reset++  , contents+  , contentsUtf8+  , uriEncodedPostParamsUTF8++  -- Httpd.Core.Main+  , start++  ) where++import Network.Salvia.Core.Config+import Network.Salvia.Core.Handler+import Network.Salvia.Core.IO+import Network.Salvia.Core.Main+