packages feed

salvia 0.1.2 → 1.0.0

raw patch · 56 files changed

+1829/−4164 lines, 56 filesdep +MaybeT-transformersdep +monads-fddep +safedep −bimapdep −encodingdep −filepathdep ~basedep ~containersdep ~fclabels

Dependencies added: MaybeT-transformers, monads-fd, safe, salvia-protocol, split, text, threadmanager, transformers, unix

Dependencies removed: bimap, encoding, filepath, mtl, parsec

Dependency ranges changed: base, containers, fclabels, network, pureMD5

Files

salvia.cabal view
@@ -1,85 +1,98 @@-Name:             salvia-Version:          0.1.2-Description:      Lightweight Haskell Web Server Framework with modular support-                  for serving static files, directories indices, default error-                  responses, connection counting and logging, HEAD and PUT-                  requests, keep-alives, custom banner printing, default-                  handler environments for parsing request and printing-                  responses, dispatching based on request methods, URI, paths-                  and filename extension, URI rewriting and redirection,-                  virtual hosting, cookie, session and user management and-                  more...+Name:               salvia+Version:            1.0.0+Description:        +  Salvia is a feature rich modular web server and web application framework+  that can be used to write dynamic websites in Haskell. From the lower level+  protocol code up to the high level application code, everything is written as+  a Salvia handler. This approach makes the server extremely extensible. To see+  a demo of a Salvia website, please see the /salvia-demo/ package.+  .+  All the low level protocol code can be found in the /salvia-protocol/+  package, which exposes the datatypes, parsers and pretty-printers for the+  URI, HTTP, Cookie and MIME protocols.+  .+  This Salvia package itself can be separated into three different parts: the+  interface, the handlers and the implementation. The /interface/ module+  defines a number of type classes that the user can build the web application+  against. Reading the request object, writing to the response, or gaining+  direct access to the socket, all of these actions are reflected using one+  type class aspect in the interface. The /handlers/ are self contained modules+  that implement a single aspect of the Salvia web server. The handlers expose+  their interface requirements in their type context. Salvia can have multiple+  /implementations/ which can be switched by using different instances for the+  interface type classes. This package has only one implementation, a simple+  accepting socket loop server. The /salvia-extras/ package has two additional+  implementations. Keeping a clear distinction between the abstract server+  aspects and the actual implementation makes it very easy to migrate existing+  web application to different back-ends. -Synopsis:         Lightweight Haskell Web Server Framework -Cabal-version:    >= 1.6-Category:         Network, Web-License:          BSD3-License-file:     LICENSE-Author:           Sebastiaan Visser-Maintainer:       sfvisser@cs.uu.nl-Build-Type:       Simple-Build-Depends:    base ==3.0.*,-                  network ==2.2.*,-                  containers ==0.2.*,-                  parsec ==3.0.*,-                  filepath == 1.1.*,-                  fclabels ==0.1.*,-                  utf8-string ==0.3.*,-                  bytestring ==0.9.*,-                  old-locale ==1.0.*,-                  time ==1.1.*,-                  encoding ==0.5.*,-                  process ==1.0.*,-                  stm ==2.1.*,-                  pureMD5 ==0.2.*,-                  directory ==1.0.*,-                  bimap ==0.2.*,-                  mtl ==1.1.*,-                  random ==1.0.*-GHC-Options:      -threaded -Wall -fno-warn-orphans-Extensions:       CPP-HS-Source-Dirs:   src-Other-modules:    Misc.Misc,-                  Misc.Terminal,-                  Network.Protocol.Http.Data,-                  Network.Protocol.Http.Parser,-                  Network.Protocol.Http.Printer,-                  Network.Protocol.Http.Status-Exposed-modules:  Demo,-                  Network.Protocol.Cookie,-                  Network.Protocol.Http,-                  Network.Protocol.Mime,-                  Network.Protocol.Uri,-                  Network.Salvia.Core.Config,-                  Network.Salvia.Core.Context,-                  Network.Salvia.Core.Handler,-                  Network.Salvia.Core.IO,-                  Network.Salvia.Core.Main,-                  Network.Salvia.Handler.Banner,-                  Network.Salvia.Handler.CGI,-                  Network.Salvia.Handler.Close,-                  Network.Salvia.Handler.Cookie,-                  Network.Salvia.Handler.Counter,-                  Network.Salvia.Handler.Directory,-                  Network.Salvia.Handler.Dispatching,-                  Network.Salvia.Handler.Environment,-                  Network.Salvia.Handler.Error,-                  Network.Salvia.Handler.ExtensionDispatcher,-                  Network.Salvia.Handler.Fallback,-                  Network.Salvia.Handler.File,-                  Network.Salvia.Handler.FileSystem,-                  Network.Salvia.Handler.Head,-                  Network.Salvia.Handler.Log,-                  Network.Salvia.Handler.Login,-                  Network.Salvia.Handler.MethodRouter,-                  Network.Salvia.Handler.Parser,-                  Network.Salvia.Handler.PathRouter,-                  Network.Salvia.Handler.Printer,-                  Network.Salvia.Handler.Put,-                  Network.Salvia.Handler.Redirect,-                  Network.Salvia.Handler.Rewrite,-                  Network.Salvia.Handler.Session,-                  Network.Salvia.Handler.VirtualHosting,-                  Network.Salvia.Handlers-                  Network.Salvia.Httpd+Synopsis:           Modular web application framework.+Cabal-version:      >= 1.6+Category:           Network, Web+License:            BSD3+License-file:       LICENSE+Author:             Sebastiaan Visser+Maintainer:         sfvisser@cs.uu.nl+Build-Type:         Simple++Library+  GHC-Options:      -Wall -fno-warn-orphans+  HS-Source-Dirs:   src++  Build-Depends:    base ==4.*,+                    bytestring ==0.9.*,+                    containers >= 0.2 && < 0.4,+                    directory ==1.0.*,+                    fclabels ==0.4.*,+                    MaybeT-transformers == 0.1.*,+                    monads-fd ==0.0.*,+                    network >= 2.2.1.7 && < 2.3,+                    old-locale ==1.0.*,+                    process ==1.0.*,+                    threadmanager ==0.1.3,+                    pureMD5 ==1.0.*,+                    random ==1.0.*,+                    safe ==0.2.*,+                    stm ==2.1.*,+                    time ==1.1.*,+                    transformers ==0.1.*,+                    unix >= 2.3 && < 2.5,+                    utf8-string ==0.3.*,+                    salvia-protocol ==1.0.*,+                    split ==0.1.*,+                    text >= 0.5 && < 0.8++  Exposed-modules:  Network.Salvia+                    Network.Salvia.Interface+                    Network.Salvia.Handlers+                    Network.Salvia.Impl++                    Network.Salvia.Impl.Config+                    Network.Salvia.Impl.Context+                    Network.Salvia.Impl.Handler+                    Network.Salvia.Impl.Server++                    Network.Salvia.Handler.Banner+                    Network.Salvia.Handler.Body+                    Network.Salvia.Handler.CGI+                    Network.Salvia.Handler.Close+                    Network.Salvia.Handler.Cookie+                    Network.Salvia.Handler.Directory+                    Network.Salvia.Handler.Dispatching+                    Network.Salvia.Handler.Environment+                    Network.Salvia.Handler.Error+                    Network.Salvia.Handler.Extension+                    Network.Salvia.Handler.File+                    Network.Salvia.Handler.FileSystem+                    Network.Salvia.Handler.Head+                    Network.Salvia.Handler.Log+                    Network.Salvia.Handler.Method+                    Network.Salvia.Handler.Parser+                    Network.Salvia.Handler.Path+                    Network.Salvia.Handler.Printer+                    Network.Salvia.Handler.Put+                    Network.Salvia.Handler.Range+                    Network.Salvia.Handler.Redirect+                    Network.Salvia.Handler.Rewrite+                    Network.Salvia.Handler.VirtualHosting
− src/Demo.hs 
@@ -1,21 +0,0 @@-module Demo where--import Network.Socket-import Network.Salvia.Httpd-import Network.Salvia.Handlers---- Serve the current directory.--main :: IO ()-main = do-  conf <- defaultConfig-  addr <- inet_addr "127.0.0.1"-  start -    (conf { listenAddr = addr, listenPort = 8080 })-    (hDefaultEnv myHandler)---- Serve the current directory.--myHandler :: Handler ()-myHandler = hFileSystem "."-
− src/Misc/Misc.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--module Misc.Misc (-    eitherToMaybe-  , bool-  , pMaybe-  , (@@)-  , safeLast-  , guardMaybe-  , ifM-  , split-  , withReverse-  , intersperseS-  , trim-  , normalCase-  , safeRead-  , now-  , later-  , safeHead-  , atomModTVar-  , atomReadTVar-  , atomWithTVar-  ) where--import Control.Applicative -import Control.Concurrent.STM-import Control.Monad-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---- 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 
@@ -1,211 +0,0 @@-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 
@@ -1,176 +0,0 @@-{- |-For more information: http://www.ietf.org/rfc/rfc2109.txt--}--module Network.Protocol.Cookie (-    Cookie (..)-  , empty--  , Cookies-  , cookies-  , cookie-  , showCookies--  , parseCookies-  ) where--import Control.Applicative hiding (empty)-import Control.Monad ()-import Data.Char (toLower)-import Data.List (intercalate)-import Misc.Misc (intersperseS, (@@), trim)-import Network.Protocol.Uri (URI)-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))-import qualified Data.Map as M---{- |-The `Cookie` data type containg one key/value pair with all the (potentially-optional) meta-data.--}--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 collection of multiple cookies. These can all be set in one single HTTP-/Set-Cookie/ header field.--}--type Cookies = M.Map String Cookie--{- |-Convert a list of cookies into a cookie mapping. The name will be used as the-key, the cookie itself as the value.--}--cookies :: [Cookie] -> Cookies-cookies = M.fromList . map (\a -> (name a, a))--{- | Case-insensitive way of getting a cookie out of a collection by name. -}--cookie :: String -> Cookies -> Maybe Cookie-cookie n = M.lookup (map toLower n)---------[ 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 ]---------------------------------------------------------{- |-Parse a set of cookie values and turn this into a collection of real cookies.-As the specification states, only the name, value, domain, path and port will-be recognized.--}--parseCookies :: String -> Maybe Cookies-parseCookies = fmap cookies . (pCookie @@)--pCookie :: GenParser Char st [Cookie]-pCookie = map ck <$> pCookieValues-  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 
@@ -1,73 +0,0 @@-module Network.Protocol.Http(--  -- * HTTP message data types.--    Method (..)-  , methods-  , Version (Version)-  , HeaderKey-  , HeaderValue-  , Headers-  , Direction (Request, Response)-  , Message (Message)--  -- * Creating (parts of) messages.--  , emptyRequest-  , emptyResponse-  , http10-  , http11--  -- * Accessing fields.--  , major-  , minor-  , body-  , headers-  , version-  , direction-  , method-  , uri-  , status--  -- * Accessing specific header fields.--  , normalizeHeader-  , header--  , utf8--  , connection-  , contentLength-  , contentType-  , cookie-  , date-  , hostname-  , keepAlive-  , location-  , server--  -- * Parsing HTTP messages.--  , parseRequest-  , parseResponse--  -- * Printing HTTP messages.--  , showMessageHeader--  -- * Handling HTTP status codes.--  , Status (..)-  , statusCodes-  , statusFailure-  , statusFromCode-  , codeFromStatus--  ) where--import Network.Protocol.Http.Data-import Network.Protocol.Http.Parser-import Network.Protocol.Http.Printer-import Network.Protocol.Http.Status-
− src/Network/Protocol/Http/Data.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Network.Protocol.Http.Data where--import Data.List (intercalate)-import Data.Map (lookup, insert, Map, empty)-import Data.Record.Label-import Misc.Misc (safeRead, normalCase, split)-import Network.Protocol.Http.Status (Status (..))-import Network.Protocol.Uri-import Prelude hiding (lookup)--{- | List of HTTP request methods. -}--data Method =-    OPTIONS-  | GET-  | HEAD-  | POST-  | PUT-  | DELETE-  | TRACE-  | CONNECT-  deriving (Show, Eq)--{- | All `Method` constructors as a list. -}--methods :: [Method]-methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]--{- | HTTP protocol version. -}--data Version = Version {_major :: Int, _minor :: Int}--{- | Create HTTP 1.0 version. -}--http10 :: Version-http10 = Version 1 0--{- | Create HTTP 1.1 version. -}--http11 :: Version-http11 = Version 1 1--type HeaderKey   = String-type HeaderValue = String--{- | HTTP headers as mapping from keys to values. -}--type Headers     = Map HeaderKey HeaderValue--{- | Request or response specific part of HTTP messages. -}--data Direction =-    Request  {__method :: Method, __uri :: URI}-  | Response {__status :: Status}--{- | An HTTP message. -}--data Message =-  Message {-    _direction :: Direction-  , _version   :: Version-  , _headers   :: Headers-  , _body      :: String-  }--{- | Create an empty HTTP request object. -}--emptyRequest :: Message-emptyRequest = Message (Request GET (mkURI)) http11 empty ""--{- | Create an empty HTTP response object. -}--emptyResponse :: Message-emptyResponse = Message (Response OK) http11 empty ""--$(mkLabels [''Version, ''Direction, ''Message])--{- | Label to access the major part of the version. -}--major :: Label Version Int--{- | Label to access the minor part of the version. -}--minor :: Label Version Int--_status   :: Label Direction Status-_uri      :: Label Direction URI-_method   :: Label Direction Method--{- | Label to access the body part of an HTTP message. -}--body :: Label Message String--{- | Label to access the header of an HTTP message. -}--headers :: Label Message Headers--{- | Label to access the version part of an HTTP message. -}--version :: Label Message Version--{- | Label to access the direction part of an HTTP message. -}--direction :: Label Message Direction--{- | Label to access the method part of an HTTP message. -}--method :: Label Message Method-method = _method % direction--{- | Label to access the URI part of an HTTP message. -}--uri :: Label Message URI-uri = _uri % direction--{- | Label to access the status part of an HTTP message. -}--status :: Label Message Status-status = _status % direction------{- | Normalize the capitalization of an HTTP header key. -}--normalizeHeader :: String -> String-normalizeHeader = (intercalate "-") . (map normalCase) . (split '-')--{- | Generic label to access an HTTP header field by key. -}--header :: HeaderKey -> Label Message HeaderValue-header key =-  Label {-    lget = maybe "" id . lookup (normalizeHeader key) . lget headers-  , lset = lmod headers . insert (normalizeHeader key)-  }--{- | Simply /utf-8/. -}--utf8 :: String-utf8 = "utf-8"--{- | Access the /Content-Length/ header field. -}--contentLength :: (Read i, Integral i) => Label Message (Maybe i)-contentLength = comp safeRead (maybe "" show) (header "Content-Length")--{- | Access the /Connection/ header field. -}--connection :: Label Message String-connection = header "Connection"--{- | Access the /Keep-Alive/ header field. -}--keepAlive :: (Read i, Integral i) => Label Message (Maybe i)-keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")--{- | Access the /Cookie/ and /Set-Cookie/ header fields. -}--cookie :: Label Message String-cookie = Label (lget $ header "Cookie") (lset $ header "Set-Cookie")--{- | Access the /Location/ header field. -}--location :: Label Message (Maybe URI)-location = Label-  (parseURI . lget (header "Location"))-  (lset (header "Location") . maybe "" show)--{- | Access the /Content-Type/ header field. -}--contentType :: Label Message (String, Maybe String)-contentType = comp pa pr (header "Content-Type")-  where pr (t, c) = t ++ maybe "" ("; charset="++) c-        pa = error "no getter for contentType yet"--{- | Access the /Data/ header field. -}--date :: Label Message String-date = header "Date"--{- | Access the /Host/ header field. -}--hostname :: Label Message (Maybe Authority)-hostname = Label-  (parseAuthority . lget (header "Host"))-  (lset (header "Host") . maybe "" show)--{- | Access the /Server/ header field. -}--server :: Label Message String-server = header "Server"-
− src/Network/Protocol/Http/Parser.hs 
@@ -1,63 +0,0 @@-module Network.Protocol.Http.Parser (-    parseRequest-  , parseResponse-  ) where--import Control.Applicative hiding (empty)-import Data.Char (ord)-import Data.List (intercalate)-import Data.Map (insert, empty)-import Misc.Misc (pMaybe)-import Network.Protocol.Http.Data-import Network.Protocol.Http.Status-import Network.Protocol.Uri (pUriReference)-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))--{- | Parse a string as an HTTP request message. -}--parseRequest :: String -> Either ParseError Message-parseRequest msg = parse pRequest  "" msg--{- | Parse a string as an HTTP request message. -}--parseResponse :: String -> Either ParseError Message-parseResponse msg = parse pResponse "" msg--lf, ws, ls :: String-lf = "\r\n"-ws = " \t\r\n"-ls = " \t"--pLf :: GenParser Char st Char-pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'--pVersion :: GenParser Char st Version-pVersion = -      (\h l -> Version (ord h - ord '0') (ord l  - ord '0'))-  <$> (string "HTTP/" *> digit)-  <*> (char '.'       *> digit)--pHeaders :: GenParser Char st Headers-pHeaders = insert-  <$> many1 (noneOf (':':ws)) <* string ":"-  <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))-  <*> option empty pHeaders--pMethod :: GenParser Char st Method-pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods--pRequest :: GenParser Char st Message-pRequest = (\m u v h b -> Message (Request m u) v h b)-  <$> (pMethod <* many1 (oneOf ls))-  <*> (pUriReference <* many1 (oneOf ls))-  <*> (pVersion <* pLf)-  <*> (pHeaders <* pLf)-  <*> (many anyToken)--pResponse :: GenParser Char st Message-pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)-  <$> (pVersion <* many1 (oneOf ls))-  <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)-  <*> (pHeaders <* pLf)-  <*> (many anyToken)-
− src/Network/Protocol/Http/Printer.hs 
@@ -1,41 +0,0 @@-{- | Provides the `Show` instance for an HTTP `Message`. -}--module Network.Protocol.Http.Printer (showMessageHeader) where--import Data.Bimap (lookupR)-import Data.List (intercalate)-import Data.Map (elems, mapWithKey)-import Data.Record.Label (lget)-import Network.Protocol.Http.Data-import Network.Protocol.Http.Status--lf :: String-lf = "\r\n"--instance Show Version where-  show (Version a b) = concat ["HTTP/", show a, ".", show b]--showHeaders :: Headers -> String-showHeaders =-    intercalate lf-  . elems-  . mapWithKey (\k a -> k ++ ": " ++ a)--{- | Helper function that only prints the header part of an HTTP message. -}--showMessageHeader :: Message -> String-showMessageHeader (Message (Response s) v hs _) =-  concat [-    show v, " "-  , maybe "Unknown status" show-  $ lookupR s statusCodes, " "-  , show s, lf-  , showHeaders hs, lf, lf-  ]--showMessageHeader (Message (Request m u) v hs _) =-  concat [show m, " ", show u, " ", show v, lf, showHeaders hs, lf, lf]--instance Show Message where-  show m = concat [showMessageHeader m, lget body m]-
− src/Network/Protocol/Http/Status.hs 
@@ -1,163 +0,0 @@-module Network.Protocol.Http.Status where--import Data.Bimap (Bimap, fromList, lookup, lookupR)-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--{- | HTTP status codes. -}--data Status =-    Continue                     -- ^ 100-  | SwitchingProtocols           -- ^ 101-  | OK                           -- ^ 200-  | Created                      -- ^ 201-  | Accepted                     -- ^ 202-  | NonAuthoritativeInformation  -- ^ 203-  | NoContent                    -- ^ 204-  | ResetContent                 -- ^ 205-  | PartialContent               -- ^ 206-  | MultipleChoices              -- ^ 300-  | MovedPermanently             -- ^ 301-  | Found                        -- ^ 302-  | SeeOther                     -- ^ 303-  | NotModified                  -- ^ 304-  | UseProxy                     -- ^ 305-  | TemporaryRedirect            -- ^ 307-  | BadRequest                   -- ^ 400-  | Unauthorized                 -- ^ 401-  | PaymentRequired              -- ^ 402-  | Forbidden                    -- ^ 403-  | NotFound                     -- ^ 404-  | MethodNotAllowed             -- ^ 405-  | NotAcceptable                -- ^ 406-  | ProxyAuthenticationRequired  -- ^ 407-  | RequestTimeOut               -- ^ 408-  | Conflict                     -- ^ 409-  | Gone                         -- ^ 410-  | LengthRequired               -- ^ 411-  | PreconditionFailed           -- ^ 412-  | RequestEntityTooLarge        -- ^ 413-  | RequestURITooLarge           -- ^ 414-  | UnsupportedMediaType         -- ^ 415-  | RequestedRangeNotSatisfiable -- ^ 416-  | ExpectationFailed            -- ^ 417-  | InternalServerError          -- ^ 500-  | NotImplemented               -- ^ 501-  | BadGateway                   -- ^ 502-  | ServiceUnavailable           -- ^ 503-  | GatewayTimeOut               -- ^ 504-  | HTTPVersionNotSupported      -- ^ 505-  | CustomStatus Int-  deriving (Eq, Ord)--{- | rfc2616 sec6.1.1 Status Code and Reason Phrase. -}--instance Show Status where-  show Continue                     = "Continue"-  show SwitchingProtocols           = "Switching Protocols"-  show OK                           = "OK"-  show Created                      = "Created"-  show Accepted                     = "Accepted"-  show NonAuthoritativeInformation  = "Non-Authoritative Information"-  show NoContent                    = "No Content"-  show ResetContent                 = "Reset Content"-  show PartialContent               = "Partial Content"-  show MultipleChoices              = "Multiple Choices"-  show MovedPermanently             = "Moved Permanently"-  show Found                        = "Found"-  show SeeOther                     = "See Other"-  show NotModified                  = "Not Modified"-  show UseProxy                     = "Use Proxy"-  show TemporaryRedirect            = "Temporary Redirect"-  show BadRequest                   = "Bad Request"-  show Unauthorized                 = "Unauthorized"-  show PaymentRequired              = "Payment Required"-  show Forbidden                    = "Forbidden"-  show NotFound                     = "Not Found"-  show MethodNotAllowed             = "Method Not Allowed"-  show NotAcceptable                = "Not Acceptable"-  show ProxyAuthenticationRequired  = "Proxy Authentication Required"-  show RequestTimeOut               = "Request Time-out"-  show Conflict                     = "Conflict"-  show Gone                         = "Gone"-  show LengthRequired               = "Length Required"-  show PreconditionFailed           = "Precondition Failed"-  show RequestEntityTooLarge        = "Request Entity Too Large"-  show RequestURITooLarge           = "Request-URI Too Large"-  show UnsupportedMediaType         = "Unsupported Media Type"-  show RequestedRangeNotSatisfiable = "Requested range not satisfiable"-  show ExpectationFailed            = "Expectation Failed"-  show InternalServerError          = "Internal Server Error"-  show NotImplemented               = "Not Implemented"-  show BadGateway                   = "Bad Gateway"-  show ServiceUnavailable           = "Service Unavailable"-  show GatewayTimeOut               = "Gateway Time-out"-  show HTTPVersionNotSupported      = "HTTP Version not supported"-  show (CustomStatus _)             = "Unknown Status"--{- |-RFC2616 sec6.1.1 Status Code and Reason Phrase.--Bidirectional mapping from status numbers to codes.--}--statusCodes :: Bimap Int Status-statusCodes = fromList [-    (100, Continue)-  , (101, SwitchingProtocols)-  , (200, OK)-  , (201, Created)-  , (202, Accepted)-  , (203, NonAuthoritativeInformation)-  , (204, NoContent)-  , (205, ResetContent)-  , (206, PartialContent)-  , (300, MultipleChoices)-  , (301, MovedPermanently)-  , (302, Found)-  , (303, SeeOther)-  , (304, NotModified)-  , (305, UseProxy)-  , (307, TemporaryRedirect)-  , (400, BadRequest)-  , (401, Unauthorized)-  , (402, PaymentRequired)-  , (403, Forbidden)-  , (404, NotFound)-  , (405, MethodNotAllowed)-  , (406, NotAcceptable)-  , (407, ProxyAuthenticationRequired)-  , (408, RequestTimeOut)-  , (409, Conflict)-  , (410, Gone)-  , (411, LengthRequired)-  , (412, PreconditionFailed)-  , (413, RequestEntityTooLarge)-  , (414, RequestURITooLarge)-  , (415, UnsupportedMediaType)-  , (416, RequestedRangeNotSatisfiable)-  , (417, ExpectationFailed)-  , (500, InternalServerError)-  , (501, NotImplemented)-  , (502, BadGateway)-  , (503, ServiceUnavailable)-  , (504, GatewayTimeOut)-  , (505, HTTPVersionNotSupported)-  ]---- | Every status greater-than or equal to 400 is considered to be a failure.-statusFailure :: Status -> Bool-statusFailure st = codeFromStatus st >= 400---- | Conversion from status numbers to codes.-statusFromCode :: Int -> Status-statusFromCode num =-    fromMaybe (CustomStatus num)-  $ lookup num statusCodes---- | Conversion from status codes to numbers.-codeFromStatus :: Status -> Int-codeFromStatus st =-    fromMaybe 0 -- function is total, should not happen.-  $ lookupR st statusCodes-
− src/Network/Protocol/Mime.hs 
@@ -1,662 +0,0 @@-{- |-Handling mime types. This module contains a mapping from file extensions to-mime-types taken from the Apache webserver project.--}--module Network.Protocol.Mime where--import Data.Map--{- | Get the mimetype for the specified extension. -}--mime :: String -> Maybe String-mime ext = Data.Map.lookup ext extensionToMime--{- | The default mimetype is /text/plain/. -}--defaultMime :: String-defaultMime = "text/plain"--{- | The mapping from extension to mimetype. -}--extensionToMime :: Map String String-extensionToMime = fromList [-    ("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 
@@ -1,622 +0,0 @@-{- | See rfc2396 for more info. -}--{-# LANGUAGE TemplateHaskell #-}-module Network.Protocol.Uri (--    Scheme-  , IPv4-  , Domain-  , RegName-  , Port-  , Query-  , Fragment-  , Hash-  , UserInfo-  , PathSegment-  , Parameters-  , Path-  , Host-  , Authority-  , URI--  -- * Creating (parts of) URIs.--  , encode-  , decode--  , mkURI-  , mkScheme-  , mkPath-  , mkAuthority-  , mkQuery-  , mkFragment-  , mkUserinfo-  , mkHost-  , mkPort--  -- * Accessing parts of URIs.--  , domain-  , regname-  , ipv4-  , userinfo-  , host-  , port-  , relative-  , scheme-  , authority-  , path-  , query-  , fragment--  -- * Helper labels.--  , absolute-  , segments-  , _host-  , _port--  -- * Parsing URIs.--  , parseURI-  , parseAbsoluteURI-  , parseAuthority-  , parsePath-  , parseHost--  , pUriReference-  , pAbsoluteURI---   , pAuthority---   , pPath---   , pHost--  -- * Handling query parameters.--  , parseQueryParams-  , queryParams--  -- * Filename related utilities.--  , extension--  , mkPathRelative-  , mimetype-  , normalize-  , jail-  , (/+)--  ) where--import Control.Applicative-import Data.Bits-import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit, toLower)-import Data.List (intercalate, isPrefixOf)-import Data.Maybe (mapMaybe, fromJust)-import Data.Record.Label-import Misc.Misc (eitherToMaybe, (@@), bool, pMaybe, split)-import Network.Protocol.Mime-import System.FilePath.Posix-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))---------[ data type definition of URIs ]------------------------------------------type Scheme      = String-type IPv4        = [Int] -- actually 4-tupel-type Domain      = [String]-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, Ord)--data Host =-    Hostname { __domain  :: Domain }-  | RegName  { __regname :: String }-  | IPv4     { __ipv4    :: IPv4   }-  deriving (Eq, Ord)--data Authority = Authority {-    __userinfo :: UserInfo-  , __host     :: Host-  , __port     :: Port-  }-  deriving (Eq, Ord)--data URI = URI {-    _relative  :: Bool-  , _scheme    :: Scheme-  , _authority :: Authority-  , __path     :: Path-  , __query     :: Query-  , _fragment  :: Fragment-  }-  deriving (Eq, Ord)--$(mkLabels [''Path, ''Host, ''Authority, ''URI])--_domain   :: Label Host Domain-_host     :: Label Authority Host-_ipv4     :: Label Host IPv4-_path     :: Label URI Path-_port     :: Label Authority Port-_query    :: Label URI Query-_regname  :: Label Host String-_userinfo :: Label Authority UserInfo-absolute  :: Label Path Bool-authority :: Label URI Authority-domain    :: Label URI Domain-fragment  :: Label URI Fragment-host      :: Label URI String-ipv4      :: Label URI IPv4-path      :: Label URI FilePath-port      :: Label URI Port-query     :: Label URI Query-regname   :: Label URI String-relative  :: Label URI Bool-scheme    :: Label URI Scheme-segments  :: Label Path [PathSegment]-userinfo  :: Label URI UserInfo---- Public label based on private labels.--domain    = _domain   % _host % authority-regname   = _regname  % _host % authority-ipv4      = _ipv4     % _host % authority-userinfo  = _userinfo % authority-port      = _port     % authority--query = Label-  (decode . lget _query)-  (lset _query . encode)--host = Label-  (show . lget (_host % authority))-  (lset (_host % authority) . maybe (Hostname []) id . parseHost)--path = Label-  (decode . show . lget _path)-  (lset _path . maybe (Path True []) id . parsePath . encode)---------[ creating, selection and modifying URIs ]--------------------------------{- | Constructors for making empty URI. -}--mkURI :: URI-mkURI = URI False mkScheme mkAuthority mkPath mkQuery mkFragment--{- | Constructors for making empty `Scheme`. -}--mkScheme :: Scheme-mkScheme = ""--{- | Constructors for making empty `Path`. -}--mkPath :: Path-mkPath = Path False []--{- | Constructors for making empty `Authority`. -}--mkAuthority :: Authority-mkAuthority = Authority "" mkHost mkPort--{- | Constructors for making empty `Query`. -}--mkQuery :: Query-mkQuery = ""--{- | Constructors for making empty `Fragment`. -}--mkFragment :: Fragment-mkFragment = ""--{- | Constructors for making empty `UserInfo`. -}--mkUserinfo :: UserInfo-mkUserinfo = ""--{- | Constructors for making empty `Host`. -}--mkHost :: Host-mkHost = Hostname []--{- | Constructors for making empty `Port`. -}--mkPort :: Port-mkPort = (-1)---------[ path encoding and decoding ]--------------------------------------------{- | URI encode a string. -}--encode :: String -> String-encode = concatMap encodeChr-  where-    encodeChr c-      | unreserved c || genDelims c || subDelims c = [c]-      | otherwise = '%' :-          intToDigit (shiftR (ord c) 4) :-          intToDigit ((ord c) .&. 0x0F) : []--{- | URI decode a string. -}--decode :: String -> String-decode [] = []-decode ('%':d:e:ds) | isHexDigit d && isHexDigit e = (chr $ digs d * 16 + digs e) : decode ds -  where digs a = fromJust $ lookup (toLower a) $ zip "0123456789abcdef" [0..]-decode (d:ds) = d : decode ds---------[ show instance for URIs ]-------------------------------------------------- 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 ]--------------------------------------------{- | Parse string into a `URI`. -}--parseURI :: String -> Maybe URI-parseURI = eitherToMaybe . parse pUriReference ""--{- | Parse string into a `URI` and only accept absolute URIs. -}--parseAbsoluteURI :: String -> Maybe URI-parseAbsoluteURI = eitherToMaybe . parse pAbsoluteURI ""--{- | Parse string into a `Authority` object. -}--parseAuthority :: String -> Maybe Authority-parseAuthority = eitherToMaybe . parse pAuthority ""--{- | Parse string into a `Path`. -}--parsePath :: String -> Maybe Path-parsePath = eitherToMaybe . parse pPath ""--{- | Parse string into a `Host`. -}--parseHost :: String -> Maybe Host-parseHost = eitherToMaybe . parse pHost ""---------[ 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 String-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 String-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 ]----------------------------------------------pQueryParams :: GenParser Char st Parameters-pQueryParams = -      filter (not . null . fst)-  <$> sepBy ((,)-  <$> many (noneOf "=&")-  <*> pMaybe (char '='-   *> (translateParam <$> many (noneOf "&"))))-      (char '&')--{- | Parse a pre-decoded query string into key value pairs parameters. -}--parseQueryParams :: String -> Maybe Parameters-parseQueryParams = eitherToMaybe . parse pQueryParams  ""--{- | Fetch the query parameters form a URI. -}--queryParams :: URI -> Parameters-queryParams = maybe [] id . parseQueryParams . lget query---- Translate special characters in a parameter.-translateParam :: String -> String-translateParam []       = []-translateParam ('+':xs) = ' ' : translateParam xs-translateParam (x:xs)   = x   : translateParam xs---------[ filename path utilities ]-----------------------------------------------{- | Label to access the extension of a filename. -}--extension :: Label FilePath (Maybe String)-extension = Label {lget = getExt, lset = setExt}-  where-    splt     p = (\(a,b) -> (reverse a, reverse b)) $ break (=='.') $ reverse p-    isExt e  p = '/' `elem` e || not ('.' `elem` p)-    getExt   p = let (u, v) = splt p in-                 if isExt u v then Nothing else Just u-    setExt e p = let (u, v) = splt p in-                 (if isExt u v then p else init v) ++ maybe "" ('.':) e--{- |-Try to guess the correct mime type for the input file based on the file-extension.--}--mimetype :: FilePath -> Maybe String-mimetype p = lget extension p >>= mime--{- |-Normalize a path by removing or merging all dot or dot-dot segments and double-slashes. --}---- Todo: cleanup, remove fixp.--normalize :: FilePath -> FilePath-normalize [] = []-normalize p = fixAbs absolut $ intercalate "/" $ norm-  where-    fixAbs True          = ('/':)-    fixAbs False         = id-    absolut              = 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--{- | Make a path relative by removing the first slash when there is one. -}--mkPathRelative :: FilePath -> FilePath-mkPathRelative = dropWhile (=='/')--{- | Jail a filepath within a jail directory. -}--jail-  :: FilePath         -- ^ Jail directory.-  -> FilePath         -- ^ Filename to jail.-  -> Maybe FilePath-jail jailDir p =-  let nj = normalize jailDir-      np = normalize p in-  if nj `isPrefixOf` np -- && not (".." `isPrefixOf` np)-    then Just np-    else Nothing--{- | Concatenate and normalize two filepaths. -}--(/+) :: FilePath -> FilePath -> FilePath-a /+ b = normalize (a ++ "/" ++ b)-
+ src/Network/Salvia.hs view
@@ -0,0 +1,10 @@+module Network.Salvia+( module Network.Salvia.Interface+, module Network.Salvia.Handlers+, module Network.Salvia.Impl+)+where++import Network.Salvia.Interface+import Network.Salvia.Handlers+import Network.Salvia.Impl
− src/Network/Salvia/Core/Config.hs 
@@ -1,44 +0,0 @@-module Network.Salvia.Core.Config (-    HttpdConfig (..)-  , defaultConfig-  ) where--import Network.Socket hiding (send, listen)-import System.IO--{- |-The HTTP server configuration specifies some important network settings the-server must know before being able to run. Most fields speak for themselves.--}--data HttpdConfig =-   HttpdConfig {-     hostname   :: String       -- ^ Server hostname.-   , email      :: String       -- ^ Server admin email address.-   , listenAddr :: HostAddress  -- ^ Addres to bind to.-   , listenPort :: PortNumber   -- ^ Port to listen on.-   , backlog    :: Int          -- ^ TCP backlog.-   , bufferSize :: Int          -- ^ Serve chunck with size.-   }--{- |-The default server configuration sets some safe default values. The server will-by default bind to 0.0.0.0 at port 80. The default value for the TCP backlog is-4, the default socket buffer size is 64KB. This function has to be in IO-because of the translation from a `String` to a `HostAddress` using-`inet_addr`.--}--defaultConfig :: IO HttpdConfig-defaultConfig = do-  addr <- inet_addr "0.0.0.0"-  return-    $ HttpdConfig {-      hostname   = "hostname"-    , email      = "admin@localhost"-    , listenAddr = addr-    , listenPort = 80-    , backlog    = 4-    , bufferSize = 64 * 1024-    }-
− src/Network/Salvia/Core/Context.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}-module Network.Salvia.Core.Context (-    SendAction-  , SendQueue-  , Context--  , config-  , request-  , response-  , sock-  , address-  , queue--  , mkContext-  ) where--import Data.Record.Label-import Network.Protocol.Http (Message, emptyRequest, emptyResponse)-import Network.Salvia.Core.Config-import Network.Socket (SockAddr)-import System.IO---------- single request/response context ------------------------------------------ | A send action is some thing that works on an IO handle.-type SendAction = Handle -> IO ()--{- |-The send queue is an abstraction to make sure all data that belongs to the-message body is sent after the response headers have been sent.  Instead of-sending data to client directly over the socket from the context it is-preferable to queue send actions in the context's send queue. The entire send-queue can be flushed to the client at once after the HTTP headers have been-sent at the end of a request handler.--}--type SendQueue  = [SendAction]--{- |-A handler context contains all the information needed by the request handlers-to perform their task and to set up a proper response. All the fields in the-context are accessible using the read/write labels defined below.--}--data Context =-  Context {-    _config   :: HttpdConfig -- ^ The HTTP server configuration.-  , _request  :: Message     -- ^ The HTTP request header.-  , _response :: Message     -- ^ The HTTP response header.-  , _sock     :: Handle      -- ^ The socket handle for the connection with the client.-  , _address  :: SockAddr    -- ^ The client addres.-  , _queue    :: SendQueue   -- ^ The queue of send actions.-  }--$(mkLabels [''Context])--{- | The queue containing all send actions. -}-queue :: Label Context SendQueue--{- | The client address.  -}-address  :: Label Context SockAddr--{- | The socket to the client. -}-sock :: Label Context Handle--{- |-The server response. Using the appropriate handler the response can be sent to-the client after processing the request.--}--response :: Label Context Message--{- |-The client request. This request is initially empty and only available after-the message has been parsed by the appropriate handler.--}--request :: Label Context Message--{- |-The global server configuration. Modifying this has no effect on consecutive-requests.--}--config :: Label Context HttpdConfig--{- |-Create and default server context with the specified server configuration,-client address and socket.--}--mkContext :: HttpdConfig -> SockAddr -> Handle -> Context-mkContext c a s = Context {-    _config   = c-  , _request  = emptyRequest-  , _response = emptyResponse  -- 200 OK, by default.-  , _sock     = s-  , _address  = a-  , _queue    = []-  }-
− src/Network/Salvia/Core/Handler.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}--module Network.Salvia.Core.Handler (-    Handler-  , ResourceHandler-  , UriHandler-  ) where--import Control.Applicative (Applicative, pure, (<*>))-import Control.Monad.State (StateT, ap)-import Network.Protocol.Uri (URI)-import Network.Salvia.Core.Context-import System.IO--{- |-A HTTP request handler lives in `IO` and carries a server context in the-`State` monad. This module also provides an `Applicative` instance for `StateT`-`Context` `IO`.--}--type Handler a = StateT Context IO a--{- | A resource handler is something that works on some filesystem resource. -}--type ResourceHandler a = FilePath -> Handler a--{- | A URI handler is something that works on an request URI. -}--type UriHandler a = URI -> Handler a---- Make handlers applicative.-instance Applicative (StateT Context IO) where-  pure  = return-  (<*>) = ap-
− src/Network/Salvia/Core/IO.hs 
@@ -1,161 +0,0 @@-{-|-This module contains some useful functions for IO over the client socket. Some-functions directly work on the socket and some queue actions into the send-queue. The latter form is more high-level and recommended for common use. This-module is likely to be extended in the future with other useful function that-handle specific message IO.--}--module Network.Salvia.Core.IO (--  -- * Queing send actions to the send queue.-    send-  , sendStr-  , sendStrLn-  , sendBs--  -- * Queing spool actions to the send queue.-  , spool-  , spoolBs--  -- * Send actions directly using the socket.-  , flushHeaders-  , flushQueue--  -- * Directly manipulate the send queue.-  , emptyQueue-  , reset--  -- * Reading data from the client request.-  , contents-  , contentsUtf8-  , uriEncodedPostParamsUTF8--  ) where---- TODO: we are mixing two encoding libs. fix.--import Control.Monad.State-import Data.Encoding (decodeLazyByteString)-import Data.Encoding.UTF8-import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Uri (Parameters, parseQueryParams, decode)-import Network.Salvia.Core.Context-import Network.Salvia.Core.Handler-import System.IO-import qualified Data.ByteString.Lazy as B-import qualified System.IO.UTF8 as U-----------------------------------------------------------------------------------{- |-Queue one potential send action in the send queue. This will not (yet) be sent-over the socket.--}--send :: SendAction -> Handler ()-send f = modM queue (++[f])--{- | Queue the action of sending one UTF-8 encoded `String` over the socket. -}--sendStr :: String -> Handler ()-sendStr s = send (flip U.hPutStr s)--{- |-Queue the action of sending one UTF-8 encoded `String` with extra linefeed-over the socket.--}--sendStrLn :: String -> Handler ()-sendStrLn s = send (flip U.hPutStr (s ++ "\n"))--{- | Queue the action of sending one lazy `B.ByteString` over the socket. -}--sendBs :: B.ByteString -> Handler ()-sendBs bs = send (flip B.hPutStr bs)--{- |-Queue spooling the entire contents of a stream to the socket using a UTF-8-encoded `String` based filter.--}--spool :: (String -> String) -> Handle -> Handler ()-spool f fd = send (\s -> U.hGetContents fd >>= \d -> U.hPutStr s (f d))--{- |-Queue spooling the entire contents of a stream to the socket using a-`B.ByteString` based filter.--}--spoolBs :: (B.ByteString -> B.ByteString) -> Handle -> Handler ()-spoolBs f fd = send (\s -> B.hGetContents fd >>= \d -> B.hPut s (f d))--{- | Send all the response headers directly over the socket. -}--flushHeaders :: Handler ()-flushHeaders = do-  r <- getM response-  s <- getM sock -  lift $ hPutStr s (showMessageHeader r)--{- | Apply all send actions successively to the client socket. -}--flushQueue :: Handler ()-flushQueue =-  do h <- getM sock-     q <- getM queue-     liftIO $-       do mapM_ ($ h) q-          hFlush h--{- | Reset the send queue by throwing away all potential send actions. -}--emptyQueue :: Handler ()-emptyQueue = setM queue []--{- | Reset both the send queue and the generated server response. -}--reset :: Handler ()-reset = do-  setM response emptyResponse-  emptyQueue--{- |-First (possibly naive) handler to retreive the client request body as a-`B.ByteString`. This probably does not handle all the quirks that the HTTP-protocol specifies, but it does the job for now. When a 'contentLength' header-field is available only this fixed number of bytes will read from the socket.-When neither the 'keepAlive' and 'contentLength' header fields are available-the entire payload of the request will be read from the socket. This method is-probably only useful in the case of 'PUT' request, because no decoding of-'POST' data is handled.--}--contents :: Handler (Maybe B.ByteString)-contents = do-  len <- getM (contentLength % request)-  kpa <- getM (keepAlive     % request)-  s   <- getM sock-  lift $-    case (kpa::Maybe Integer, len::Maybe Integer) of-      (_,       Just n)  -> liftM Just (B.hGet s (fromIntegral n))-      (Nothing, Nothing) -> liftM Just (B.hGetContents s)-      _                  -> return Nothing--{- |-Like the `contents' function but decodes the data as UTF-8. Soon, time will-come that decoding will be based upon the requested encoding.--}--contentsUtf8 :: Handler (Maybe String)-contentsUtf8 = (fmap $ decodeLazyByteString UTF8) `liftM` contents--{- |-Try to parse the supplied request body as URI encoded `POST` parameters in-UTF-8 encoding. Returns as a URI parameter type or nothing when parsing fails.--}--uriEncodedPostParamsUTF8 :: Handler (Maybe Parameters)-uriEncodedPostParamsUTF8 = liftM (>>= parseQueryParams . decode) contentsUtf8-
− src/Network/Salvia/Core/Main.hs 
@@ -1,59 +0,0 @@-module Network.Salvia.Core.Main (start) where--import Control.Concurrent (forkIO)-import Control.Monad.State-import Network.Salvia.Core.Config (listenAddr, listenPort, backlog, HttpdConfig)-import Network.Salvia.Core.Context (mkContext)-import Network.Salvia.Core.Handler (Handler)-import Network.Socket-import System.IO---------- HTTP deamon implementation ---------------------------------------------{- |-Start a webserver with a specific server configuration and default handler. The-server will go into an infinite loop and will repeatedly accept client-connections on the address and port specified in the configuration. For every-connection the specified handler will be executed with the client address and-socket stored in the handler context.--}--start :: HttpdConfig -> Handler () -> IO ()-start config httpHandler =-  server-    (listenAddr config)-    (listenPort config)-    (backlog config)-    tcpHandler-  where-    tcpHandler handle addr = -      fst `liftM` runStateT httpHandler-        (mkContext config addr handle)--{--Start a listening TCP server on the specified address/port combination and-handle every connection with a custom handler.--}--server :: HostAddress -> PortNumber -> Int -> (Handle -> SockAddr -> IO ()) -> IO ()-server addr port blog handler = do-  sock <- socket AF_INET Stream 0-  setSocketOption sock ReuseAddr 1-  bindSocket sock $ SockAddrInet port addr-  listen sock blog-  acceptLoop sock handler--{--Accept connections on the listening socket and pass execution to the-application specific connection handler.--}--acceptLoop :: Socket -> (Handle -> SockAddr -> IO ()) -> IO ()-acceptLoop sock handler = do-  forever $ do-    (sock', addr) <- accept sock-    forkIO $-      do h <- socketToHandle sock' ReadWriteMode-         handler h addr-  putStrLn "quiting"-
src/Network/Salvia/Handler/Banner.hs view
@@ -1,28 +1,31 @@+{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Banner (hBanner) where +import Control.Applicative import Control.Monad.State import Data.Record.Label-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (formatTime)-import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime import Network.Protocol.Http-import Network.Salvia.Httpd-import System.Locale (defaultTimeLocale)+import Network.Salvia.Interface+import System.Locale  {- | The 'hBanner' handler adds the current date-/timestamp and a custom server name to the response headers. -} -hBanner ::-     String     -- ^ The HTTP server name.-  -> Handler ()-hBanner sv = do-  dt <- lift $ do-    zone <- getCurrentTimeZone-    time <- liftM (utcToLocalTime zone) getCurrentTime-    return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time-  enterM response $ do-    setM date   dt-    setM server sv+hBanner+  :: (MonadIO m, HttpM Response m)+  => String -- ^ The name to include as the /Server/ header line.+  -> m ()+hBanner sv =+  do dt <- liftIO $+       do zone <- getCurrentTimeZone+          time <- utcToLocalTime zone <$> getCurrentTime+          return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" time+     response $+       do date   =: Just dt+          server =: Just sv
+ src/Network/Salvia/Handler/Body.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables #-}+module Network.Salvia.Handler.Body+( hRawRequestBody+, hRawResponseBody+, hRawBody++, hRequestBodyText+, hResponseBodyText+, hBodyText++, hRequestBodyStringUTF8+, hResponseBodyStringUTF8+, hBodyStringUTF8++, hRequestParameters+, hResponseParameters+, hParameters+)+where++import Control.Applicative+import Control.Monad.State hiding (get)+import Data.Char+import Data.Record.Label+import Data.Text.Lazy (Text, unpack)+import Data.Text.Lazy.Encoding+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Salvia.Interface+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.UTF8 as U++-- | Lookup an Data.Text encoding function from a named identifier, currently+-- identifies "utf-8", "utf-16", "utf-32" with possible little/big endian+-- postfixes ("le", "be"). The comparision is quite fuzzy so, for example, both+-- "UTF16le" and "utf-16-LE" will be mapped to the same decoder.++encodingFromName :: String -> Maybe (B.ByteString -> Text)+encodingFromName s = k `lookup`+  [ ("utf8",    decodeUtf8)+--   , ("utf16",   decodeUtf16LE)+--   , ("utf16le", decodeUtf16LE)+--   , ("utf16be", decodeUtf16BE)+--   , ("utf32",   decodeUtf32LE)+--   , ("utf32le", decodeUtf32LE)+--   , ("utf32be", decodeUtf32BE)+  ] where k = map toLower (filter (\c -> isAlpha c || isDigit c) s)++{- |+First (possibly naive) handler to retreive the client request or server+response body as a raw lazy `B.ByteString`. This probably does not handle all+the quirks that the HTTP protocol specifies, but it does the job for now. When+a 'contentLength' header field is available only this fixed number of bytes+will read from the socket.  When neither the 'keepAlive' and 'contentLength'+header fields are available the entire payload of the request will be read from+the socket. The function is parametrized with a the direction of the HTTP+message, client request or server response.+-}++hRawBody :: forall m d. (MonadIO m, HandleM m, HttpM d m) => d -> m B.ByteString+hRawBody _ =+  do let h = http :: State (Http d) a -> m a+     con <- h (getM connection)+     kpa <- h (getM keepAlive)+     len <- h (getM contentLength)+     s   <- handle+     liftIO $+       case (con, kpa :: Maybe Integer, len :: Maybe Integer) of+         (_, _,       Just n)                           -> B.hGet s (fromIntegral n)+         (k, Nothing, Nothing) | k /= Just "keep-alive" -> B.hGetContents s+         _                                              -> return B.empty++-- | Like `hRawBody' but specifically for `Http' `Request's.++hRawRequestBody :: BodyM Request m => m B.ByteString+hRawRequestBody = body forRequest++-- | Like `hRawBody' but specifically for `Http' `Request's.++hRawResponseBody :: BodyM Response m => m B.ByteString+hRawResponseBody = body forResponse++{- |+Like the `hRawBody' but is will handle proper decoding based on the charset+part of the `contentType' header line. When a valid encoding is found in the+`Http' message it will be decoded with using the encodings package. The default+encoding supplied as the function's argument can be used to specify what+encoding to use in the absence of a proper encoding in the HTTP message itself.+-}++hBodyText :: forall m dir. (BodyM dir m, HttpM dir m) => dir -> String -> m Text+hBodyText d def = +  do let h = http :: State (Http dir) a -> m a+     c <- body d+     e <- (>>= snd) <$> h (getM contentType) :: m (Maybe String)+     return $+       case (e >>= encodingFromName, encodingFromName def) of+         (Just enc, _) -> enc c+         (_, Just enc) -> enc c+         (_, _)        -> error "hBodyText: wrong default encoding specified"++-- | Like `hBodyText' but specifically for `Http' `Request's.++hRequestBodyText :: (BodyM Request m, HttpM Request m) => String -> m Text+hRequestBodyText = hBodyText forRequest++-- | Like `hBodyText' but specifically for `Http' `Response's.++hResponseBodyText :: (BodyM Response m, HttpM Response m) => String -> m Text+hResponseBodyText = hBodyText forResponse++-- | Like the `hRawBody' but decodes it as UTF-8 to a `String'.++hBodyStringUTF8 :: BodyM dir m => dir -> m String+hBodyStringUTF8 d = U.toString <$> body d++-- | Like `hBodyStringUTF8' but specifically for `Http' `Request's.++hRequestBodyStringUTF8 :: BodyM Request m => m String+hRequestBodyStringUTF8 = hBodyStringUTF8 forRequest++-- | Like `hBodyStringUTF8' but specifically for `Http' `Response's.++hResponseBodyStringUTF8 :: BodyM Response m => m String+hResponseBodyStringUTF8 = hBodyStringUTF8 forResponse++{- |+Try to parse the message body, as a result of `hBodyText', as URI encoded `POST`+parameters. Returns as a URI `Parameter' type or nothing when parsing fails.+-}++hParameters :: (BodyM d m, HttpM d m) => d -> String -> m Parameters+hParameters d def = fw params . unpack <$> hBodyText d def++-- | Like `hParameters' but specifically for `HTTP' `Request's.++hRequestParameters :: (BodyM Request m, HttpM Request m) => String -> m Parameters+hRequestParameters = hParameters forRequest++-- | Like `hParameters' but specifically for `HTTP' `Response's.++hResponseParameters :: (BodyM Response m, HttpM Response m) => String -> m Parameters+hResponseParameters = hParameters forResponse+
src/Network/Salvia/Handler/CGI.hs view
@@ -1,22 +1,90 @@+{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.CGI (hCGI) where +import Control.Applicative+import Control.Category+import Control.Concurrent import Control.Monad.State+import Data.Char+import Data.List+import Data.List.Split import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd+import Network.Protocol.Http hiding (server)+import Network.Protocol.Uri hiding (host)+import Network.Salvia.Interface+import Network.Salvia.Handler.Error+import Network.Salvia.Handler.Parser+import Network.Socket+import Prelude hiding ((.), id) import System.IO-import System.Process (runProcess, waitForProcess)+import System.Process+import qualified Data.ByteString.Lazy as B -{- |-Handle CGI scripts, not yet working properly.--}+-- | Handler to run CGI scripts. -hCGI :: ResourceHandler ()-hCGI name = do-  setM (status % response) OK-  h <- getM sock-  lift $ do-    p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)-    waitForProcess p-    return ()+-- todo: fails on ipv6 en unix sockets.+-- todo: stderr?++hCGI :: (MonadIO m, HttpM' m, BodyM Request m, SendM m, HandleQueueM m, ServerM m, AddressM' m) => FilePath -> m ()+hCGI fn =+  do adm <- admin+     hst <- host+     (cp, ca) <- clientAddress >>= addr+     (sp, sa) <- serverAddress >>= addr+     hdrs    <- request (getM headers)+     _query  <- request (getM (query . asUri))+     _path   <- request (getM (path . asUri))+     _method <- request (getM method)++     -- Helper function to convert all headers to environment variables.+     let headerDecls =+           map (\(a, b) -> ("HTTP_" ++ (map toUpper . intercalate "_" . splitOn "-") a, b))+             . unHeaders++     -- Set the of expoerted server knowledge.+     let envs =+             ("GATEWAY_INTERFACE", "CGI/1.1")+           : ("REQUEST_METHOD",    show _method)+           : ("REQUEST_URI",       _path)+           : ("QUERY_STRING",      _query)+           : ("SERVER_SOFTWARE",   "Salvia")+           : ("SERVER_SIGNATURE",  "")+           : ("SERVER_PROTOCOL",   "HTTP/1.1")+           : ("SERVER_ADMIN",      adm)+           : ("SERVER_NAME",       hst)+           : ("SERVER_ADDR",       sa)+           : ("SERVER_PORT",       show sp)+           : ("REMOTE_ADDR",       ca)+           : ("REMOTE_PORT",       show cp)+           : ("SCRIPT_FILENAME",   fn)+           : ("SCRIPT_NAME",       fn)+           : headerDecls hdrs++     -- Start up the CGI script with the appropriate environment variables.+     -- todo: what to do with stderr? log?+     (inp, out, _, pid) <- liftIO (runInteractiveProcess fn [] Nothing $ Just envs)++     -- Read the request body and fork a thread to spool the body to the CGI+     -- script's input. After spooling, or when there is no data, the scripts+     -- input will be closed.+     b <- body forRequest+     liftIO $ forkIO (B.hPut inp b >> hClose inp) >> return ()++     -- Read the headers produced by the CGI script and store them as the+     -- response headers of this handler.+     hs <- liftIO (readNonEmptyLines out)+     case parseHeaders hs of+       Left e  -> hCustomError InternalServerError e+       Right r -> response (headers =: r)++     -- Spool all data from the CGI script's output to the client. When+     -- finished, close the handle and wait for the script to terminate.+     spool out+     enqueueHandle (const (hClose out <* waitForProcess pid))++  where+  addr (SockAddrInet  p a)     = (,) p <$> liftIO (inet_ntoa a)+  addr (SockAddrInet6 p _ _ _) = return (p,  "ipv6")+  addr _                       = return (-1, "unix")+
src/Network/Salvia/Handler/Close.hs view
@@ -1,21 +1,22 @@-module Network.Salvia.Handler.Close (-    hCloseConn+module Network.Salvia.Handler.Close+  ( hCloseConn   , hKeepAlive-  ) where+  , emptyQueue+  )+where  import Control.Monad.State import Data.Maybe import Data.Record.Label import Network.Protocol.Http-import Network.Salvia.Httpd+import Network.Salvia.Interface+import Network.Salvia.Handler.Error import System.IO -{- |-Run a handler once and close the connection afterwards.--}+-- | Run a handler once and close the connection afterwards. -hCloseConn :: Handler () -> Handler ()-hCloseConn h = h >> getM sock >>= liftIO . hClose+hCloseConn :: (HandleM m, MonadIO m) => m a -> m ()+hCloseConn h = h >> handle >>= flip catchIO () . hClose  {- | Run a handler and keep the connection open for potential consecutive requests.@@ -28,24 +29,34 @@ * The client has set the `connection` header field to 'close'.  * The connection has already been closed, possible due to IO errors.++* The HTTP version is HTTP/1.0. -} -hKeepAlive :: Handler () -> Handler ()+hKeepAlive :: (QueueM m, HandleM m, HttpM' m, MonadIO m) => m a -> m () hKeepAlive handler =-  do handler--     h      <- getM sock-     conn   <- getM (connection % request)-     len    <- getM (contentLength % response)+  do _ <- handler+     h      <- handle+     conn   <- request (getM connection)+     ver    <- request (getM version)+     len    <- response (getM contentLength)      closed <- liftIO (hIsClosed h)--     if or [closed, conn == "Close", isNothing (len::Maybe Integer) ]-       then liftIO (hClose h)-       else resetContext >> hKeepAlive handler+     if or [ closed+           , conn == Just "Close"+           , isNothing (len :: Maybe Integer)+           , ver == http10+           ]+       then catchIO (hClose h) ()+       else resetContext >> hKeepAlive handler  -resetContext :: Handler ()+resetContext :: (HttpM' m, QueueM m) => m () resetContext =-  do setM request emptyRequest-     setM response emptyResponse-     setM queue []+  do request  (put emptyRequest)+     response (put emptyResponse)+     emptyQueue++-- | Empty the send queue.++emptyQueue :: QueueM m => m ()+emptyQueue = dequeue >>= return () `maybe` const emptyQueue
src/Network/Salvia/Handler/Cookie.hs view
@@ -1,44 +1,55 @@-module Network.Salvia.Handler.Cookie (-    hSetCookies-  , hGetCookies--  , newCookie-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Cookie where  import Control.Applicative hiding (empty)-import Control.Monad.State+import Control.Category import Data.Record.Label import Data.Time.Format-import Data.Time.LocalTime-import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires)-import Network.Protocol.Http (cookie)-import Network.Salvia.Httpd-import System.Locale (defaultTimeLocale)+import Network.Protocol.Cookie+import Network.Salvia.Interface+import Network.Socket+import Prelude hiding ((.), id)+import System.Locale+import qualified Network.Protocol.Http as H -{- | Set the `cookie` HTTP response header (Set-Cookie) with the specified `Cookies`. -}+{- | Set the `Set-Cookie` HTTP response header with the specified `Cookies`. -} -hSetCookies :: Cookies -> Handler ()-hSetCookies = setM (cookie % response) . showCookies+hSetCookie :: HttpM H.Response m => Cookies -> m ()+hSetCookie = response . setM H.setCookie . Just . show  {- | Try to get the cookies from the HTTP `cookie` request header. -} -hGetCookies :: Handler (Maybe Cookies)-hGetCookies = parseCookies <$> getM (cookie % request)+hCookie :: (HttpM H.Request m) => m (Maybe Cookies)+hCookie = fmap (fw cookies) <$> request (getM H.cookie) +{- | Delete one cookie by removing it from the `Set-Cookie' header. -}++hDelCookie :: HttpM H.Response m => String -> m ()+hDelCookie nm = response (theCookie =: Just Nothing)+  where theCookie = fmapL (pickCookie nm)+                  . fmapL (cookies `iso` id)+                  . H.setCookie+ {- | 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.+root. If the second argument is set, the cookie will be valid for all+subdomains. -} -newCookie :: LocalTime -> Handler Cookie-newCookie expire = do-  httpd <- getM config-  return $ empty {-      path    = Just "/"---  , domain  = Just $ '.' : hostname httpd-    , port    = [fromEnum $ listenPort httpd]-    , expires = Just $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire-    }-+hNewCookie :: (ServerM m, ServerAddressM m, FormatTime t) => t -> Bool -> m Cookie+hNewCookie expire _ = do+--   hst   <- host+  sAddr <- serverAddress+  return +    . (path    `set` Just "/")+-- No domain for now, to make demoing easier. The below line doesn't+-- work in Chrome and Webkit if hst is an IP.+--    . (domain  `set` Just ((if wildcard then ('.':) else id) hst))+    . (port    `set` [portNum sAddr])+    . (expires `set` Just ("\"" ++ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire ++ "\""))+    $ empty+  where portNum (SockAddrInet  p _)     = fromIntegral p+        portNum (SockAddrInet6 p _ _ _) = fromIntegral p+        portNum _                       = -1
− src/Network/Salvia/Handler/Counter.hs 
@@ -1,11 +0,0 @@-module Network.Salvia.Handler.Counter (hCounter) where--import Control.Concurrent.STM-import Control.Monad.State-import Network.Salvia.Httpd--{- | This handler simply increases the request counter variable. -}--hCounter :: TVar Int -> Handler ()-hCounter c = lift $ atomically $ readTVar c >>= writeTVar c . (+1)-
src/Network/Salvia/Handler/Directory.hs view
@@ -1,17 +1,21 @@-module Network.Salvia.Handler.Directory (-    hDirectory+{- | Rendering of HTML directory listings. -}+module Network.Salvia.Handler.Directory+  ( hDirectory   , hDirectoryResource-  ) where+  )+where -import Control.Monad.State+import Control.Applicative+import Control.Category+import Control.Monad.State hiding (get) import Data.List (sort) import Data.Record.Label-import Misc.Misc (bool) import Network.Protocol.Http import Network.Protocol.Uri (path)+import Network.Salvia.Interface import Network.Salvia.Handler.File (hResource) import Network.Salvia.Handler.Redirect-import Network.Salvia.Httpd+import Prelude hiding ((.), id, mod) import System.Directory (doesDirectoryExist, getDirectoryContents)  {- |@@ -19,35 +23,42 @@ filesystem. -} -hDirectoryResource :: ResourceHandler ()-hDirectoryResource dirName = do-  (u, p) <- bothM (uri % request) (getM path)-  if (null p) || last p /= '/'-   then hRedirect (lmod path (++"/") u)-   else dirHandler dirName+hDirectoryResource+  :: (MonadIO m, HttpM' m, SendM m)+  => FilePath  -- ^ Directory to produce a listing for.+  -> m ()+hDirectoryResource dirName =+  do u <- request (getM asUri)+     let p = get path u+     if (null p) || last p /= '/'+       then hRedirect (show $ mod path (++"/") u)+       else dirHandler dirName  {- |-Like `hDirectoryResource` but uses the path of the current request URI.+Like `hDirectoryResource` but uses the path from the current request URI. -} -hDirectory :: Handler ()+hDirectory :: (MonadIO m, HttpM' m, SendM m) => m () hDirectory = hResource hDirectoryResource -dirHandler:: ResourceHandler ()-dirHandler dirName = do-  p <- getM (path % uri % request)-  filenames <- lift $ getDirectoryContents dirName-  processed <- lift $ mapM (processFilename dirName) (sort filenames)-  let b = listing p processed-  enterM response $ do-    setM contentType ("text/html", Nothing)-    setM contentLength (Just $ length b)-    setM status OK-  sendStr b+-- Helper function that does all the work. +dirHandler :: (MonadIO m, HttpM' m, SendM m) => FilePath -> m ()+dirHandler dirName =+  do p <- request (getM (path . asUri))+     filenames <- liftIO $ getDirectoryContents dirName+     processed <- liftIO $ mapM (processFilename dirName) (sort filenames)+     let b = listing p processed+     response $+       do contentType   =: Just ("text/html", Nothing)+          contentLength =: Just (length b)+          status        =: OK+     send b+ -- Add trailing slash to a directory name. processFilename :: FilePath -> FilePath -> IO FilePath-processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f)+processFilename d f =+  (\b -> (if b then (++"/") else id) f) <$> doesDirectoryExist (d ++ f)  -- Turn a list of filenames into HTML directory listing. listing :: FilePath -> [FilePath] -> String
src/Network/Salvia/Handler/Dispatching.hs view
@@ -1,12 +1,10 @@-module Network.Salvia.Handler.Dispatching (-    Dispatcher-  , ListDispatcher-  , hDispatch-  , hListDispatch-  ) where+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleContexts, ScopedTypeVariables #-}+module Network.Salvia.Handler.Dispatching where +import Control.Monad.State import Data.Record.Label-import Network.Salvia.Httpd+import Network.Protocol.Http+import Network.Salvia.Interface  {- | The dispatcher type takes one value to dispatch on and two handlers. The first@@ -15,14 +13,14 @@ `False`. -} -type Dispatcher a b = a -> Handler b -> Handler b -> Handler b+type Dispatcher a m b = a -> m b -> m b -> m b  {- |-A list dispatcher takes a mapping from dispatch values and handlers and one-default handler.+A list dispatcher takes a mapping from dispatch values to handlers and one+default fallback handler. -} -type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b+type ListDispatcher a m b = [(a, m b)] -> m b -> m b  {- | Dispatch on an arbitrary part of the context using an arbitrary predicate. When@@ -30,12 +28,14 @@ handler will be invoked, otherwise the second handler will be used. -} -hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b-hDispatch f match a handler _default = do-  ctx <- getM f-  if a `match` ctx-    then handler-    else _default+hDispatch+  :: forall a b c d m. HttpM d m => d -> (Http d :-> b) -> (c -> b -> Bool) -> Dispatcher c m a+hDispatch _ f match a handler _default =+  do let h = http :: State (Http d) b -> m b+     ctx <- h (getM f)+     if a `match` ctx+       then handler+       else _default  {- | Turns a dispatcher function into a list dispatcher. This enables handler@@ -43,6 +43,22 @@ in the `ListDispatcher` type hold the default handler will be invoked. -} -hListDispatch :: Dispatcher a b -> ListDispatcher a b-hListDispatch disp = flip $ foldr $ uncurry disp+hListDispatch :: Dispatcher a m b -> ListDispatcher a m b+hListDispatch disp = flip $ foldr (uncurry disp)++{- |+Like the `hDispatch` but always dispatches on a (part of) the `HTTP+Request' part of the context.+-}++hRequestDispatch :: HttpM Request m => (Http Request :-> b) -> (t -> b -> Bool) -> Dispatcher t m c+hRequestDispatch = hDispatch forRequest++{- |+Like the `hDispatch` but always dispatches on a (part of) the `HTTP+Response' part of the context.+-}++hResponseDispatch :: HttpM Response m => (Http Response :-> b) -> (t -> b -> Bool) -> Dispatcher t m c+hResponseDispatch = hDispatch forResponse
src/Network/Salvia/Handler/Environment.hs view
@@ -1,78 +1,50 @@-module Network.Salvia.Handler.Environment (-    hDefaultEnv-  , hSessionEnv-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Environment+( hDefaultEnv+, hEnvNoKeepAlive+)+where -import Control.Concurrent.STM+import Control.Monad.State import Network.Protocol.Http+import Network.Salvia.Interface import Network.Salvia.Handler.Banner-import Network.Salvia.Handler.Counter import Network.Salvia.Handler.Close import Network.Salvia.Handler.Error import Network.Salvia.Handler.Head-import Network.Salvia.Handler.Log import Network.Salvia.Handler.Parser import Network.Salvia.Handler.Printer-import Network.Salvia.Handler.Session-import Network.Salvia.Httpd-import System.IO+import Prelude hiding (log)  {- |-This is the default stateless handler evnironment. It takes care of request-parsing (`hParser`), response printing (`hPrinter`), request logging (`hLog`),-connection keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and-printing the `salvia-httpd` server banner (`hBanner`).+This is the default handler environment. It takes care of request parsing+(`hRequestParser`), response printing (`hResponsePrinter`), connection+keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and printing the+`salvia-httpd` server banner (`hBanner`).  -}  hDefaultEnv-  :: Handler ()  -- ^ Handler to run in the default environment.-  -> Handler ()+  :: (MonadIO m, HandleM m, RawHttpM' m, HttpM' m, QueueM m, SendM m, FlushM Response m)+  => m ()  -- ^ Handler to run in the default environment.+  -> m () hDefaultEnv handler =   hKeepAlive $ -    hParser (1000 * 15)-      (wrapper Nothing . parseError)-      (wrapper Nothing $ hHead handler)--{- |-This function is a more advanced version of the `hDefaultEnv` handler-environment that takes a global state into account. It takes a shared variable-containg the connection counter (used by `hCounter`) and a variable containing-all session information (used by `hSession`). Handlers that run in this-environment take should be parametrized with a session.--}--hSessionEnv-  :: TVar Int             -- ^ Request count variable.-  -> Sessions a           -- ^ Session collection variable.-  -> SessionHandler a ()  -- ^ Handler parametrized with current session.-  -> Handler ()-hSessionEnv count sessions handler =-  hKeepAlive $ -    hParser (1000 * 15)-     (wrapper (Just count) . parseError)-     (wrapper (Just count) $-       do session <- hSession sessions 300-          hHead (handler session))---- Helper functions.--before :: Handler ()-before = hBanner "salvia-httpd"--after :: Maybe (TVar Int) -> Handler ()-after mc = -  do hPrinter-     maybe-       (hLog stdout)-       (\c -> hCounter c >> hLogWithCounter c stdout)-       mc+    do hBanner "salvia-httpd"+       _ <- hRequestParser (1000 * 4)+         (hCustomError BadRequest)+         (hHead handler)+       hResponsePrinter -wrapper :: Maybe (TVar Int) -> Handler a -> Handler ()-wrapper c h = before >> h >> after c+-- | Like `hDefaultEnv' but only serves one request per connection. -parseError :: String -> Handler ()-parseError err = -  do hError BadRequest-     sendStrLn []-     sendStrLn err+hEnvNoKeepAlive+  :: (MonadIO m, HandleM m, RawHttpM' m, HttpM' m, QueueM m, SendM m, FlushM Response m)+  => m ()  -- ^ Handler to run in this environment.+  -> m ()+hEnvNoKeepAlive handler =+  do hBanner "salvia-httpd"+     _ <- hRequestParser (1000 * 4)+       (hCustomError BadRequest)+       (hHead handler)+     hResponsePrinter
src/Network/Salvia/Handler/Error.hs view
@@ -1,34 +1,35 @@-module Network.Salvia.Handler.Error (-    hError-  , hCustomError-  , hIOError-  , safeIO-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Error+( hError+, hCustomError+, hIOError+, hSafeIO+, catchIO+)+where -import Control.Monad.State+import Control.Monad.Trans import Data.Record.Label import Network.Protocol.Http-import Network.Salvia.Httpd+import Network.Salvia.Interface import System.IO.Error -{- |-The 'hError' handler enables the creation of a default style of error responses-for the specified HTTP `Status` code.--}+-- | The 'hError' handler enables the creation of a default style of error+-- responses for the specified HTTP `Status` code. -hError :: Status -> Handler ()+hError :: (HttpM Response m, SendM m) => Status -> m () hError e = hCustomError e   (concat ["[", show (codeFromStatus e), "] ", show e, "\n"]) -{- | Like `hError` but with a custom error message. -}+-- | Like `hError` but with a custom error message. -hCustomError :: Status -> String -> Handler ()-hCustomError e m = do-  enterM response $ do-    setM status e-    setM contentLength (Just $ length m)-    setM contentType ("text/plain", Nothing)-  sendStr m+hCustomError :: (HttpM Response m, SendM m) => Status -> String -> m ()+hCustomError e m =+  do response $+       do status        =: e+          contentLength =: Just (length m)+          contentType   =: Just ("text/plain", Nothing)+     send m  {- | Map an `IOError` to a default style error response.@@ -41,18 +42,23 @@ >  | True                  = hError InternalServerError -} -hIOError :: IOError -> Handler ()+hIOError :: (HttpM Response m, SendM m) => IOError -> m () hIOError e   | isDoesNotExistError e = hError NotFound   | isAlreadyInUseError e = hError ServiceUnavailable   | isPermissionError   e = hError Forbidden-  | True                  = hError InternalServerError+  | otherwise             = hError InternalServerError -{- |-Execute an handler with the result of an IO action. When the IO actions fails a-default error handler will be executed.--}+-- | 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+hSafeIO+  :: (MonadIO m, HttpM Response m, SendM m)+  => IO a -> (a -> m ()) -> m ()+hSafeIO io h = liftIO (try io) >>= either hIOError h++-- | Utility function to easily catch IO errors.++catchIO :: MonadIO m => IO a -> a -> m a+catchIO a b = liftIO (a `catch` (const (return b)))
+ src/Network/Salvia/Handler/Extension.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Extension+  ( hExtension+  , hExtensionRouter+  )+where++import Control.Category+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Interface+import Prelude hiding ((.), id)++{- | Request dispatcher based on the request path file extenstion. -}++hExtension :: HttpM Request m => Dispatcher (Maybe String) m a+hExtension = hRequestDispatch (extension . path . asUri) (==)++{- | List dispatcher version of `hExtension`. -}++hExtensionRouter :: HttpM Request m => ListDispatcher (Maybe String) m a+hExtensionRouter = hListDispatch hExtension+
− src/Network/Salvia/Handler/ExtensionDispatcher.hs 
@@ -1,21 +0,0 @@-module Network.Salvia.Handler.ExtensionDispatcher (-    hExtension-  , hExtensionRouter-  ) where--import Data.Record.Label-import Network.Protocol.Http (uri)-import Network.Protocol.Uri (extension, path)-import Network.Salvia.Handler.Dispatching-import Network.Salvia.Httpd (request)--{- | Request dispatcher based on the request path file extenstion. -}--hExtension :: Dispatcher (Maybe String) a-hExtension = hDispatch (extension % path % uri % request) (==)--{- | List dispatcher version of `hExtension`. -}--hExtensionRouter :: ListDispatcher (Maybe String) a-hExtensionRouter = hListDispatch hExtension-
− src/Network/Salvia/Handler/Fallback.hs 
@@ -1,33 +0,0 @@-module Network.Salvia.Handler.Fallback (hOr, hEither) where--import Control.Applicative-import Control.Monad.State-import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Httpd--{- |-Until I figure out how to do this correctly, this handler somewow implements-the MonadPlus/Alternative instance using a custom function.--When the first handler fails the response will be reset and the second handler-is executed. Failure is indicated by an HTTP response `Status` bigger than or-equal to 400 (`BadRequest`). See `statusFailure`.--}--hOr :: Handler a -> Handler a -> Handler a-hOr h0 h1 = do-  a  <- h0-  st <- getM (status % response)-  if statusFailure st-    then reset >> h1-    else return a--{- |-Like the `hOr` function, but the types of the alternatives may differ because-the values are packed up in an `Either`.--}--hEither :: Handler a -> Handler b -> Handler (Either a b)-hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)-
src/Network/Salvia/Handler/File.hs view
@@ -1,88 +1,123 @@-module Network.Salvia.Handler.File (-    hFile-  , hFileResource--  , hFileFilter-  , hFileResourceFilter--  , hResource-  , hUri-  ) where+{-# LANGUAGE FlexibleContexts, TypeOperators #-}+module Network.Salvia.Handler.File+( hFile+, hFileResource+, fileMime+, hFileFilter+, hFileResourceFilter+, hResource+, hUri+)+where -import Control.Monad.State+import Control.Applicative+import Control.Category+import Control.Monad.State hiding (get)+import Data.ByteString.Lazy.UTF8 (fromString)+import Data.Digest.Pure.MD5+import Data.Maybe import Data.Record.Label+import Data.Time+import Data.Time.Clock.POSIX import Network.Protocol.Http import Network.Protocol.Mime-import Network.Protocol.Uri (mimetype, path, parseURI)+import Network.Protocol.Uri import Network.Salvia.Handler.Error-import Network.Salvia.Httpd+import Network.Salvia.Handler.Range+import Network.Salvia.Interface+import Prelude hiding ((.), id) import System.IO+import System.Locale+import System.Posix.Files+import qualified Data.ByteString.Lazy as B  {- | Serve a file from the filesystem indicated by the specified filepath. When-there is some kind of `IOError` the `safeIO` function will be used to produce a+there is some kind of `IOError` the `hSafeIO` function will be used to produce a corresponding error response. The `contentType` will be the mime-type based on the filename extension using the `mimetype` function. The `contentLength` will be set the file's size. -} --- TODO: what to do with encoding?-hFileResource :: ResourceHandler ()-hFileResource file = do-  let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)-  safeIO (openBinaryFile file ReadMode)-    $ \fd -> do-      fs <- lift $ hFileSize fd-      enterM response $ do-        setM contentType (m, Just "utf-8")-        setM contentLength (Just fs)-        setM status OK-      spoolBs id fd+hFileResource :: (MonadIO m, HttpM' m, SendM m) => FilePath -> m ()+hFileResource file =+  hSafeIO (openBinaryFile file ReadMode) $ \fd ->+    do fs <- liftIO (hFileSize fd)+       rng <- request (getM range)+       mt <- liftIO $+         formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"+           . posixSecondsToUTCTime+           . realToFrac+           . modificationTime <$> getFileStatus file +       let etag = show . md5 $ fromString mt+       response $+         do contentType   =: Just (fileMime file, Nothing)+            contentLength =: Just fs+            lastModified  =: Just mt+            eTag          =: Just etag+            acceptRanges  =: Just "bytes"+            status        =: OK++       case rng of+         -- todo: use peek and cleanup this range code.+         Just (Range (Just from) to _) ->+           do let t = fromMaybe (fs - 1) to+                  r = Range (Just from) (Just t) (Just fs)+              response $+                do status        =: PartialContent+                   contentRange  =: Just r+                   contentLength =: Just (t - from + 1)+              let chop = maybe id (B.take . fromIntegral . (subtract from)) to+              spoolWithBs (chop . B.drop (fromIntegral from)) fd+              return ()++         _ -> spoolWithBs id fd++fileMime :: FilePath -> Mime+fileMime file =+    maybe defaultMime id+  $ (either (const Nothing) Just (parseUri file)+  >>= mimetype . get path)+ {- | Like the `hFileResource` handler, but with a custom filter over the content.-This function will assume the content is an UTF-8 encoded text file. No-`contentLength` header will be set using this handler.+This function will assume the content is an UTF-8 encoded text file. Because of+the possibly unpredictable behavior of the filter, no `contentLength` header+will be set using this handler. -} --- TODO: what to do with encoding?-hFileResourceFilter :: (String -> String) -> ResourceHandler ()-hFileResourceFilter fFilter file = do  -- TODO... this should be a more general hFilter-  let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)-  safeIO (openBinaryFile file ReadMode)-    $ \fd -> do-      enterM response $ do-        setM contentType (m, Just "utf-8")-        setM status OK-      spool fFilter fd+hFileResourceFilter :: (MonadIO m, HttpM Response m, SendM m) => (String -> String) -> FilePath -> m ()+hFileResourceFilter f file =+  hSafeIO (openFile file ReadMode) $ \fd ->+    do response $+         do contentType =: Just (fileMime file, Just "utf-8")+            status      =: OK+       spoolWith f fd  {- |-Turn a resource handler into a regular handler that utilizes the path part of-the request URI as the resource identifier.+Turn a handler that is parametrized by a file resources into a regular handler+that utilizes the path part of the request URI as the resource identifier. -} -hResource :: ResourceHandler a -> Handler a-hResource rh = getM (path % uri % request) >>= rh+hResource :: HttpM Request m => (FilePath -> m a) -> m a+hResource rh = request (getM (path . asUri)) >>= rh  {- |-Turn a URI handler into a regular handler that utilizes the request URI as the-resource identifier.+Turn a handler that is parametrized by a URI into a regular handler that+utilizes the request URI as the resource identifier. -} -hUri :: UriHandler a -> Handler a-hUri rh = getM (uri % request) >>= rh+hUri :: HttpM Request m => (Uri -> m a) -> m a+hUri rh = request (getM asUri) >>= rh -{- |-Like `hFileResource` but uses the path of the current request URI.--}+-- | Like `hFileResource` but uses the path of the current request URI. -hFile :: Handler ()+hFile :: (MonadIO m, HttpM' m, SendM m) => m () hFile = hResource hFileResource -{- |-Like `hFileResourceFilter` but uses the path of the current request URI.--}+-- | Like `hFileResourceFilter` but uses the path of the current request URI. -hFileFilter :: (String -> String) -> Handler ()+hFileFilter :: (MonadIO m, HttpM' m, SendM m) => (String -> String) -> m () hFileFilter = hResource . hFileResourceFilter
src/Network/Salvia/Handler/FileSystem.hs view
@@ -1,19 +1,22 @@-module Network.Salvia.Handler.FileSystem (-    hFileSystem-  , hFileSystemNoIndexes-  , hFileTypeDispatcher-  ) where+{- | Serving parts of the local file system. -}+module Network.Salvia.Handler.FileSystem+( hFileSystem+, hFileSystemNoIndexes+, hFileTypeDispatcher+)+where +import Control.Category import Control.Monad.State import Data.Record.Label-import Misc.Misc (bool) import Network.Protocol.Http-import Network.Protocol.Uri (jail, path)+import Network.Protocol.Uri+import Network.Salvia.Interface import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Error import Network.Salvia.Handler.File-import Network.Salvia.Httpd-import System.Directory (doesDirectoryExist)+import Prelude hiding ((.), id)+import System.Directory  {- | Dispatch based on file type; regular files or directories. The first handler@@ -25,17 +28,25 @@ parts of the file system. -} -hFileTypeDispatcher :: ResourceHandler () -> ResourceHandler () -> ResourceHandler () +hFileTypeDispatcher+  :: (MonadIO m, HttpM' m, SendM m)+  => (FilePath -> m ())  -- ^ Handler to invoke in case of directory.+  -> (FilePath -> m ())  -- ^ Handler to invoke in case of regular files.+  -> FilePath            -- ^ Directory to serve.+  -> m () hFileTypeDispatcher hdir hfile dir =-  getM (path % uri % request) >>=-  hJailedDispatch dir hdir hfile . (dir ++)+  do p <- request $ getM (path . asUri) +     hJailedDispatch dir hdir hfile (dir /+ p)  {- | Serve single directory by combining the `hDirectoryResource` and `hFileResource` handlers in the `hFileTypeDispatcher`. -} -hFileSystem :: ResourceHandler ()+hFileSystem+  :: (MonadIO m, HttpM' m, SendM m)+  => FilePath  -- ^ Directory to serve.+  -> m () hFileSystem = hFileTypeDispatcher hDirectoryResource hFileResource  {- |@@ -43,14 +54,21 @@ Instead of an directory index an `Forbidden` response will be created. -} --- Show file contents, do not show directory indexes.-hFileSystemNoIndexes :: ResourceHandler ()+hFileSystemNoIndexes+  :: (MonadIO m, HttpM' m, SendM m)+  => FilePath  -- ^ Directory to serve.+  -> m () hFileSystemNoIndexes = hFileTypeDispatcher (const $ hError Forbidden) hFileResource -hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler () -hJailedDispatch dir hdir hfile file = do-  case jail dir file of-    Nothing -> hError Forbidden-    Just f  -> bool (hdir file) (hfile file)-           =<< lift (doesDirectoryExist f) +-- Helper distpatcher that takes care of jailing the request in the specified+-- file system directory.++hJailedDispatch+  :: (MonadIO m, HttpM' m, SendM m)+  => FilePath -> (FilePath -> m ()) -> (FilePath -> m ()) -> FilePath -> m () +hJailedDispatch dir hdir hfile file =+  do case jail dir file of+       Nothing -> hError Forbidden+       Just f -> (\b -> (if b then hdir else hfile) file)+                 =<< liftIO (doesDirectoryExist f)
src/Network/Salvia/Handler/Head.hs view
@@ -1,23 +1,26 @@+{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Head (hHead) where -import Control.Applicative-import Control.Monad.State (put)+import Control.Monad.Trans+import Control.Applicative hiding (empty) import Data.Record.Label import Network.Protocol.Http-import Network.Salvia.Httpd+import Network.Salvia.Handler.Rewrite+import Network.Salvia.Handler.Close+import Network.Salvia.Interface  {- |-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+The 'hHead' handler makes sure no `HTTP' `Response' body is sent to the client+when the request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the specified sub handler will be executed under the assumption that the request was a 'GET' request, otherwise this handler will act as the identify function. -} -hHead :: Handler a -> Handler a-hHead handler = do-  m <- getM (method % request)-  case m of-    HEAD -> withM (method % request) (put GET) $-              handler <* emptyQueue-    _    -> handler+hHead :: (MonadIO m, QueueM m, HttpM Request m) => m a -> m a+hHead handler =+  do m <- request (getM method)+     case m of+       HEAD -> hLocalRequest method (const GET) $+                 handler <* emptyQueue+       _    -> handler
src/Network/Salvia/Handler/Log.hs view
@@ -1,47 +1,53 @@-module Network.Salvia.Handler.Log (-    hLog-  , hLogWithCounter-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Log where -import Control.Concurrent.STM+import Control.Applicative import Control.Monad.State-import Data.Record.Label-import Misc.Terminal (red, green, reset)+import Data.List+import Data.Record.Label hiding (get)+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime import Network.Protocol.Http-import Network.Salvia.Httpd  (Handler, request, response, address)+import Network.Salvia.Interface import System.IO+import System.Locale  {- |-A simple logger that prints a summery of the request information to the-specified file handle.+A simple logger that prints a summery of the request information to+the specified file handle. -} -hLog :: Handle -> Handler ()-hLog = logger Nothing+hLog :: (AddressM' m , MonadIO m, HttpM' m) => Handle -> m ()+hLog h =+  do mt <- request  (getM method)+     ur <- request  (getM uri)+     st <- response (getM status)+     ca <- clientAddress+     sa <- serverAddress+     dt <- liftIO $+       do zone <- getCurrentTimeZone+          time <- utcToLocalTime zone <$> getCurrentTime+          return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" time+     let code = codeFromStatus st+     liftIO+       . hPutStrLn h+       $ intercalate " ; "+         [ dt+         , show sa+         , show mt+         , show ca+         , ur+         , show code ++ " " ++ show st+         ] -{- | Like `hLog` but also prints the request count since server startup. -}+-- | Dump the request headers to the standard output, useful for debugging. -hLogWithCounter :: TVar Int -> Handle -> Handler ()-hLogWithCounter a = logger (Just a)+hDumpRequest :: (HttpM Request m, MonadIO m) => m ()+hDumpRequest = request get >>= liftIO . print -logger :: Maybe (TVar Int) -> Handle -> Handler ()-logger count handle = do-  c <- case count of-    Nothing -> return ""-    Just c' -> liftIO (show `liftM` atomically (readTVar c'))-  mt   <- getM (method % request)-  ur   <- getM (uri    % request)-  st   <- getM (status % response)-  addr <- getM address-  let code = codeFromStatus st-      clr  = if code >= 400 then red else green-  liftIO $ hPutStrLn handle $ concat [-      concat ["[", show addr, "] ", c, "\t"]-    , show mt, "\t"-    , show ur, " -> "-    , clr-    , show code, " "-    , show st-    , reset-    ]+-- | Dump the response headers to the standard output, useful for debugging.++hDumpResponse :: (HttpM Response m, MonadIO m) => m ()+hDumpResponse = response get >>= liftIO . print
− src/Network/Salvia/Handler/Login.hs 
@@ -1,276 +0,0 @@-module Network.Salvia.Handler.Login (--  -- * Basic types.-    Username-  , Password-  , Action-  , Actions-  , User (..)-  , Users-  , UserDatabase-  , TUserDatabase--  -- * User Sessions.-  , UserPayload (..)-  , UserSession-  , TUserSession-  , UserSessionHandler--  -- * Handlers.-  , hSignup-  , hLogin-  , hLogout-  , hLoginfo--  , hAuthorized-  , hAuthorizedUser--  -- * Helper functions.-  , readUserDatabase--  ) where--import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)-import Control.Monad.State (lift, liftM)-import Data.Digest.Pure.MD5 (md5)-import Data.List (intercalate)-import Data.Maybe (catMaybes)-import Data.Record.Label-import Misc.Misc (atomModTVar, safeHead)-import Network.Protocol.Http (Status (Unauthorized, OK), status)-import Network.Salvia.Handler.Error (hCustomError, hError)-import Network.Salvia.Handler.Session-import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)-import Network.Protocol.Uri-import Data.ByteString.Lazy.UTF8 (fromString)-----------------------------------------------------------------------------------type Username = String-type Password = String-type Action   = String-type Actions  = [Action]--{- |-User containg a username, password and a list of actions this user is allowed-to perform within the system.--}--data User = User {-    username :: Username-  , password :: Password-  , email    :: String-  , actions  :: Actions-  } deriving (Eq, Show)--type Users = [User]--{- |-A user database containing a list of users, a list of default actions the guest-or `no-user' user is allowed to perform and a polymorphic reference to the-place the database originates from. This source field can be used by update-functions synchronizing changes back to the database.--}--data UserDatabase src =-  UserDatabase {-    dbUsers  :: Users-  , dbGuest  :: Actions-  , dbSource :: src-  } deriving Show--type TUserDatabase src = TVar (UserDatabase src)--{- |-A user payload instance contains user related session information and can be-used as the payload for regular sessions. It contains a reference to the user-it is bound to, a flag to indicate whether the user is logged in or not and a-possible user specific session payload.--}--data UserPayload a = UserPayload {-    upUser     :: User-  , upLoggedIn :: Bool-  , upPayload  :: Maybe a-  } deriving (Eq, Show)--type UserSession  a = Session  (UserPayload a)-type TUserSession a = TSession (UserPayload a)--{- | A handler that requires a session with a user specific payload. -}--type UserSessionHandler a b = SessionHandler (UserPayload a) b-----------------------------------------------------------------------------------{-|-Read a user data from file. Format: /username password email action*/.--}--readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)-readUserDatabase file = do--  -- First line contains the default `guest` actions, tail lines contain users.-  gst:ls <- lines `liftM` readFile file--  atomically $ newTVar $ UserDatabase-    (catMaybes $ map parseUserLine ls)-    (words gst)-    file-  where-    parseUserLine line =-      case words line of-        user:pass:mail:acts -> Just (User user pass mail acts)-        _                   -> Nothing--printUserLine :: User -> String-printUserLine u = intercalate " " ([-    username u-  , password u-  , email u-  ] ++ actions u)--{- |-The signup handler is used to create a new entry in the user database. It reads-a new username and password from the HTTP POST parameters and adds a new entry-in the database when no user with such name exists. The user gets the specified-initial set of actions assigned. On failure an `Unauthorized' error will be-produced.--}--hSignup :: TUserDatabase FilePath -> Actions -> Handler ()-hSignup tdb acts = do-  db <- lift . atomically $ readTVar tdb-  params <- uriEncodedPostParamsUTF8-  case freshUserInfo params (dbUsers db) acts of-    Nothing -> hCustomError Unauthorized "signup failed"-    Just u  -> do-      lift $ do-        atomically-          $ writeTVar tdb-          $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)-        appendFile (dbSource db) (printUserLine u)--freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User-freshUserInfo params us acts = do-  p <- params-  user <- "username" `lookup` p >>= id-  pass <- "password" `lookup` p >>= id-  mail <- "email"    `lookup` p >>= id-  case safeHead $ filter ((==user).username) us of-    Nothing -> return $ User user (show $ md5 $ fromString pass) mail acts-    Just _  -> Nothing-----------------------------------------------------------------------------------{- |-The login handler. Read the username and password values from the post data and-use that to authenticate the user. When the user can be found in the database-the user is logged in and stored in the session payload. Otherwise a-`Unauthorized' response will be sent and the user has not logged in.--}--hLogin :: UserDatabase b -> UserSessionHandler a ()-hLogin db session = do-  params <- uriEncodedPostParamsUTF8-  maybe-    (hCustomError Unauthorized "login failed")-    (loginSuccessful session)-    (authenticate params db)--authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User-authenticate params db = do-  p <- params-  user <- "username" `lookup` p >>= id-  pass <- "password" `lookup` p >>= id-  case safeHead $ filter ((==user).username) (dbUsers db) of-    Nothing -> Nothing-    Just u  ->-      if password u == (show $ md5 $ fromString pass)-      then return u-      else Nothing---- Login user and create `Ok' response on successful user.-loginSuccessful :: TUserSession a -> User -> Handler ()-loginSuccessful session user = do-  lift $ atomModTVar (\s -> s {sPayload = Just (UserPayload user True Nothing)}) session-  setM (status % response) OK-  sendStrLn "login successful"-----------------------------------------------------------------------------------{- | Logout the current user by emptying the session payload. -}--hLogout :: TUserSession a -> Handler ()-hLogout session = do-  lift $ atomModTVar (\s -> s {sPayload = Nothing}) session-  return ()-----------------------------------------------------------------------------------{- |-The `loginfo' handler exposes the current user session to the world using a-simple text based file. The file contains information about the current session-identifier, session start and expiration date and the possible user payload-that is included.--}--hLoginfo :: UserSessionHandler a ()-hLoginfo session = do-  s' <- lift $ atomically $ readTVar session--  sendStrLn $ "sID="    ++ show (sID     s')-  sendStrLn $ "start="  ++ show (sStart  s')-  sendStrLn $ "expire=" ++ show (sExpire s')--  case sPayload s' of-    Nothing -> return ()-    Just (UserPayload (User uname _ mail acts) _ _) -> do-      sendStrLn $ "username=" ++ uname-      sendStrLn $ "email="    ++ mail-      sendStrLn $ "actions="  ++ intercalate " " acts-----------------------------------------------------------------------------------{- |-Execute a handler only when the user for the current session is authorized to-do so. The user must have the specified action contained in its actions list in-order to be authorized. Otherwise an `Unauthorized' error will be produced.-When no user can be found in the current session or this user is not logged in-the guest account from the user database is used for authorization.--}--hAuthorized ::-     UserDatabase b              -- ^ The user database to read guest account from.-  -> Action                      -- ^ The actions that should be authorized.-  -> (Maybe User -> Handler ())  -- ^ The handler to perform when authorized.-  -> UserSessionHandler a ()     -- ^ This handler requires a user session.--hAuthorized db action handler session = do-  load <- liftM sPayload (lift $ atomically $ readTVar session)-  case load of-    Just (UserPayload user _ _)-      | action `elem` actions user -> handler (Just user)-    Nothing-      | action `elem` dbGuest db   -> handler Nothing-    _                              -> hError Unauthorized--{- |-Execute a handler only when the user for the current session is authorized to-do so. The user must have the specified action contained in its actions list in-order to be authorized. Otherwise an `Unauthorized' error will be produced. The-guest user will not be used in any case.--}--hAuthorizedUser ::-     Action                      -- ^ The actions that should be authorized.-  -> (User -> Handler ())        -- ^ The handler to perform when authorized.-  -> UserSessionHandler a ()     -- ^ This handler requires a user session.--hAuthorizedUser action handler session = do-  load <- liftM sPayload (lift $ atomically $ readTVar session)-  case load of-    Just (UserPayload user _ _)-      | action `elem` actions user -> handler user-    _                              -> hError Unauthorized-
+ src/Network/Salvia/Handler/Method.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Method+  ( hMethod+  , hMethodRouter+  )+where++import Network.Protocol.Http+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Interface++{- | Request dispatcher based on the HTTP request `Method`.  -}++hMethod :: HttpM Request m => Dispatcher Method m a+hMethod = hRequestDispatch method (==)++{- | Request list dispatcher based on the `hMethod` dispatcher. -}++hMethodRouter :: HttpM Request m => ListDispatcher Method m ()+hMethodRouter = hListDispatch hMethod+
− src/Network/Salvia/Handler/MethodRouter.hs 
@@ -1,78 +0,0 @@-module Network.Salvia.Handler.MethodRouter (-    hMethod-  , hMethodRouter--  , hOPTIONS-  , hGET-  , hHEAD-  , hPOST-  , hPUT-  , hDELETE-  , hTRACE-  , hCONNECT-  ) where--import Data.Record.Label-import Network.Protocol.Http-import Network.Salvia.Handler.Dispatching-import Network.Salvia.Handler.Error-import Network.Salvia.Httpd--{- |-Request dispatcher based on the HTTP request `Method`. When the method does not-match an HTTP `NotFound` will be created and `Nothing` will be returned.--}--hMethod :: Method -> Handler a -> Handler (Maybe a)-hMethod m h = hMethod' m-  (Just `fmap` h)-  (const Nothing `fmap` hError NotFound)--{- | Request list dispatcher based on the `hMethod` dispatcher. -}--hMethodRouter :: ListDispatcher Method ()-hMethodRouter = hListDispatch hMethod'--{- | Only invoke a handler on an `OPTIONS` request. -}--hOPTIONS :: Handler a -> Handler (Maybe a)-hOPTIONS = hMethod OPTIONS--{- | Only invoke a handler on a `GET` request. -}--hGET :: Handler a -> Handler (Maybe a)-hGET = hMethod GET--{- | Only invoke a handler on a `HEAD` request. -}--hHEAD :: Handler a -> Handler (Maybe a)-hHEAD = hMethod HEAD--{- | Only invoke a handler on a `POST` request. -}--hPOST :: Handler a -> Handler (Maybe a)-hPOST = hMethod POST--{- | Only invoke a handler on a `PUT` request. -}--hPUT :: Handler a -> Handler (Maybe a)-hPUT = hMethod PUT--{- | Only invoke a handler on a `DELETE` request. -}--hDELETE :: Handler a -> Handler (Maybe a)-hDELETE = hMethod DELETE--{- | Only invoke a handler on a `TRACE` request. -}--hTRACE :: Handler a -> Handler (Maybe a)-hTRACE = hMethod TRACE--{- | Only invoke a handler on a `CONNECT` request. -}--hCONNECT :: Handler a -> Handler (Maybe a)-hCONNECT = hMethod CONNECT--hMethod' :: Dispatcher Method a-hMethod' = hDispatch (method % request) (==)-
src/Network/Salvia/Handler/Parser.hs view
@@ -1,51 +1,83 @@-module Network.Salvia.Handler.Parser (hParser) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Parser+( hRequestParser+, hResponseParser+, hParser+, readNonEmptyLines+)+where -import Control.Monad.State-import Data.Record.Label+import Control.Applicative+import Control.Monad.State hiding (sequence)+import Data.Traversable import Network.Protocol.Http-import Network.Salvia.Httpd+import Network.Salvia.Interface+import Network.Salvia.Handler.Error+import Prelude hiding (sequence) import System.IO-import System.Timeout+-- import System.Timeout +-- | Like the `hParser' but always parses `HTTP` `Requests`s.++hRequestParser+  :: (HandleM m, RawHttpM Request m, HttpM Request m, MonadIO m)+  => Int               -- ^ Timeout in milliseconds.+  -> (String -> m a)   -- ^ The fail handler.+  -> m a               -- ^ The success handler.+  -> m (Maybe a)+hRequestParser = hParser pt parseRequest+  where pt x = do request (put x)+                  rawRequest (put x)++-- | Like the `hParser' but always parses `HTTP` `Response`s.++hResponseParser+  :: (HandleM m, RawHttpM Response m, HttpM Response m, MonadIO m)+  => Int               -- ^ Timeout in milliseconds.+  -> (String -> m a)   -- ^ The fail handler.+  -> m a               -- ^ The success handler.+  -> m (Maybe a)+hResponseParser = hParser pt parseResponse+  where pt x = do response (put x)+                  rawResponse (put x)+ {- |-The 'hParser' handler is used to parse the raw request message into the+The 'hParser' handler is used to parse the raw `HTTP` message into the 'Message' data type. This handler is generally used as (one of) the first-handlers in an environment. The first handler argument is executed when the-request is invalid, possibly due to parser errors, and is parametrized with the-error string. The second handler argument is executed when the request is-valid. When the message could be parsed within the time specified with the-first argument the function silently returns.+handlers in a client or server environment. The first handler argument is+executed when the message is invalid, possibly due to parser errors, and is+parametrized with the error string. The second handler argument is executed+when the message is valid. When the message could not be parsed within the time+specified with the first argument the function silently returns. -} -hParser ::-     Int                    -- ^ Timeout in milliseconds.-  -> (String -> Handler ()) -- ^ The fail handler.-  -> Handler ()             -- ^ The success handler.-  -> Handler ()--hParser t onfail onsuccess = do-  h <- getM sock-  -- TODO use try and fail with bad request or reject silently.-  mMsg <- liftIO $ timeout (t * 1000) $-    -- TODO: Using NoBuffering here may crash the entire program (GHC-    -- runtime?) when processing more requests than just a few:-    do hSetBuffering h (BlockBuffering (Just (64*1024)))-       fmap Just (readHeader h) `catch` const (return Nothing)-  case join mMsg of-    Nothing -> return ()-    Just msg -> -      do case parseRequest (msg "") of-           Left err -> onfail (show err)-           Right x -> do-             setM request x-             onsuccess+hParser+  :: (HandleM m, MonadIO m)+  => (Http d -> m b)                        -- ^ What to do with message.+  -> (String -> Either String (Http d))     -- ^ Custom message parser.+  -> Int                                    -- ^ Timeout in milliseconds.+  -> (String -> m a)                        -- ^ The fail handler.+  -> m a                                    -- ^ The success handler.+  -> m (Maybe a)+hParser action parse _ onfail onsuccess =+  do h <- handle+     mmsg <-+       liftM join+         . flip catchIO Nothing+         . fmap Just+--          . timeout (t * 1000)+         $ do hSetBuffering h (BlockBuffering (Just (64*1024)))+              Just <$> readNonEmptyLines h+     let hndl = (onfail . show) `either` (\x -> action x >> onsuccess)+     sequence (hndl . parse <$> mmsg)  -- 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)+readNonEmptyLines :: Handle -> IO String+readNonEmptyLines h = ($"") <$> f+  where+    f = do l <- hGetLine h+           let lf = showChar '\n'+           if null l || l == "\r"+             then return lf+             else ((showString l . lf) .) <$> f
+ src/Network/Salvia/Handler/Path.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Path+  ( hPath+  , hPathRouter+  , hPrefix+  , hPrefixRouter++  , hQueryParameters+  )+where++import Control.Category+import Data.List+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Salvia.Interface+import Network.Salvia.Handler.Dispatching+import Network.Salvia.Handler.Rewrite+import Prelude hiding ((.), id)++{- | Request dispatcher based on the request path. -}++hPath :: HttpM Request m => Dispatcher String m a+hPath p h = hRequestDispatch (path . asUri) (==) p (chop p h)++{- | List dispatcher version of `hPath`. -}++hPathRouter :: HttpM Request m => ListDispatcher String m a+hPathRouter = hListDispatch hPath++{- | Request dispatcher based on a prefix of the request path. -}++hPrefix :: HttpM Request m => Dispatcher String m a+hPrefix p h = hRequestDispatch (path . asUri) isPrefixOf p (chop p h)++{- | List dispatcher version of `hPrefix`. -}++hPrefixRouter :: HttpM Request m => ListDispatcher String m a+hPrefixRouter = hListDispatch hPrefix++{- | Helper function to fetch the URI parameters from the request. -}++hQueryParameters :: HttpM Request m => m Parameters+hQueryParameters = request (getM (queryParams . asUri))++-- Helper.++chop :: HttpM Request m => String -> m a -> m a+chop a = hLocalRequest (path . asUri) (drop (length a))+
− src/Network/Salvia/Handler/PathRouter.hs 
@@ -1,45 +0,0 @@-module Network.Salvia.Handler.PathRouter (-    hPath-  , hPathRouter-  , hPrefix-  , hPrefixRouter--  , hParameters-  ) where--import Control.Monad.State-import Data.List (isPrefixOf)-import Data.Record.Label-import Network.Protocol.Http-import Network.Protocol.Uri (path, queryParams, Parameters)-import Network.Salvia.Handler.Dispatching-import Network.Salvia.Httpd--{- | Request dispatcher based on the request path. -}--hPath :: Dispatcher String a-hPath p h = hDispatch (path % uri % request) (==) p (chop p h)--{- | List dispatcher version of `hPath`. -}--hPathRouter :: ListDispatcher String b-hPathRouter = hListDispatch hPath--{- | Request dispatcher based on a prefix of the request path. -}--hPrefix :: Dispatcher String a-hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)--{- | List dispatcher version of `hPrefix`. -}--hPrefixRouter :: ListDispatcher String b-hPrefixRouter = hListDispatch hPrefix--{- | Helper function to fetch the URI parameters from the request. -}--hParameters :: Handler Parameters-hParameters = getM (uri % request) >>= return . queryParams --chop :: String -> Handler a -> Handler a-chop a = withM (path % uri % request) (modify (drop $ length a))-
src/Network/Salvia/Handler/Printer.hs view
@@ -1,15 +1,77 @@-module Network.Salvia.Handler.Printer (hPrinter) where+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes #-}+module Network.Salvia.Handler.Printer+( hRequestPrinter+, hResponsePrinter+, hFlushHeaders+, hFlushHeadersOnly+, hFlushRequestHeaders+, hFlushResponseHeaders+, hFlushQueue+)+where -import Network.Salvia.Httpd+import Control.Applicative+import Control.Monad.State+import Network.Protocol.Http+import Network.Salvia.Interface+import Network.Salvia.Handler.Error+import System.IO  {- |-The 'hPrinter' handler print the entire response including the headers to the-client. This handler is generally used as (one of) the last handler in a-handler environment.+The 'hRequestPrinter' handler prints the entire HTTP request including the+headers and the body to the socket towards the server. This handler is+generally used as (one of) the last handler in a server environment. -} -hPrinter :: Handler ()-hPrinter =-  do flushHeaders-     flushQueue+hRequestPrinter :: FlushM Request m => m ()+hRequestPrinter = flushHeaders forRequest >> flushQueue forRequest++{- |+The 'hResponsePrinter' handler prints the entire HTTP response including the+headers and the body to the socket towards the client. This handler is+generally used as (one of) the last handler in a client environment.+-}++hResponsePrinter :: FlushM Response m => m ()+hResponsePrinter = flushHeaders forResponse >> flushQueue forResponse++-- | Send all the message headers directly over the socket.++-- | todo: printer for rawResponse over response!!++hFlushHeaders :: forall m d. (Show (Http d), HandleM m, QueueM m, MonadIO m, HttpM d m) => d -> m ()+hFlushHeaders _ =+  do r <- http get :: m (Http d)+     h <- handle +     catchIO (hPutStr h (show r) >> hFlush h) ()++-- | Like `hFlushHeaders' but does not print status line, can be useful for CGI mode.++hFlushHeadersOnly :: forall m d. (Show (Http d), HandleM m, QueueM m, MonadIO m, HttpM d m) => d -> m ()+hFlushHeadersOnly _ =+  do r <- http get :: m (Http d)+     h <- handle +     catchIO (hPutStr h (unlines . tail . lines $ show r) >> hFlush h) ()++-- | Like `hFlushHeaders` but specifically for the request headers.++hFlushRequestHeaders :: FlushM Request m => m ()+hFlushRequestHeaders = flushHeaders forRequest++-- | Like `hFlushHeaders` but specifically for the response headers.++hFlushResponseHeaders :: FlushM Response m => m ()+hFlushResponseHeaders = flushHeaders forResponse++-- | One by one apply all enqueued send actions to the socket.++hFlushQueue :: (QueueM m, HandleM m, SocketM m, MonadIO m) => m ()+hFlushQueue =+  do s <- socket+     h <- handle+     q <- queue+     flip catchIO () $+       sequence_ (map (\(SendAction f) -> f (s, h)) q) >> hFlush h+  where queue = dequeue >>= maybe (return []) ((<$> queue) . (:))+
src/Network/Salvia/Handler/Put.hs view
@@ -1,26 +1,55 @@-module Network.Salvia.Handler.Put (hPut) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.Put+( hPutFileSystem+, hPutResource+, hStore+)+where  import Control.Monad.State import Network.Protocol.Http+import Network.Salvia.Interface+import Network.Salvia.Handler.Body+import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Error-import Network.Salvia.Httpd+import Network.Salvia.Handler.File+import Network.Salvia.Handler.FileSystem+import Network.Salvia.Handler.Method import System.IO import qualified Data.ByteString.Lazy as B  {- |-First naive handler for the HTTP `PUT` request. This probably does not handle-all the quirks that the HTTP protocol specifies, but it does the job for now.-When a 'contentLength' header field is available only this fixed number of-bytes will be spooled from socket to the resource. When both the `keepAlive'-and 'contentLength' header fields are not available the entire payload of the-request is spooled to the resource.+Create a browseable filesystem handler (like `hFileSystem') but make all files+writeable by a `PUT' request. Files that do not exists will be created as long+as the directory in which they will be created exists. -} -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)+hPutFileSystem :: (MonadIO m, HttpM' m, SendM m, BodyM Request m) => FilePath -> m ()+hPutFileSystem = hFileTypeDispatcher hDirectoryResource (hPutResource hFileResource)++{- |+Invokes the `hStore' handler when the request is a `PUT' request and invokes+the fallback handler otherwiser.+-}++hPutResource+  :: (MonadIO m, BodyM Request m, HttpM' m, SendM m)+  => (FilePath -> m ()) -> FilePath -> m ()+hPutResource def fp = hMethod PUT (hStore fp) (def fp)++{- |+This handler takes a FilePath and will try to store the entire request body in+that file. When the request body could for some reason not be fetch a+`BadRequest' error response will be created. When an IO error occurs the+`hIOError' function is used to setup an apropriate response.+-}++hStore+  :: (MonadIO m, BodyM Request m, HttpM Response m, SendM m)+  => FilePath -> m ()+hStore name =+  do b <- hRawRequestBody+     hSafeIO+       (withBinaryFile name WriteMode (flip B.hPut b))+       (const (hCustomError OK "Document stored."))
+ src/Network/Salvia/Handler/Range.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts, TypeOperators #-}+module Network.Salvia.Handler.Range+( Range (..)+, contentRange+, range+, rangeL+)+where++import Data.Record.Label+import Data.List+import Network.Protocol.Http+import Safe++-- | HTTP Range datatype.++data Range = Range (Maybe Integer) (Maybe Integer) (Maybe Integer)+  deriving Show++-- | Access the /Content-Range/ header field.++contentRange :: Http Response :-> Maybe Range+contentRange = lmap rangeL `iso` header "Content-Range"++-- | Access the /Range/ header field.++range :: Http Request :-> Maybe Range+range = lmap rangeL `iso` header "Range"++-- | Lens containing parser and pretty-printer for HTTP ranges.++rangeL :: String :<->: Range+rangeL = parser <-> printer+  where+  printer (Range f t x) = concat ["bytes ", maybe "" show f, "-", maybe "" show t, maybe "" (('/':).show) x]+  parser r =+    case span (/='-') . maybe r id $ stripPrefix "bytes=" r of+      (f, _:a) -> case span (/='/') a of+                    (t, _:x) -> Range (readMay f) (readMay t) (readMay x)+                    (t, _)   -> Range (readMay f) (readMay t) Nothing+      (f, [])  ->               Range (readMay f) Nothing Nothing++-- If-Range: "ac5319-31f76000-481fa6ec42cc0"+-- Range: bytes=125817136-+-- Content-Range:  "bytes 21010-47021/47022"+-- "ac5319-31f76000-481fa6ec42cc0"+-- Last-Modified: Wed, 17 Mar 2010 07:55:07 GMT+-- : bytes+
src/Network/Salvia/Handler/Redirect.hs view
@@ -1,18 +1,18 @@+{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Redirect (hRedirect) where  import Data.Record.Label import Network.Protocol.Http-import Network.Protocol.Uri (URI)-import Network.Salvia.Httpd+import Network.Salvia.Interface  {- | Redirect a client to another location by creating a `MovedPermanently` response message with the specified `URI` in the `location' header. -} -hRedirect :: URI -> Handler ()+hRedirect :: HttpM Response m => String -> m () hRedirect u =-  enterM response $ do-    setM location (Just u)-    setM status MovedPermanently+  response $+    do location =: Just u+       status   =: MovedPermanently
src/Network/Salvia/Handler/Rewrite.hs view
@@ -1,60 +1,75 @@-module Network.Salvia.Handler.Rewrite (-    hRewrite+{-# LANGUAGE FlexibleContexts, TypeOperators #-}+module Network.Salvia.Handler.Rewrite+  ( hLocalRequest++  , hRewrite   , hRewritePath   , hRewriteHost   , hRewriteExt+   , hWithDir   , hWithoutDir-  ) where -import Control.Monad.State-import Data.List (isPrefixOf)+  )+where++import Control.Applicative+import Control.Category+import Data.List import Data.Record.Label import Network.Protocol.Http-import Network.Protocol.Uri (URI, host, path, extension)-import Network.Salvia.Httpd+import Network.Protocol.Uri+import Network.Salvia.Interface hiding (host)+import Prelude hiding ((.), id)  {- |-Run an handler in a modified context in which the request `URI` has been-changed by the specified modifier function. After the handler completes the `URI`-remains untouched.+Run a handler in a local environment in which the `HTTP' `Request' has+been modified. -} -hRewrite :: (URI -> URI) -> Handler a -> Handler a-hRewrite f = withM (uri % request) (modify f)+hLocalRequest :: HttpM Request m => (Http Request :-> b) -> (b -> b) -> m a -> m a+hLocalRequest p f m =+  do u <- request (getM p) <* request (modM p f)+     m <* request (p =: u) --- express these below in terms of the above?+{- |+Run an handler in a modified context in which the request `Uri` has been+changed by the specified modifier function. After the handler completes the `Uri`+remains untouched.+-} +hRewrite :: HttpM Request m => (Uri -> Uri) -> m a -> m a+hRewrite = hLocalRequest asUri+ {- | Run handler in a context with a modified host. -} -hRewriteHost :: (String -> String) -> Handler a -> Handler a-hRewriteHost f = withM (host % uri % request) (modify f)+hRewriteHost :: HttpM Request m => (String -> String) -> m a -> m a+hRewriteHost = hLocalRequest (host . asUri)  {- | Run handler in a context with a modified path. -} -hRewritePath :: (String -> String) -> Handler a -> Handler a-hRewritePath f = withM (path % uri % request) (modify f)+hRewritePath :: HttpM Request m => (FilePath -> FilePath) -> m a -> m a+hRewritePath = hLocalRequest (path . asUri)  {- | Run handler in a context with a modified file extension. -} -hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a-hRewriteExt f = withM (extension % path % uri % request) (modify f)+hRewriteExt :: HttpM Request m => (Maybe String -> Maybe String) -> m a -> m a+hRewriteExt = hLocalRequest (extension . path . asUri)  {- | Run handler in a context with a modified path. The specified prefix will be prepended to the path. -} -hWithDir :: String -> Handler a -> Handler a+hWithDir :: HttpM Request m => String -> m a -> m a hWithDir d = hRewritePath (d++)  {- | Run handler in a context with a modified path. The specified prefix will be-stripped form the path.+stripped from the path. -} -hWithoutDir :: String -> Handler a -> Handler a-hWithoutDir d h = do-  p <- getM (path % uri % request)-  (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h+hWithoutDir :: HttpM Request m => String -> m a -> m a+hWithoutDir d = hRewritePath $+  \p -> if d `isPrefixOf` p then drop (length d) p else p
− src/Network/Salvia/Handler/Session.hs 
@@ -1,192 +0,0 @@-module Network.Salvia.Handler.Session (-    hSession--  , SessionID-  , Session (..)-  , TSession-  , SessionHandler-  , Sessions--  , mkSessions-  ) where--import Control.Applicative hiding (empty)-import Control.Concurrent.STM-import Control.Monad.State-import Data.Time.LocalTime-import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)-import Network.Protocol.Cookie hiding (empty)-import Network.Salvia.Handler.Cookie-import Network.Salvia.Httpd-import Prelude hiding (lookup)-import System.Random-import qualified Data.Map as M-----------------------------------------------------------------------------------{- | A session identifier. Should be unique for every session. -}--newtype SessionID = SID Integer-  deriving (Eq, Ord)--{- | The session data type with polymorphic payload. -}--data Session a = Session {-    sID      :: SessionID  -- ^ A globally unique session identifier.-  , sStart   :: LocalTime  -- ^ The time the session started.-  , sExpire  :: LocalTime  -- ^ The time after which the session is expired.-  , sPayload :: Maybe a    -- ^ The information this session stores.-  } deriving Show--{- | A shared session. -}--type TSession a = TVar (Session a)--{- | A handler that expects a session. -}--type SessionHandler a b = TSession a -> Handler b--{- | Create a new, empty, shared session. -}--mkSession :: SessionID -> LocalTime -> IO (TSession a)-mkSession sid e = do-  s <- now-  atomically $ newTVar $ Session sid s e Nothing-----------------------------------------------------------------------------------{- | A mapping from unique session IDs to shared session variables. -}--type Sessions a = TVar (M.Map SessionID (TSession a))--instance Show SessionID where-  show (SID sid) = show sid--{- | Create a new, empty, store of sessions. -}--mkSessions :: IO (Sessions a)-mkSessions = atomically $ newTVar M.empty-----------------------------------------------------------------------------------{- |-The session handler. This handler will try to return an existing session from-the sessions map based on a session identifier found in the HTTP `cookie`. When-such a session can be found the expiration date will be updated to a number of-seconds in the future. When no session can be found a new one will be created.-A cookie will be set that informs the client of the current session.--}--hSession-  :: Sessions a            -- ^ Map of shared session variables.-  -> Integer               -- ^ Number of seconds to be added to the session expiritation time.-  -> Handler (TSession a)-hSession smap expiration = do--  -- Get the session identifier from an existing cookie or create a new one.-  prev <- getSessionID <$> hGetCookies--  -- Compute current time and expiration time.-  (n, ex) <- lift $ liftM2 (,) now (later expiration)--  -- Either create a new session or try to reuse current one.-  tsession <- -    maybe-    (newSession smap ex)-    (existingSession smap ex n)-    prev--  setSessionCookie tsession ex-  return tsession-----------------------------------------------------------------------------------{--Given the (possible wrong) request cookie, try to recover the existing ---session identifier.--}--getSessionID :: Maybe Cookies -> Maybe SessionID-getSessionID prev = do-  ck  <- prev-  sid <- cookie "sid" ck-  sid' <- safeRead $ value sid-  return (SID sid')-  -{--Generate a fresh, random session identifier using the default system random-generator.--}--genSessionID :: IO SessionID-genSessionID = do-  g <- getStdGen-  let (sid, g') = random g-  setStdGen g'-  return (SID (abs sid))---{--This handler sets the HTTP cookie for the specified session. It will use a-default cookie with an additional `sid' attribute with the session identifier-as value. The session expiration date will be used as the cookie expire field.--}--setSessionCookie :: TSession a -> LocalTime -> Handler ()-setSessionCookie tsession ex = do-  ck <- newCookie ex-  sid <- lift $ liftM sID $ atomReadTVar tsession-  hSetCookies $-    cookies [ck {-      name  = "sid"-    , value = show sid-    }]--{--Handler when no (valid) session is available. Create a new session with a-specified expiration date. The session will be stored in the session map.--}--newSession :: Sessions a -> LocalTime -> Handler (TSession a)-newSession sessions ex = lift $ do--  -- Fresh session identifier.-  sid <- genSessionID--  -- Fresh session.-  session <- mkSession sid ex--  -- Place in session mapping usinf session identifier as key.-  atomModTVar (M.insert sid session) sessions-  return session--{--Handler for existing sessions. Given an existing session identifier lookup a-session from the session map. When no session is available, or the session is-expired, create a new one using the `newSession' function. Otherwise the-expiration date of the existing session is updated.--}--existingSession ::-     Sessions a -> LocalTime -> LocalTime-  -> SessionID -> Handler (TSession a)-existingSession sessions ex n sid = do--  -- Lookup the session in the session map given the session identifier.-  mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)-  case mtsession of--    -- Unrecognized session identifiers are penalised by a fresh session.-    Nothing -> newSession sessions ex-    Just tsession -> do-      expd <- lift $ liftM sExpire (atomReadTVar tsession)-      if expd < n--        -- Session is expired, create a new one.-        then newSession sessions ex--        -- Existing session, update expiration date.-        else lift $ do-          atomModTVar (\s -> s {sExpire = ex}) tsession-          return tsession-
src/Network/Salvia/Handler/VirtualHosting.hs view
@@ -1,34 +1,44 @@-module Network.Salvia.Handler.VirtualHosting (-    hHostRouter-  , hVirtualHosting-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.VirtualHosting where -import Data.Ord+import Data.List.Split import Data.List-import Data.Record.Label-import Network.Protocol.Http+import Data.Maybe import Network.Protocol.Uri+import Network.Protocol.Http import Network.Salvia.Handler.Dispatching-import Network.Salvia.Httpd hiding (hostname)+import Network.Salvia.Interface  {- |-List dispatcher based on the host part of the hostname request header.-Everything not part of the real hostname (like the port number) will be-ignored.+Dispatcher based on the host part of the `hostname' request header. Everything+not part of the real hostname (like the port number) will be ignored. When the+expected hostname starts with a dot (like ".mydomain.com")  this indicates that+all sub-domains of this domain will match as well. -} -hVirtualHosting :: ListDispatcher String a-hVirtualHosting = (hListDispatch disp) . parse+hVirtualHosting :: HttpM Request m => ListDispatcher String m b+hVirtualHosting = hListDispatch (hRequestDispatch hostname (\a -> False `maybe` (match a)))   where-    disp    = hDispatch (hostname % request) cmp-    parse   = map (\(a, b) -> (parseAuthority a, b))-    cmp a b = (==EQ) $ comparing (fmap (lget _host)) a b+  match e f = +    case parseAuthority f of+      Right (Authority _ hst _) -> +        case (e, hst) of+          ('.':_, Hostname (Domain d)) -> filter (not . null) (splitOn "." e) `isSuffixOf` d+          (_,     Hostname d)          -> e == show d+          (_,     RegName r)           -> e == r+          (_,     IP i)                -> e == show i+      _ -> False  {- |-List dispatcher based on the hostname request header. This header field is-parsed and interpreted as an `Authority` field.+Dispatcher based on the port number of the `hostname' request header. When no+port number is available in the hostname header port 80 will be assumed. -} -hHostRouter :: ListDispatcher (Maybe Authority) a-hHostRouter = hListDispatch $ hDispatch (hostname % request) (==)+hPortRouter :: HttpM Request m => ListDispatcher Int m b+hPortRouter = hListDispatch (hRequestDispatch hostname (\a -> False `maybe` (match a)))+  where+  match e f = +    case parseAuthority f of+      Right (Authority _ _ prt) -> fromMaybe 80 prt == e+      _                         -> False
src/Network/Salvia/Handlers.hs view
@@ -1,213 +1,196 @@-module Network.Salvia.Handlers (--  -- * Fundamental protocol handlers.--    -- ** Default handler environments.--      hDefaultEnv-    , hSessionEnv--    -- ** Parse client requests.--    , hParser--    -- ** Print server responses.--    , hPrinter--    -- ** HTTP header banner.+module Network.Salvia.Handlers {- todo doc - client/server assumptions -}+( -    , hBanner+-- * Fundamental protocol handlers. -    -- ** Closing or keeping alive connections.+-- ** Default handler environments. -    , hCloseConn-    , hKeepAlive+  hDefaultEnv+, hEnvNoKeepAlive -    -- ** Enable HTTP HEAD requests.-    -    , hHead+-- ** Parse client requests. -  -- * Error handling and logging.+, hRequestParser+, hResponseParser+, hParser+, readNonEmptyLines -    -- ** Default error handlers.+-- ** Print server responses. -    , hError-    , hCustomError-    , hIOError-    , safeIO+, hResponsePrinter+, hRequestPrinter+, hFlushHeaders+, hFlushHeadersOnly+, hFlushRequestHeaders+, hFlushResponseHeaders+, hFlushQueue -    -- ** Logging of client requests.+-- ** Accessing request and response bodies. -    , hLog-    , hLogWithCounter+, hRawRequestBody+, hRawResponseBody+, hRawBody -    -- ** Fallback handlers.+, hRequestBodyText+, hResponseBodyText+, hBodyText -    , hOr-    , hEither+, hRequestBodyStringUTF8+, hResponseBodyStringUTF8+, hBodyStringUTF8 -    -- ** Request counter.+, hRequestParameters+, hResponseParameters+, hParameters -    , hCounter+-- ** HTTP header banner. -  -- * Redirecting and rewriting.+, hBanner -    -- ** Redirecting the client.+-- ** Closing or keeping alive connections. -    , hRedirect+, hCloseConn+, hKeepAlive -    -- ** Request URI rewriting.+-- ** Enable HTTP HEAD requests. -    , hRewrite-    , hRewriteHost-    , hRewritePath-    , hRewriteExt-    , hWithDir-    , hWithoutDir+, hHead -  -- * File and directory serving.+-- * Error handling and logging. -    -- ** Serve static file resources.+-- ** Default error handlers. -    , hFileResource-    , hFileResourceFilter-    , hResource-    , hUri-    , hFile-    , hFileFilter+, hError+, hCustomError+, hIOError+, hSafeIO -    -- ** Serve directory indices.+-- ** Logging of client requests. -    , hDirectory-    , hDirectoryResource+, hLog+, hDumpRequest+, hDumpResponse -    -- ** Serve file system directory.+-- * Redirecting and rewriting. -    , hFileTypeDispatcher-    , hFileSystem-    , hFileSystemNoIndexes+-- ** Redirecting the client. -    -- ** Enable PUTing resources to the files ystem.+, hRedirect -    , hPut+-- ** Request URI rewriting. -    -- ** Serving CGI scripts.+, hRewrite+, hRewriteHost+, hRewritePath+, hRewriteExt+, hWithDir+, hWithoutDir -    , hCGI+-- * File and directory serving. -  -- * Dispatching.+-- ** Serve static file resources. -    -- ** Custom request dispatchers.+, hFileResource+, hFileResourceFilter+, hResource+, fileMime+, hUri+, hFile+, hFileFilter -    , Dispatcher-    , ListDispatcher-    , hDispatch-    , hListDispatch+-- ** Serve directory indices. -    -- ** Dispatch based on request method.+, hDirectory+, hDirectoryResource -    , hMethod-    , hMethodRouter+-- ** Serve file system directory. -    , hOPTIONS-    , hGET-    , hHEAD-    , hPOST-    , hPUT-    , hDELETE-    , hTRACE-    , hCONNECT+, hFileTypeDispatcher+, hFileSystem+, hFileSystemNoIndexes -    -- ** Dispatch based on request path.+-- ** Enable PUTing resources to the files ystem. -    , hPath-    , hPathRouter-    , hPrefix-    , hPrefixRouter-    , hParameters+, hPutFileSystem+, hPutResource+, hStore -    -- ** Dispatch based on filename extension.+-- ** Support for HTTP ranges. -    , hExtension-    , hExtensionRouter+, Range (..)+, contentRange+, range+, rangeL -    -- ** Dispatch based on host name.+-- ** Serving CGI scripts. -    , hHostRouter-    , hVirtualHosting+, hCGI -  -- * Session and user management.+-- * Dispatching. -    -- ** Cookie handling.+-- ** Custom request dispatchers. -    , hSetCookies-    , hGetCookies-    , newCookie+, Dispatcher+, ListDispatcher+, hDispatch+, hRequestDispatch+, hListDispatch -    -- ** Session management.+-- ** Dispatch based on request method. -    , hSession+, hMethod+, hMethodRouter -    , SessionID-    , Session (..)-    , TSession-    , SessionHandler-    , Sessions+-- ** Dispatch based on request path. -    , mkSessions+, hPath+, hPathRouter+, hPrefix+, hPrefixRouter+, hQueryParameters -    -- ** User management.+-- ** Dispatch based on filename extension. -    , Username-    , Password-    , Action-    , Actions-    , User (..)-    , Users-    , UserDatabase-    , TUserDatabase+, hExtension+, hExtensionRouter -    , UserPayload (..)-    , UserSession-    , TUserSession-    , UserSessionHandler+-- ** Dispatch based on host name. -    , hSignup-    , hLogin-    , hLogout-    , hLoginfo+, hVirtualHosting+, hPortRouter -    , hAuthorized-    , hAuthorizedUser+-- * Cookie management. -    , readUserDatabase+, hSetCookie+, hCookie+, hDelCookie+, hNewCookie+)+where -  ) where+-- todo: cleanup handler exports and export entire modules?  import Network.Salvia.Handler.Banner+import Network.Salvia.Handler.Body import Network.Salvia.Handler.CGI import Network.Salvia.Handler.Close import Network.Salvia.Handler.Cookie-import Network.Salvia.Handler.Counter import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Dispatching import Network.Salvia.Handler.Environment import Network.Salvia.Handler.Error-import Network.Salvia.Handler.ExtensionDispatcher-import Network.Salvia.Handler.Fallback+import Network.Salvia.Handler.Extension import Network.Salvia.Handler.File import Network.Salvia.Handler.FileSystem import Network.Salvia.Handler.Head import Network.Salvia.Handler.Log-import Network.Salvia.Handler.Login-import Network.Salvia.Handler.MethodRouter+import Network.Salvia.Handler.Method import Network.Salvia.Handler.Parser-import Network.Salvia.Handler.PathRouter+import Network.Salvia.Handler.Path import Network.Salvia.Handler.Printer import Network.Salvia.Handler.Put+import Network.Salvia.Handler.Range import Network.Salvia.Handler.Redirect import Network.Salvia.Handler.Rewrite-import Network.Salvia.Handler.Session import Network.Salvia.Handler.VirtualHosting
− src/Network/Salvia/Httpd.hs 
@@ -1,51 +0,0 @@-module Network.Salvia.Httpd (--  -- Httpd.Core.Config-    HttpdConfig (..)-  , defaultConfig--  -- Httpd.Core.Handler-  , Context-  , config-  , request-  , response-  , sock-  , address-  , queue--  , mkContext--  , Handler-  , ResourceHandler-  , UriHandler--  -- Httpd.Core.IO-  , send-  , sendStr-  , sendStrLn-  , sendBs--  , spool-  , spoolBs--  , flushHeaders-  , flushQueue--  , emptyQueue-  , reset--  , contents-  , contentsUtf8-  , uriEncodedPostParamsUTF8--  -- Httpd.Core.Main-  , start--  ) where--import Network.Salvia.Core.Config-import Network.Salvia.Core.Context-import Network.Salvia.Core.Handler-import Network.Salvia.Core.IO-import Network.Salvia.Core.Main-
+ src/Network/Salvia/Impl.hs view
@@ -0,0 +1,14 @@+module Network.Salvia.Impl+( module Network.Salvia.Impl.Config+, module Network.Salvia.Impl.Context+, module Network.Salvia.Impl.Handler+, module Network.Salvia.Impl.Server+)+where++-- import Network.Salvia.Impl.Client+import Network.Salvia.Impl.Config+import Network.Salvia.Impl.Context+import Network.Salvia.Impl.Handler+import Network.Salvia.Impl.Server+
+ src/Network/Salvia/Impl/Config.hs view
@@ -0,0 +1,32 @@+module Network.Salvia.Impl.Config where++import Network.Socket++{- |+The HTTP server configuration contains some network settings the server needs+know before being able to run. +-}++data Config =+  Config+  { hostname  :: String       -- ^ Server hostname.+  , adminMail :: String       -- ^ Server admin email address.+  , listenOn  :: [SockAddr]   -- ^ Address port combinations to listen on.+  , backlog   :: Int          -- ^ TCP backlog.+  }++{- |+The default server configuration sets some safe default values. The server will+by default bind to 0.0.0.0 (`iNADDR_ANY') at port 8080. The default value for+the TCP backlog is 64.+-}++defaultConfig :: Config+defaultConfig =+  Config+  { hostname  = "127.0.0.1"+  , adminMail = "admin@localhost"+  , listenOn  = [SockAddrInet 8080 iNADDR_ANY]+  , backlog   = 64+  }+
+ src/Network/Salvia/Impl/Context.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Salvia.Impl.Context where++import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Interface+import Network.Socket+import System.IO++{- |+A generic handler context that contains all the information needed by the+request handlers to perform their task and to set up a proper response. All the+fields in the context are accessible using the first class labels defined+below. +-}++data Context p = Context+  { _cServerHost  :: String+  , _cAdminMail   :: String+  , _cListenOn    :: [SockAddr]+  , _cRequest     :: Http Request+  , _cResponse    :: Http Response+  , _cRawRequest  :: Http Request+  , _cRawResponse :: Http Response+  , _cSocket      :: Socket+  , _cHandle      :: Handle+  , _cClientAddr  :: SockAddr+  , _cServerAddr  :: SockAddr+  , _cQueue       :: SendQueue+  , _cPayload     :: p+  } deriving (Show)++$(mkLabels [''Context])++-- | The server hostname.+cServerHost :: Context p :-> String++-- | The mail address of the server adminstrator.+cAdminMail :: Context p :-> String++-- | The socket address(es) the server is listening on.+cListenOn :: Context p :-> [SockAddr]++-- | Connection wide payload.+cPayload :: Context p :-> p++-- | The HTTP request header.+cRequest :: Context p :-> Http Request++-- | The HTTP response header.+cResponse :: Context p :-> Http Response++-- | The unaltered HTTP request header as received from a client.+cRawRequest :: Context p :-> Http Request++-- | The plain HTTP response header unaffected by local rewriting.+cRawResponse :: Context p :-> Http Response++-- | Raw socket for connection to the peer.+cSocket :: Context p :-> Socket++-- | File descriptor associated with socket for the connection to the peer.+cHandle :: Context p :-> Handle++-- | Client address.+cClientAddr :: Context p :-> SockAddr++-- | Server address.+cServerAddr :: Context p :-> SockAddr++-- | The queue of send actions.+cQueue :: Context p :-> SendQueue+
+ src/Network/Salvia/Impl/Handler.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE+    FlexibleInstances+  , StandaloneDeriving+  , TypeSynonymInstances+  , UndecidableInstances+  , OverlappingInstances+  , IncoherentInstances+  , MultiParamTypeClasses+  , GeneralizedNewtypeDeriving+  , ScopedTypeVariables+  #-}+module Network.Salvia.Impl.Handler where++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.State+import Data.ByteString.Lazy.UTF8 (fromString, toString)+import Data.Monoid+import Data.Record.Label hiding (get)+import Network.Protocol.Http hiding (hostname)+import Network.Salvia.Handler.Body+import Network.Salvia.Handler.Close+import Network.Salvia.Handler.Printer+import Network.Salvia.Impl.Context+import Network.Salvia.Interface+import Prelude hiding (mod)+import Safe+import qualified Data.ByteString.Lazy as ByteString+import qualified Data.Record.Label as L++newtype Handler p a = Handler { unHandler :: StateT (Context p) IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadState (Context p))++runHandler :: Handler p a -> Context p -> IO (a, Context p)+runHandler h = runStateT (unHandler h)++instance ForkM IO (Handler p) where+  forkM a = get >>= return . fmap fst . runHandler a++instance HttpM Request (Handler p) where+  http st =+    do (a, s) <- runState st <$> getM cRequest+       cRequest =: s >> return a++instance HttpM Response (Handler p) where+  http st =+    do (a, s) <- runState st <$> getM cResponse+       cResponse =: s >> return a++instance RawHttpM Request (Handler p) where+  rawHttp st =+    do (a, s) <- runState st <$> getM cRawRequest+       cRawRequest =: s >> return a++instance RawHttpM Response (Handler p) where+  rawHttp st =+    do (a, s) <- runState st <$> getM cRawResponse+       cRawResponse =: s >> return a++instance HandleQueueM (Handler p) where+  enqueueHandle f = modM cQueue (++[SendAction (f . snd)])++instance SocketQueueM (Handler p) where+  enqueueSock f = modM cQueue (++[SendAction (f . fst)])++instance QueueM (Handler p) where+  dequeue = headMay <$> getM cQueue <* modM cQueue (tailDef [])++instance SendM (Handler p) where+  send        s    = enqueueHandle (\h -> ByteString.hPut h (fromString s))+  sendBs      bs   = enqueueHandle (\h -> ByteString.hPutStr h bs)+  spoolWith   f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . fromString . f . toString)+  spoolWithBs f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . f)++instance SocketM (Handler p) where+  socket = getM cSocket++instance HandleM (Handler p) where+  handle = getM cHandle++instance ClientAddressM (Handler p) where+  clientAddress = getM cClientAddr++instance ServerAddressM (Handler p) where+  serverAddress = getM cServerAddr++instance Monoid a => Monoid (Handler p a) where+  mempty  = mzero >> return mempty+  mappend = mplus++instance Alternative (Handler p) where+  empty = mzero+  (<|>) = mplus++instance MonadPlus (Handler p) where+  mzero =+    do http (status =: BadRequest)+       return (error "mzero/empty")+  a `mplus` b =+    do r <- a+       s <- http (getM status)+       if statusFailure s+         then do response $+                   do status        =: OK+                      contentLength =: (Nothing :: Maybe Integer)+                 emptyQueue >> mzero >> b+         else return r++instance FlushM Response (Handler p) where+  flushHeaders = hFlushHeaders+  flushQueue _ = hFlushQueue++instance FlushM Request (Handler p) where+  flushHeaders = hFlushHeaders+  flushQueue _ = hFlushQueue++instance BodyM Request (Handler p) where+  body = hRawBody++instance BodyM Response (Handler p) where+  body = hRawBody++instance ServerM (Handler p) where+  host   = getM cServerHost+  admin  = getM cAdminMail+  listen = getM cListenOn++instance Contains p (TVar q) => PayloadM p q (Handler p) where+  payload st =+    do pl <- getM cPayload :: Handler p p+       let var = L.get select pl :: TVar q+       liftIO . atomically $+          do q <- readTVar var+             let (s, q') = runState st q+             writeTVar var q'+             return s+
+ src/Network/Salvia/Impl/Server.hs view
@@ -0,0 +1,61 @@+module Network.Salvia.Impl.Server (start) where++import Control.Concurrent.ThreadManager+import Control.Monad.State+import Network.Protocol.Http hiding (accept, hostname)+import Network.Salvia.Impl.Config+import Network.Salvia.Impl.Context +import Network.Salvia.Impl.Handler+import Network.Socket+import System.IO++{- | todo:+Start a webserver with a specific server configuration and default handler. The+server will go into an infinite loop and will repeatedly accept client+connections on the address and port specified in the configuration. For every+connection the specified handler will be executed with the client address and+socket stored in the handler context.+-}++{- todo:+Start a listening TCP server on the specified address/port combination and+handle every connection with a custom handler. Accept connections on the+listening socket and pass execution to the application specific connection+handler.+-}++start :: Config -> Handler p () -> p -> IO ()+start conf handler payload =+  do tm <- make+     forM_ (listenOn conf) $ \(SockAddrInet port addr) ->+       fork tm $+         do inet_ntoa addr >>= \a ->+              putStrLn ("starting listening server on: " ++ a ++ ":" ++ show port)+            s <- socket AF_INET Stream 0+            setSocketOption s ReuseAddr 1+            let sAddr = SockAddrInet port addr+            bindSocket s sAddr+            listen s (backlog conf)+            forever $+              do (sck, cAddr) <- accept s+                 fork tm $+                   do hndl <- socketToHandle sck ReadWriteMode+                      _ <- runHandler handler+                        Context+                          { _cServerHost  = hostname conf+                          , _cAdminMail   = adminMail conf+                          , _cListenOn    = listenOn conf+                          , _cPayload     = payload+                          , _cRequest     = emptyRequest+                          , _cResponse    = emptyResponse+                          , _cRawRequest  = emptyRequest+                          , _cRawResponse = emptyResponse+                          , _cSocket      = sck+                          , _cHandle      = hndl+                          , _cClientAddr  = cAddr+                          , _cServerAddr  = sAddr+                          , _cQueue       = []+                          }+                      return ()+     waitForAll tm+
+ src/Network/Salvia/Interface.hs view
@@ -0,0 +1,236 @@+{- |+This interface module contains all the basic operations to access the server+context. The interface is just of bunch of type classes that allow access to+the request and response objects. Most type classes allow access to the context+information through lifted state computations. To dig deeper into the context+object you would probably want to use the derived /fclabels/ accessors.++Example 1: To get the entire request object:++> do r <- request get  -- Control.Monad.State.get++Example 2: To get the request URI as a string:++> do r <- request (getM uri) -- getM from Data.Record.Label++Example 3: To get the query parameters and the /User-Agent/ header:++> do request $+>      do q <- getM (queryParams . asUri)  -- composed labels using the (.) from Control.Category.+>         u <- header "user-agent"+>         return (q, u)++Example 4: To set the /Content-Type/ and response status and send some string.++> do response $+>      do status =: BadRequest    -- the (=:) operator from Data.Record.Label+>         header "content-type" =: "text/plain"+>    send "hello, world"++-}++{-# LANGUAGE+    UndecidableInstances+  , TypeOperators+  , MultiParamTypeClasses+  , FunctionalDependencies+  , FlexibleContexts+  , FlexibleInstances+  , TypeFamilies+  , IncoherentInstances+  #-}+module Network.Salvia.Interface where++import Control.Concurrent.STM+import Control.Applicative+import Control.Category+import Control.Monad.State hiding (get)+import Data.ByteString.Lazy (ByteString)+import Data.Record.Label+import Network.Protocol.Http+import Network.Socket+import Prelude hiding ((.), id)+import System.IO++-- todo: comment++class ForkM n m where+  forkM :: m a -> m (n a)++-- | The `HttpM' type class indicates is parametrized with the directon+-- (`Request' or `Response') for which the implementation should be able to+-- supply and modify the values. The `http` method allow for running arbitrary+-- state computations over the request or response objects.++class (Applicative m, Monad m) => HttpM dir m where+  http :: State (Http dir) a -> m a++class (Applicative m, Monad m) => RawHttpM dir m where+  rawHttp :: State (Http dir) a -> m a++-- | Stub request and response used to fill in type level gaps for message+-- directions.++forRequest :: Request+forRequest = undefined++forResponse :: Response+forResponse = undefined++-- | Type class alias indicating an HttpM instance for both requests and+-- responses.++class (HttpM Request m, HttpM Response m) => HttpM' m+instance (HttpM Request m, HttpM Response m) => HttpM' m++class (RawHttpM Request m, RawHttpM Response m) => RawHttpM' m+instance (RawHttpM Request m, RawHttpM Response m) => RawHttpM' m++-- | Direction specific aliases for the `http' method.++request :: HttpM Request m => State (Http Request) a -> m a+request = http++response :: HttpM Response m => State (Http Response) a -> m a+response = http++rawRequest :: RawHttpM Request m => State (Http Request) a -> m a+rawRequest = rawHttp++rawResponse :: RawHttpM Response m => State (Http Response) a -> m a+rawResponse = rawHttp++-- | The `SocketM` type class allows access to the raw socket.++class (Applicative m, Monad m) => SocketM m where+  socket :: m Socket++-- | The `HandleM` type class allows access to the file handle, probabaly+-- associated with the socket to the peer.++class (Applicative m, Monad m) => HandleM m where+  handle :: m Handle++-- | The `ClientAddressM` type class gives access to socket address of the+-- client part of the connection.++class (Applicative m, Monad m) => ClientAddressM m where+  clientAddress :: m SockAddr++-- | The `ServerAddressM` type class gives access to socket address of the+-- client part of the connection.++class (Applicative m, Monad m) => ServerAddressM m where+  serverAddress :: m SockAddr++-- | Type class alias indicating an instances for both `ClientAddressM' and+-- `ServerAddressM'.++class (ClientAddressM m, ServerAddressM m) => AddressM' m+instance (ClientAddressM m, ServerAddressM m) => AddressM' m++{- |+The send queue is an abstraction to make sure all data that belongs to the+message body is sent after the response headers have been sent.  Instead of+sending data to client directly over the socket from the context it is+preferable to queue send actions in the context's send queue. The entire send+queue can be flushed to the client at once after the HTTP headers have been+sent at the end of a request handler.+-}++type SendQueue = [SendAction]++data SendAction = SendAction ((Socket, Handle) -> IO ())++instance Show SendAction where+  show _ = "<send action>"++-- | todo: comment:+-- The `QueueM' type class allows for queing actions for sending data values+-- over the wire. Using a queue for collecting send actions instead of directly+-- sending values over the socket allows for a more modular client or server+-- layout.++class (Applicative m, Monad m) => HandleQueueM m where+  enqueueHandle :: (Handle -> IO ()) -> m ()++class (Applicative m, Monad m) => SocketQueueM m where+  enqueueSock :: (Socket -> IO ()) -> m ()++class (Applicative m, Monad m) => QueueM m where+  dequeue :: m (Maybe SendAction)++class (Applicative m, Monad m) => SendM m where++  -- | Enqueue the action of sending one regular Haskell `String' over the wire+  -- to the other endpoint.++  send :: String -> m ()++  -- | Enqueue the action of sending one `ByteString' over the wire to the+  -- other endpoint.++  sendBs :: ByteString -> m ()++  -- | Like the `spool' function but allows a custom filter over the contents.+  -- the wire to the other endpoint.++  spoolWith :: (String -> String) -> Handle -> m ()++  -- | Like the `spoolWith' function but uses a direct `ByteString' filter+  -- which might be more efficient.++  spoolWithBs :: (ByteString -> ByteString) -> Handle -> m ()++-- | Enqueue the action of spooling the entire contents of a file handle over+-- the wire to the other endpoint.++spool :: SendM m => Handle -> m ()+spool = spoolWithBs id++-- | The `FlushM' type class can be used to flush the message headers and the+-- message body directly over the wire to the other endpoint.++class (Applicative m, Monad m) => FlushM dir m where+  flushHeaders :: dir -> m ()+  flushQueue   :: dir -> m ()++class (Applicative m, Monad m) => BodyM dir m where+  body :: dir -> m ByteString++-- | The `ServerM' type class can be used to acesss the static server+-- configuration like the address/port combination the server listens on and+-- the related hostname.++class (Applicative m, Monad m) => ServerM m where+  host   :: m String+  admin  :: m String+  listen :: m [SockAddr]++-- | The `PayloadM' type class provides access to the server payload. The+-- payload can be an arbitrary piece of data that gets shared between all the+-- handlers. Can be used to implement sessions and such. Heterogeneous lists+-- implemented as right associated nested tuples can be used to store multiple+-- pieces of information and still let individual handlers pick out the right+-- thing they need. Picking the right pieces of information from the payload+-- can be done with the `select' function from the `Contains' type class.++class (Applicative m, Monad m, Contains p (TVar q)) => PayloadM p q m | m -> p where+  payload :: State q a -> m a++infixr 5 &+(&) :: a -> b -> (a, b)+(&) a b = (a, b)++class Contains a b where+  select :: a :-> b++instance (a ~ a') => Contains a a' where+  select = id++instance Contains (a, c) a where+  select = label fst (\a (_, b) -> (a, b))++instance (b ~ b', Contains a b') => Contains (c, a) b' where+  select = select . label snd (\b (a, _) -> (a, b))+