packages feed

salvia 0.0.4 → 0.0.5

raw patch · 39 files changed

+652/−573 lines, 39 filesdep +nano-md5dep +template-haskell

Dependencies added: nano-md5, template-haskell

Files

salvia.cabal view
@@ -1,5 +1,5 @@ Name:             salvia-Version:          0.0.4+Version:          0.0.5 Description:      Lightweight Haskell Web Server Framework Synopsis:         Lightweight Haskell Web Server Framework  Category:         Network, Web@@ -14,6 +14,7 @@                   clevercss,                   containers,                   directory,+                  nano-md5,                   encoding,                   filepath,                   hscolour,@@ -22,6 +23,7 @@                   old-locale,                   parsec,                   process,+                  template-haskell >= 2.2,                   random,                   stm,                   time,@@ -30,8 +32,10 @@ Extensions:       CPP HS-Source-Dirs:   src Other-modules:    Misc.Misc,-                  Misc.Terminal-Exposed-modules:  Network.Protocol.Cookie,+                  Misc.Terminal,+                  Data.Record.Label.TH+Exposed-modules:  Data.Record.Label,+                  Network.Protocol.Cookie,                   Network.Protocol.Http,                   Network.Protocol.Mime,                   Network.Protocol.Uri,
+ src/Data/Record/Label.hs view
@@ -0,0 +1,86 @@+module Data.Record.Label (+    Getter, Setter, Modifier+  , Label (..)+  , lmod+  , (%), comp+  , getM, setM, modM+  , bothM+  , enterM, enterMT+  , withM, localM+  , list+  , module Data.Record.Label.TH+  ) where++import Control.Monad.State+import Data.Record.Label.TH++type Getter   a b = a -> b+type Setter   a b = b -> a -> a+type Modifier a b = (b -> b) -> a -> a++data Label a b = Label {+    lget :: Getter a b+  , lset :: Setter a b+  }++lmod :: Label a b -> Modifier a b+lmod l f a = lset l (f (lget l a)) a++infixr 8 %++(%) :: Label t a -> Label b t -> Label b a+a % b = Label (lget a . lget b) (lmod b . lset a)++-- Apply custom `parser' and 'printer' function.++comp :: (b -> c) -> (c -> b) -> Label t b -> Label t c+comp f g (Label a b) = Label (f . a) (\v -> b $ g v)++-- Extend the state monad with support for labels.++getM :: MonadState s m => Label s b -> m b+getM = gets . lget++setM :: MonadState s m => Label s b -> b -> m ()+setM l = modify . lset l++modM :: MonadState s m => Label s b -> (b -> b) -> m ()+modM l = modify . lmod l++-- Run a state computation for a sub element updating this part of the state afterwards.++enterM :: MonadState s m => Label s b -> State b a -> m a+enterM l c = do+  b <- getM l+  let (a, s) = runState c b+  setM l s+  return a++enterMT :: (MonadState s (t m), MonadTrans t, Monad m) => Label s b -> StateT b m a -> t m a+enterMT l c = do+  b <- getM l+  (a, s) <- lift $ runStateT c b+  setM l s+  return a++bothM :: MonadState s m => Label s b -> State b a -> m (b, a)+bothM parent cmp = do+  p <- getM parent+  c <- enterM parent cmp+  return (p, c)++localM :: MonadState s m => Label s b -> m c -> m c+localM l c = do+  k <- getM l+  c' <- c+  setM l k+  return c'++withM :: MonadState s m => Label s b -> State b a -> m c -> m c+withM l c d = localM l (enterM l c >> d)++-- Lift list indexing to a label.++list :: Int -> Label [a] a+list i = Label (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)+
+ src/Data/Record/Label/TH.hs view
@@ -0,0 +1,47 @@+module Data.Record.Label.TH (mkLabels) where++import Control.Monad (liftM)+import Data.Char (toLower, toUpper)+import Language.Haskell.TH ( Body (NormalB)+                           , Clause (Clause)+                           , Con (RecC)+                           , Dec (DataD, FunD)+                           , Exp (AppE, ConE, LamE, RecUpdE, VarE)+                           , Info (TyConI)+                           , Name+                           , Pat (VarP)+                           , Q+                           , mkName+                           , nameBase+                           , reify)+import Language.Haskell.TH.Syntax (VarStrictType)++mkLabels :: [Name] -> Q [Dec]+mkLabels = liftM concat . mapM mkLabels1++mkLabels1 :: Name -> Q [Dec]+mkLabels1 n = do+    i <- reify n+    let cs' = case i of+                 TyConI (DataD _ _ _ cs _) -> cs -- only process data declarations+                 _ -> []+        ls' = [ l | (RecC _ ls) <- cs', l <- ls ] -- we're only interested in labels of record constructors+    return $ map mkLabel ls'++mkLabel :: VarStrictType -> Dec+mkLabel (name, _, _) =+    -- Generate a name for the label:+    -- * If the original selector starts with an _, remove it and make+    --   the next character lowercase.+    -- * Otherwise, add 'l', and make the next character uppercase.+    let n = mkName $ case nameBase name of+                ('_' : c : rest) -> toLower c : rest+                (f : rest)   -> 'l' : toUpper f : rest+                []           -> error "Data.Record.Label.TH: this should not happen."+    in FunD n [Clause [] (NormalB (+           AppE (AppE (ConE (mkName "Label"))+                      (VarE name)) -- getter+                (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter+                      (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))+                                   )) []]+
src/Misc/Misc.hs view
@@ -13,10 +13,9 @@   , intersperseS   , trim   , normalCase-  , intRead+  , safeRead   , now   , later-  , safeRead   , safeHead   , atomModTVar   , atomReadTVar@@ -40,9 +39,6 @@ safeRead s = case reads s of   [(x, "")] -> Just x   _         -> Nothing--intRead :: String -> Maybe Int-intRead = safeRead  -- Conversions.
src/Network/Protocol/Cookie.hs view
@@ -10,15 +10,14 @@   , parseCookies   ) where -import Control.Monad () import Control.Applicative hiding (empty)+import Control.Monad () import Data.Char (toLower) import Data.List (intercalate)-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))-import qualified Data.Map as M- import Misc.Misc (intersperseS, (@@), trim) import Network.Protocol.Uri (URI)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))+import qualified Data.Map as M  -- For more information: -- http://www.ietf.org/rfc/rfc2109.txt
src/Network/Protocol/Http.hs view
@@ -1,46 +1,41 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}  module Network.Protocol.Http(      Status (..)   , Method (..)   , methods-  , Version (..)+  , Version   , Headers-  , Direction (..)-  , Message (..)+  , Direction+  , Message +  , major+  , minor+  , method+  , uri+  , status+  , direction+  , version+  , headers+  , body+   , utf8   , http10   , http11   , emptyRequest   , emptyResponse -  , method-  , setMethod-  , uri-  , setUri-  , modUri-  , status-  , setStatus-  , setVersion-  , setBody-  , modBody-  , header-  , setHeader-  , modHeader-  , getLocation-  , getHost-  , getContentLength-  , getKeepAlive-  , getCookie-  , setContentType-  , setContentLength-  , setLocation-  , setDate-  , setServer-  , setCookie   , normalizeHeader+  , header+  , contentLength+  , keepAlive+  , cookie+  , location+  , contentType+  , date+  , server+  , hostname    , pRequest   , pResponse@@ -59,14 +54,13 @@ import Data.Char import Data.List (intercalate) import Data.Maybe (fromMaybe)+import Data.Record.Label+import Misc.Misc+import Network.Protocol.Uri (URI, mkURI, pUriReference, parseURI) import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) import qualified Data.Bimap as Bm import qualified Data.Map as M -import Misc.Misc-import Network.Protocol.Uri (URI, mkURI, pUriReference)-import Network.Protocol.Cookie ()- -------- HTTP message data-types ----------------------------------------------  data Status =@@ -107,111 +101,106 @@ methods :: [Method] methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT] -data Version = Version {major :: Int, minor :: Int}-type Headers = M.Map String String+data Version = Version {_major :: Int, _minor :: Int} +type HeaderKey   = String+type HeaderValue = String+type Headers     = M.Map HeaderKey HeaderValue+ data Direction =-    Request  {_method :: Method, _uri :: URI}-  | Response {_status :: Status}+    Request  {__method :: Method, __uri :: URI}+  | Response {__status :: Status}  data Message =   Message {-    direction :: Direction-  , version :: Version-  , headers :: Headers-  , body :: String+    _direction :: Direction+  , _version   :: Version+  , _headers   :: Headers+  , _body      :: String   } -utf8 :: String-utf8 = "utf-8"---------- HTTP message creation and alteration ------------------------------------- Create HTTP versions.-http10, http11 :: Version-http10 = Version 1 0-http11 = Version 1 1--emptyRequest :: Message-emptyRequest = Message (Request GET (mkURI)) http11 M.empty ""--emptyResponse :: Message-emptyResponse = Message (Response OK) http11 M.empty ""--method :: Message -> Method-method = _method . direction--setMethod :: Method -> Message -> Message-setMethod e m = m { direction = Request e (uri m) }--uri :: Message -> URI-uri = _uri . direction--setUri :: URI -> Message -> Message-setUri u m = m { direction = Request (method m) u }--modUri :: (URI -> URI) -> Message -> Message-modUri f m = setUri (f $ uri m) m+$(mkLabels [''Version, ''Direction, ''Message]) -status :: Message -> Status-status = _status . direction+major     :: Label Version   Int+minor     :: Label Version   Int+body      :: Label Message   String+headers   :: Label Message   Headers+version   :: Label Message   Version+direction :: Label Message   Direction+_status   :: Label Direction Status+_uri      :: Label Direction URI+_method   :: Label Direction Method -setStatus :: Status -> Message -> Message-setStatus s m = m { direction = Response s }+-- Public labels based on private labels. -setVersion :: Version -> Message -> Message-setVersion v m = m { version = v }+method :: Label Message Method+method = _method % direction -setBody :: String -> Message -> Message-setBody b m = m { body = b }+uri :: Label Message URI+uri = _uri % direction -modBody :: (String -> String) -> Message -> Message-modBody f m = setBody (f $ body m) m+status :: Label Message Status+status = _status % direction -header :: String -> Message -> String-header k = maybe "" id . M.lookup (normalizeHeader k) . headers+-- More advanced labels. -setHeader :: String -> String -> Message -> Message-setHeader k a (Message r v h b) = Message r v (M.insert (normalizeHeader k) a h) b+normalizeHeader :: String -> String+normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-') -modHeader :: String -> (String -> String) -> Message -> Message-modHeader k f m = setHeader k (f $ header k m) m+header :: HeaderKey -> Label Message HeaderValue+header key =+  Label {+    lget = maybe "" id . M.lookup (normalizeHeader key) . lget headers+  , lset = lmod headers . M.insert (normalizeHeader key)+  } -getLocation :: Message -> String-getLocation = header "Location"+contentLength :: Label Message (Maybe Integer)+contentLength = comp safeRead (maybe "" show) (header "Content-Length") -getHost :: Message -> String-getHost = header "Host"+keepAlive :: Label Message (Maybe Integer)+keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive") -getContentLength :: Message -> Maybe Int-getContentLength = intRead . header "Content-Length"+cookie :: Label Message String+cookie =+  Label {+    lget = lget (header "Cookie")+  , lset = lset (header "Set-Cookie")+  } -getKeepAlive :: Message -> Maybe Int-getKeepAlive = intRead . header "Keep-Alive"+location :: Label Message (Maybe URI)+location =+  Label {+    lget = parseURI . lget (header "Location")+  , lset = lset (header "Location") . maybe "" show+  } -getCookie :: Message -> String-getCookie = header "Cookie"+contentType :: Label Message (String, Maybe String)+contentType = comp pa pr (header "Content-Length")+  where pr (t, c) = t ++ maybe "" ("; charset="++) c+        pa = error "no getter for contentType yet" -setContentType :: String -> Maybe String -> Message -> Message-setContentType t c = setHeader "Content-Type" (t ++ maybe "" ("; charset="++) c)+date :: Label Message String+date = header "Date" -setContentLength :: Num a => a -> Message -> Message-setContentLength l = setHeader "Content-Length" (show l)+hostname :: Label Message String+hostname = header "Host" -setLocation :: URI -> Message -> Message-setLocation l = setHeader "Location" (show l)+server :: Label Message String+server = header "Server" -setDate :: String -> Message -> Message-setDate d = setHeader "Date" d+-- Create HTTP versions.+http10, http11 :: Version+http10 = Version 1 0+http11 = Version 1 1 -setServer :: String -> Message -> Message-setServer n  = setHeader "Server" n+emptyRequest :: Message+emptyRequest = Message (Request GET (mkURI)) http11 M.empty "" -setCookie :: String -> Message -> Message-setCookie c = setHeader "Set-Cookie" c+emptyResponse :: Message+emptyResponse = Message (Response OK) http11 M.empty "" -normalizeHeader :: String -> String-normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-')+utf8 :: String+utf8 = "utf-8"  -------- HTTP message parsing ------------------------------------------------- @@ -279,7 +268,7 @@   concat [show m, " ", show u, " ", showVersion v, lf, showHeaders hs, lf, lf]  instance Show Message where-  show m = concat [showMessageHeader m, body m]+  show m = concat [showMessageHeader m, lget body m]  -------- status code mappings -------------------------------------------------
src/Network/Protocol/Uri.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}+ module Network.Protocol.Uri ( -    URI (..)+    URI   , Scheme   , IPv4-  , Label   , Domain   , RegName   , Port@@ -13,9 +14,9 @@   , UserInfo   , PathSegment   , Parameters-  , Path (..)-  , Host (..)-  , Authority (..)+  , Path+  , Host+  , Authority    , encode   , decode@@ -30,34 +31,21 @@   , mkHost   , mkPort +  , absolute+  , segments+  , domain+  , regname+  , ipv4+  , userinfo+  , host+  , port+  , relative   , scheme   , authority   , path   , query   , fragment-  , userinfo-  , host-  , port-  , domains-  , pathSegments -  , setScheme-  , setAuthority-  , setPath-  , setQuery-  , setFragment-  , setUserinfo-  , setHost-  , setPort--  , modScheme-  , modAuthority-  , modPath-  , modQuery-  , modUserinfo-  , modHost-  , modPort-   , parseURI   , parseAbsoluteURI   , parseAuthority@@ -74,10 +62,8 @@   , queryParams    , extension-  , setExtension-  , modExtension -  , relative+  , mkPathRelative   , mimetype   , normalize   , jail@@ -90,18 +76,17 @@ import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit) import Data.List (intercalate, isPrefixOf) import Data.Maybe (mapMaybe, fromJust)-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))-import System.FilePath.Posix-+import Data.Record.Label+import Misc.Misc (eitherToMaybe, (@@), bool, pMaybe, split) import Network.Protocol.Mime-import Misc.Misc+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 Label       = String-type Domain      = [Label]+type Domain      = [String] type RegName     = String type Port        = Int type Query       = String@@ -118,15 +103,15 @@   deriving Eq  data Host =-    Hostname { _domain  :: Domain }-  | RegName  { _regname :: String }-  | IPv4     { _ipv4    :: IPv4   }+    Hostname { __domain  :: Domain }+  | RegName  { __regname :: String }+  | IPv4     { __ipv4    :: IPv4   }   deriving Eq  data Authority = Authority {-    _userinfo :: UserInfo-  , _host     :: Host-  , _port     :: Port+    __userinfo :: UserInfo+  , __host     :: Host+  , __port     :: Port   }   deriving Eq @@ -134,20 +119,69 @@     _relative  :: Bool   , _scheme    :: Scheme   , _authority :: Authority-  , _path      :: Path-  , _query     :: Query+  , __path     :: Path+  , __query     :: Query   , _fragment  :: Fragment   }   deriving Eq -{--testUri0 :: URI-testUri0 = fromJust $ parseURI "http://sebas@hs.spugium.net:8080/wiki/first%20section/chapter-2;pdf?additional=vars"+$(mkLabels [''Path, ''Host, ''Authority, ''URI]) -testUri1 :: URI-testUri1 = fromJust $ parseURI "http://cs.uu.nl/docs/../docs/vakken/../vakken/"--}+_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 {+    lget = decode . lget _query+  , lset = lset _query . encode+  }++host =+  Label {+    lget = show . lget (_host % authority)+  , lset = lset (_host % authority) . fromJust . parseHost+  }++path =+  Label {+    lget = decode . show . lget _path+  , lset = lset _path . fromJust . parsePath . encode+  }++-- testUri0 :: URI+-- testUri0 = fromJust $ parseURI "http://sebas@hs.spugium.net:8080/wiki/first%20section/chapter-2.pdf?additional=vars"++-- testUri1 :: URI+-- testUri1 = fromJust $ parseURI "http://cs.uu.nl/docs/../docs/vakken/../vakken/"+ -------[ creating, selection and modifying URIs ]------------------------------  -- pseudo constructors for `empty values'@@ -179,84 +213,6 @@ mkPort :: Port mkPort = (-1) --- getter functions-scheme :: URI -> Scheme-scheme = _scheme--authority :: URI -> String-authority = show . _authority--path :: URI -> FilePath-path = decode . show . _path--query :: URI -> Query-query = decode . _query--fragment :: URI -> Fragment-fragment = _fragment--userinfo :: URI -> UserInfo-userinfo = _userinfo . _authority--host :: URI -> String-host = show . _host . _authority--port :: URI -> Port-port = _port . _authority--domains :: URI -> Domain-domains = _domain . _host . _authority--pathSegments :: URI -> [PathSegment]-pathSegments = _segments . _path ---- setter functions-setScheme :: Scheme -> URI -> URI-setScheme s u = u { _scheme = s }--setAuthority :: String -> URI -> URI-setAuthority a u = u { _authority = fromJust $ parseAuthority a }--setPath :: String -> URI -> URI-setPath p u = u { _path = fromJust $ parsePath p }--setQuery :: Query -> URI -> URI-setQuery q u = u { _query = q }--setFragment :: Fragment -> URI -> URI-setFragment q u = u { _fragment  = q }--setUserinfo :: UserInfo -> URI -> URI-setUserinfo i u = u { _authority = (_authority u) { _userinfo = i }}--setHost :: String -> URI -> URI-setHost h u = u { _authority = (_authority u) { _host = fromJust $ parseHost h }}--setPort :: Port -> URI -> URI-setPort p u = u { _authority = (_authority u) { _port = p }}---- modifier functions-modScheme :: (Scheme -> Scheme) -> URI -> URI-modScheme f u = setScheme (f $ scheme u) u--modAuthority :: (String -> String) -> URI -> URI-modAuthority f u = setAuthority (f $ authority u) u--modPath :: (String -> String) -> URI -> URI-modPath f u = setPath (f $ encode $ path u) u--modQuery :: (Query -> Query) -> URI -> URI-modQuery f u = setQuery (f $ query u) u--modUserinfo :: (UserInfo -> UserInfo) -> URI -> URI-modUserinfo f u = setUserinfo  (f $ userinfo u) u--modHost :: (String -> String) -> URI -> URI-modHost f u = setHost (f $ host u) u--modPort :: (Port -> Port) -> URI -> URI-modPort f u = setPort (f $ port u) u- -------[ path encoding and decoding ]------------------------------------------  encode :: String -> String@@ -448,7 +404,7 @@   ,     (pure                <$>                                digit)   ] -pRegName :: GenParser Char st Label+pRegName :: GenParser Char st String pRegName = concat <$> many1 (       (pure <$> pUnreserved)   <|>           pPctEncoded@@ -459,7 +415,7 @@ pHostname :: GenParser Char st Domain pHostname = sepBy (option "" pDomainlabel) (string ".") -pDomainlabel :: GenParser Char st Label+pDomainlabel :: GenParser Char st String pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-")  -- 3.2.3.  Port@@ -545,52 +501,54 @@   <$> sepBy ((,)   <$> many (noneOf "=&")   <*> pMaybe (char '='-   *> many (noneOf "&")))+   *> (translateParam <$> many (noneOf "&"))))       (char '&')  parseQueryParams :: String -> Maybe Parameters parseQueryParams = eitherToMaybe . parse pQueryParams  ""  queryParams :: URI -> Parameters-queryParams = maybe [] id . parseQueryParams . query+queryParams = maybe [] id . parseQueryParams . lget query --------[ filename path utilities ]---------------------------------------------+-- Translate special characters in a parameter.+translateParam :: String -> String+translateParam []       = []+translateParam ('+':xs) = ' ' : translateParam xs+translateParam (x:xs)   = x   : translateParam xs -extension :: URI -> Maybe String-extension u = do-  lst <- safeLast . _segments . _path $ u-  guardMaybe (elem '.' lst)-  return $ withReverse (takeWhile (/='.')) lst+-------[ filename path utilities ]--------------------------------------------- -setExtension :: Maybe String -> URI -> URI-setExtension e u =-  let ex = maybe "" ('.':) e in-  (\f -> modPath (\p -> f p ++ ex) u)-  $ maybe id (const $ withReverse (tail . dropWhile (/='.')))-    (extension u)+mkPathRelative :: FilePath -> FilePath+mkPathRelative = dropWhile (=='/') -modExtension :: (String -> String) -> URI -> URI-modExtension f u = setExtension (f `fmap` extension u) u+-- Generate a label for the filename extension. -relative :: URI -> URI-relative = modPath (dropWhile (=='/'))+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 :: URI -> Maybe String-mimetype u = extension u >>= mime+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 absolute $ intercalate "/" $ norm+normalize p = fixAbs absolut $ intercalate "/" $ norm   where     fixAbs True          = ('/':)     fixAbs False         = id-    absolute             = head p == '/'+    absolut              = head p == '/'     norm                 = fixp False $ split '/' p     fixp False xs        = let ys = merge xs in fixp (xs == ys) ys     fixp True  xs        = xs
src/Network/Salvia/Advanced/CleverCSS.hs view
@@ -4,15 +4,14 @@   , hParametrizedCleverCSS   ) where -import Text.CSS.CleverCSS (cleverCSSConvert)-+import Network.Protocol.Uri (Parameters) import Network.Salvia.Handlers.ExtensionDispatcher (hExtension)+import Network.Salvia.Handlers.Fallback (hOr) import Network.Salvia.Handlers.File (hFile, hFileFilter)-import Network.Salvia.Handlers.Rewrite (hRewriteExt) import Network.Salvia.Handlers.PathRouter (hParameters)-import Network.Salvia.Handlers.Fallback (hOr)-import Network.Protocol.Uri (Parameters)+import Network.Salvia.Handlers.Rewrite (hRewriteExt) import Network.Salvia.Httpd (Handler)+import Text.CSS.CleverCSS (cleverCSSConvert)  hFilterCSS :: Handler () -> Handler () -> Handler () hFilterCSS cssfilter handler = do@@ -21,12 +20,10 @@     handler  hCleverCSS :: Handler ()-hCleverCSS = do-  params <- hParameters-  hParametrizedCleverCSS params+hCleverCSS = hParameters >>= hParametrizedCleverCSS  hParametrizedCleverCSS :: Parameters -> Handler () hParametrizedCleverCSS p = do-  hRewriteExt ('c':) (hFileFilter convert)+  hRewriteExt (fmap ('c':)) (hFileFilter convert)   where convert = either id id . flip (cleverCSSConvert "") (map (fmap $ maybe "" id) p)
src/Network/Salvia/Advanced/ExtendedFileSystem.hs view
@@ -1,17 +1,20 @@ module Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem) where -import Network.Salvia.Handlers.File (hFile)-import Network.Salvia.Handlers.Directory (hDirectory)+import Network.Salvia.Advanced.CleverCSS (hFilterCSS, hCleverCSS)+import Network.Salvia.Advanced.HsColour (hHighlightHaskell, hHsColour)+import Network.Salvia.Handlers.Directory (hDirectoryResource)+import Network.Salvia.Handlers.File (hFileResource) import Network.Salvia.Handlers.FileSystem (hFileTypeDispatcher)+import Network.Salvia.Handlers.Rewrite (hWithDir) import Network.Salvia.Httpd (Handler)-import Network.Salvia.Advanced.HsColour (hHighlightHaskell, hHsColour)-import Network.Salvia.Advanced.CleverCSS (hFilterCSS, hCleverCSS)  hExtendedFileSystem :: FilePath -> Handler () hExtendedFileSystem dir =-  hFileTypeDispatcher dir-    hDirectory-    (hHighlightHaskell hHsColour-      $ hFilterCSS hCleverCSS-      $ hFile)+    hFileTypeDispatcher dir+    hDirectoryResource+  $ \r -> hHighlightHaskell (hHsColour r)+  $ hWithDir dir+  $ hFilterCSS hCleverCSS+  $ hFileResource r+
src/Network/Salvia/Advanced/HsColour.hs view
@@ -6,11 +6,11 @@   , defaultStyleSheet   ) where +import Data.Record.Label import Language.Haskell.HsColour.CSS-+import Network.Protocol.Http (contentType, utf8) import Network.Salvia.Handlers.ExtensionDispatcher import Network.Salvia.Handlers.File-import Network.Protocol.Http (setContentType, utf8) import Network.Salvia.Httpd  hHighlightHaskell :: Handler () -> Handler () -> Handler ()@@ -19,20 +19,19 @@     (Just "hs",  highlighter)   , (Just "lhs", highlighter)   , (Just "ag",  highlighter)-  ] +  ] -hHsColour :: Handler ()+hHsColour :: ResourceHandler () hHsColour = hHsColourCustomStyle (Left defaultStyleSheet)  -- Left means direct inclusion of stylesheet, right means link to external -- stylesheet. -hHsColourCustomStyle :: Either String String -> Handler ()-hHsColourCustomStyle style = do+hHsColourCustomStyle :: Either String String -> ResourceHandler ()+hHsColourCustomStyle style r = do   sendStr (either id makeStyleLink style)-  hFileFilter (hscolour False True "")-  modResponse-    $ setContentType ("text/html") (Just utf8)+  hFileResourceFilter (hscolour False True "") r+  setM (contentType % response) ("text/html", Just utf8)  makeStyleLink :: String -> String makeStyleLink css = "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ css ++ "\"></link>"
src/Network/Salvia/Core/Handler.hs view
@@ -1,27 +1,32 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}  module Network.Salvia.Core.Handler (     SendAction   , SendQueue   , Context (..)-  , makeContext +  , config+  , request+  , response+  , sock+  , address+  , queue++  , mkContext+   , Handler   , ResourceHandler   , UriHandler-  , putRequest, putResponse, putQueue-  , modRequest, modResponse, modQueue-  , withRequest, withResponse   ) where  import Control.Applicative (Applicative, pure, (<*>))-import Control.Monad.State (StateT, ap, modify, gets)-import Network.Socket (SockAddr)-import System.IO--import Network.Salvia.Core.Config+import Control.Monad.State (StateT, ap)+import Data.Record.Label import Network.Protocol.Http (Message, emptyRequest, emptyResponse) import Network.Protocol.Uri (URI)+import Network.Salvia.Core.Config+import Network.Socket (SockAddr)+import System.IO  -------- single request/response context -------------------------------------- @@ -30,29 +35,32 @@  data Context =   Context {-  -- | The HTTP server configuration.-    config   :: HttpdConfig-  -- | The HTTP request header.-  , request  :: Message-  -- | The HTTP response header.-  , response :: Message-  -- | The socket handle for the connection with the client.-  , sock     :: Handle-  -- | The client addres.-  , address  :: SockAddr-  -- | The queue of send actions.-  , queue    :: SendQueue+    _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])++queue    :: Label Context SendQueue+address  :: Label Context SockAddr+sock     :: Label Context Handle+response :: Label Context Message+request  :: Label Context Message+config   :: Label Context HttpdConfig+ -- Create and empty server context.-makeContext :: HttpdConfig -> SockAddr -> Handle -> Context-makeContext c a s = Context {-    config   = c-  , request  = emptyRequest-  , response = emptyResponse  -- 200 OK, by default.-  , sock     = s-  , address  = a-  , queue    = []+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    = []   }  -------- request handlers -----------------------------------------------------@@ -66,36 +74,4 @@ instance Applicative (StateT Context IO) where   pure  = return   (<*>) = ap---- Domain specific setters and modifiers.--putRequest :: Message -> Handler ()-putRequest  r = modify (\m -> m { request  = r })--modRequest :: (Message -> Message) -> Handler ()-modRequest  f = gets request  >>= putRequest  . f--putResponse :: Message -> Handler ()-putResponse r = modify (\m -> m { response = r })--modResponse :: (Message -> Message) -> Handler ()-modResponse f = gets response >>= putResponse . f--putQueue :: SendQueue -> Handler ()-putQueue    q = modify (\m -> m { queue = q })--modQueue :: (SendQueue -> SendQueue) -> Handler ()-modQueue    f = gets queue >>= putQueue . f---- Execute handlers in a modified environment, but restore the original state.--- This is comparable to the `local' function from the Reader monad.-withModified :: (Monad m) => m d -> (t -> m a) -> (d -> m b) -> t -> m c -> m c-withModified get m put f h =-  do { o <- get ; m f ; r <- h ; put o ; return r }--withRequest :: (Message -> Message) -> Handler a -> Handler a-withRequest = withModified (gets request) modRequest putRequest--withResponse :: (Message -> Message) -> Handler a -> Handler a-withResponse = withModified (gets response) modResponse putResponse
src/Network/Salvia/Core/IO.hs view
@@ -26,26 +26,26 @@ import Control.Monad.State import Data.Encoding (decodeLazy) import Data.Encoding.UTF8-import System.IO-import qualified Data.ByteString.Lazy as B-import qualified System.IO.UTF8 as U-+import Data.Record.Label import Network.Protocol.Http import Network.Protocol.Uri (Parameters, parseQueryParams, decode) import Network.Salvia.Core.Handler+import System.IO+import qualified Data.ByteString.Lazy as B+import qualified System.IO.UTF8 as U  -------------------------------------------------------------------------------  -- Send the response header to the socket. sendHeaders :: Handler () sendHeaders = do-  r <- gets response-  s <- gets sock +  r <- getM response+  s <- getM sock    lift $ hPutStr s (showMessageHeader r)  -- Queue a potential send action in the send queue. send :: SendAction -> Handler ()-send f = modify (\m -> m { queue = (queue m) ++ [f] })+send f = modM queue (++[f]) -- modify (\m -> m { queue = (queue m) ++ [f] })  -- Queue a String for sending. sendStr, sendStrLn :: String -> Handler ()@@ -90,12 +90,12 @@  -- Reset the send queue. emptyQueue :: Handler ()-emptyQueue = putQueue []+emptyQueue = setM queue []  -- Reset both the send queue and the generated response. reset :: Handler () reset = do-  putResponse emptyResponse+  setM response emptyResponse   emptyQueue  {- |@@ -111,13 +111,12 @@  contents :: Handler (Maybe B.ByteString) contents = do-  r <- gets request-  s <- gets sock-  let len = getContentLength r-      kpa = getKeepAlive     r+  len <- getM (contentLength % request)+  kpa <- getM (keepAlive     % request)+  s   <- getM sock   lift $     case (kpa, len) of-      (_,       Just n)  -> liftM Just (B.hGet s n)+      (_,       Just n)  -> liftM Just (B.hGet s (fromIntegral n))       (Nothing, Nothing) -> liftM Just (B.hGetContents s)       _                  -> return Nothing
src/Network/Salvia/Core/Main.hs view
@@ -1,9 +1,8 @@ module Network.Salvia.Core.Main (start) where  import Control.Monad.State- import Network.Salvia.Core.Config (listenAddr, listenPort, backlog, HttpdConfig)-import Network.Salvia.Core.Handler (Handler, makeContext)+import Network.Salvia.Core.Handler (Handler, mkContext) import Network.Salvia.Core.Network (server)  -------- HTTP deamon implementation -------------------------------------------@@ -23,5 +22,5 @@   where     tcpHandler handle addr =        fst `liftM` runStateT httpHandler-        (makeContext config addr handle)+        (mkContext config addr handle)
src/Network/Salvia/Core/Network.hs view
@@ -1,7 +1,6 @@ module Network.Salvia.Core.Network where  import Control.Concurrent (forkIO)--- import Control.Exception (try) import Control.Monad import Network.Socket import System.IO
src/Network/Salvia/Handlers/Banner.hs view
@@ -1,13 +1,13 @@ module Network.Salvia.Handlers.Banner (hBanner) where  import Control.Monad.State+import Data.Record.Label import Data.Time.Clock (getCurrentTime)-import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime) import Data.Time.Format (formatTime)-import System.Locale (defaultTimeLocale)--import Network.Salvia.Httpd+import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime) import Network.Protocol.Http+import Network.Salvia.Httpd+import System.Locale (defaultTimeLocale)  -- | The 'hBanner' handler adds the current date-/timestamp and a custom server -- name to the response headers.@@ -15,12 +15,12 @@ hBanner ::      String     -- ^ The HTTP server name.   -> Handler ()-hBanner server = do-  date <- lift $ do+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-  modResponse-    $ setDate   date-    . setServer server+  enterM response $ do+    setM date   dt+    setM server sv
src/Network/Salvia/Handlers/CGI.hs view
@@ -1,17 +1,16 @@ module Network.Salvia.Handlers.CGI (hCGI) where  import Control.Monad.State+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia.Httpd import System.IO import System.Process (runProcess, waitForProcess) -import Network.Salvia.Httpd-import Network.Protocol.Http- hCGI :: FilePath -> Handler () hCGI name = do-  modResponse-    $ setStatus OK-  h <- gets sock+  setM (status % response) OK+  h <- getM sock   lift $ do     p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)     waitForProcess p
src/Network/Salvia/Handlers/Cookie.hs view
@@ -7,26 +7,26 @@  import Control.Applicative hiding (empty) import Control.Monad.State+import Data.Record.Label import Data.Time.Format import Data.Time.LocalTime-import System.Locale (defaultTimeLocale)-+import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires)+import Network.Protocol.Http (cookie) import Network.Salvia.Httpd-import Network.Protocol.Cookie-import Network.Protocol.Http (getCookie, setCookie)+import System.Locale (defaultTimeLocale)  hSetCookies :: Cookies -> Handler ()-hSetCookies = modResponse . setCookie . showCookies+hSetCookies = setM (cookie % response) . showCookies  hGetCookies :: Handler (Maybe Cookies)-hGetCookies = parseCookies <$> getCookie <$> gets request+hGetCookies = parseCookies <$> getM (cookie % request)  -- Convenient method for creating cookies that expire in the near future and -- are bound to the domain and port this server runs on. The path will be -- locked to root. newCookie :: LocalTime -> Handler Cookie newCookie expire = do-  httpd <- gets config+  httpd <- getM config   return $ empty {       path    = Just "/" --  , domain  = Just $ '.' : hostname httpd
src/Network/Salvia/Handlers/Counter.hs view
@@ -1,8 +1,7 @@ module Network.Salvia.Handlers.Counter (hCounter) where -import Control.Monad.State import Control.Concurrent.STM-+import Control.Monad.State import Network.Salvia.Httpd  hCounter :: TVar Int -> Handler ()
src/Network/Salvia/Handlers/Default.hs view
@@ -1,8 +1,7 @@ module Network.Salvia.Handlers.Default (hDefault) where -import System.IO import Control.Concurrent.STM-+import Network.Protocol.Http import Network.Salvia.Handlers.Banner import Network.Salvia.Handlers.Counter import Network.Salvia.Handlers.Error@@ -12,15 +11,14 @@ import Network.Salvia.Handlers.Printer import Network.Salvia.Handlers.Session import Network.Salvia.Httpd-import Network.Protocol.Http+import System.IO -hDefault :: TVar Int -> Sessions a -> SessionHandler a () -> Handler ()+hDefault :: Show a => TVar Int -> Sessions a -> SessionHandler a () -> Handler () hDefault count sessions handler = do   hBanner "salvia-httpd"-  hParser onerror-    $ hHead $ do-      session <- hSession sessions 300-      handler session+  hParser onerror $ do+    session <- hSession sessions 300+    hHead $ handler session   hPrinter   hLog count stdout   hCounter count
src/Network/Salvia/Handlers/Directory.hs view
@@ -5,35 +5,35 @@  import Control.Monad.State import Data.List (sort)-import System.Directory (doesDirectoryExist, getDirectoryContents)--import Network.Salvia.Httpd-import Network.Salvia.Handlers.Redirect-import Network.Salvia.Handlers.File (hResource)-import Network.Protocol.Http-import Network.Protocol.Uri (path, modPath)+import Data.Record.Label import Misc.Misc (bool)+import Network.Protocol.Http+import Network.Protocol.Uri (path)+import Network.Salvia.Handlers.File (hResource)+import Network.Salvia.Handlers.Redirect+import Network.Salvia.Httpd+import System.Directory (doesDirectoryExist, getDirectoryContents)  hDirectory :: Handler () hDirectory = hResource hDirectoryResource  hDirectoryResource :: ResourceHandler () hDirectoryResource dirName = do-  req <- gets request-  if (null $ path $ uri req) || (last $ path $ uri req) /= '/'-   then hRedirect (modPath (++"/") $ uri req)+  (u, p) <- bothM (uri % request) (getM path)+  if (null p) || last p /= '/'+   then hRedirect (lmod path (++"/") u)    else dirHandler dirName  dirHandler:: ResourceHandler () dirHandler dirName = do-  req <- gets request+  p <- getM (path % uri % request)   filenames <- lift $ getDirectoryContents dirName   processed <- lift $ mapM (processFilename dirName) (sort filenames)-  let b = listing (path $ uri req) processed-  modResponse-    $ setContentType   "text/html" Nothing-    . setContentLength (length b)-    . setStatus OK+  let b = listing p processed+  enterM response $ do+    setM contentType ("text/html", Nothing)+    setM contentLength (Just $ fromIntegral $ length b)+    setM status OK   sendStr b  -- Add trailing slash to a directory name.
src/Network/Salvia/Handlers/Dispatching.hs view
@@ -5,16 +5,15 @@   , hListDispatch   ) where -import Control.Monad.State-+import Data.Record.Label import Network.Salvia.Httpd  type Dispatcher     a b = a -> Handler b   -> Handler b -> Handler b type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b -hDispatch :: (Show c, Show a) => (Context -> c) -> (a -> c -> Bool) -> Dispatcher a b+hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b hDispatch f match a handler _default = do-  ctx <- gets f+  ctx <- getM f   if a `match` ctx     then handler     else _default
src/Network/Salvia/Handlers/Error.hs view
@@ -5,11 +5,11 @@   , safeIO   ) where -import System.IO.Error- import Control.Monad.State-import Network.Salvia.Httpd+import Data.Record.Label import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO.Error  {- | The 'hError' handler enables the creation of a default style of error responses@@ -27,9 +27,9 @@   -> String     -- ^ Custom error message.   -> Handler () hCustomError e m = do-  modResponse-    $ setStatus e-    . setContentType "text/plain" Nothing+  enterM response $ do+    setM status e+    setM contentType ("text/plain", Nothing)   sendStr m  -- | Map IO errors to a default style error response.
src/Network/Salvia/Handlers/ExtensionDispatcher.hs view
@@ -3,13 +3,14 @@   , hExtensionRouter   ) where -import Network.Salvia.Httpd (request)+import Data.Record.Label import Network.Protocol.Http (uri)-import Network.Protocol.Uri (extension)+import Network.Protocol.Uri (extension, path) import Network.Salvia.Handlers.Dispatching+import Network.Salvia.Httpd (request)  hExtension :: Dispatcher (Maybe String) a-hExtension = hDispatch (extension . uri . request) (==)+hExtension = hDispatch (extension % path % uri % request) (==)  hExtensionRouter :: ListDispatcher (Maybe String) a hExtensionRouter = hListDispatch hExtension
src/Network/Salvia/Handlers/Fallback.hs view
@@ -2,8 +2,9 @@  import Control.Applicative import Control.Monad.State-import Network.Salvia.Httpd+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@@ -14,7 +15,7 @@ hOr :: Handler a -> Handler a -> Handler a hOr h0 h1 = do   a  <- h0-  st <- gets (status . response)+  st <- getM (status % response)   if statusFailure st     then reset >> h1     else return a
src/Network/Salvia/Handlers/File.hs view
@@ -10,13 +10,13 @@   ) where  import Control.Monad.State-import System.IO--import Network.Salvia.Httpd-import Network.Salvia.Handlers.Error+import Data.Record.Label import Network.Protocol.Http-import Network.Protocol.Uri (mimetype, path, parseURI) import Network.Protocol.Mime+import Network.Protocol.Uri (mimetype, path, parseURI)+import Network.Salvia.Handlers.Error+import Network.Salvia.Httpd+import System.IO  hFile :: Handler () hFile = hResource hFileResource@@ -30,7 +30,7 @@ -}  hResource :: ResourceHandler a -> Handler a-hResource rh = gets request >>= rh . path . uri+hResource rh = getM (path % uri % request) >>= rh  {- Turn a URI handler into a regular handler that utilizes the request URI as the@@ -38,7 +38,7 @@ -}  hUri :: UriHandler a -> Handler a-hUri rh = gets request >>= rh . uri+hUri rh = getM (uri % request) >>= rh  -------- HTTP deamon implementation ------------------------------------------- @@ -46,24 +46,24 @@ -- TODO: what to do with encoding? hFileResource :: ResourceHandler () hFileResource file = do-  let m = maybe defaultMime id $ (parseURI file >>= mimetype)+  let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)   safeIO (openBinaryFile file ReadMode)     $ \fd -> do       fs <- lift $ hFileSize fd-      modResponse-        $ setContentType m (Just "utf-8")-        . setContentLength fs-        . setStatus OK+      enterM response $ do+        setM contentType (m, Just "utf-8")+        setM contentLength (Just fs)+        setM status OK       spoolBs id fd  -- TODO: what to do with encoding? hFileResourceFilter :: (String -> String) -> ResourceHandler () hFileResourceFilter fFilter file = do  -- TODO... this should be a more general hFilter-  let m = maybe defaultMime id $ (parseURI file >>= mimetype)+  let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)   safeIO (openBinaryFile file ReadMode)     $ \fd -> do-      modResponse-        $ setContentType m (Just "utf-8")-        . setStatus OK+      enterM response $ do+        setM contentType (m, Just "utf-8")+        setM status OK       spool fFilter fd
src/Network/Salvia/Handlers/FileSystem.hs view
@@ -5,37 +5,34 @@   ) where  import Control.Monad.State-import System.Directory (doesDirectoryExist)--import Network.Salvia.Httpd+import Data.Record.Label+import Misc.Misc (bool)+import Network.Protocol.Http+import Network.Protocol.Uri (jail, path)+import Network.Salvia.Handlers.Directory import Network.Salvia.Handlers.Error import Network.Salvia.Handlers.File-import Network.Salvia.Handlers.Directory-import Network.Salvia.Handlers.Rewrite-import Network.Protocol.Http-import Network.Protocol.Uri (jail)-import Misc.Misc (bool)+import Network.Salvia.Httpd+import System.Directory (doesDirectoryExist)  -- Show file contents and show directory indexes. hFileSystem :: ResourceHandler ()-hFileSystem dir = hFileTypeDispatcher dir hDirectory hFile+hFileSystem dir = hFileTypeDispatcher dir hDirectoryResource hFileResource  -- Show file contents, do not show directory indexes. hFileSystemNoIndexes :: ResourceHandler ()-hFileSystemNoIndexes dir = hFileTypeDispatcher dir (hError Forbidden) hFile+hFileSystemNoIndexes dir = hFileTypeDispatcher dir (const $ hError Forbidden) hFileResource  -- Dispatch based on file type, regular files or directories.-hFileTypeDispatcher :: FilePath -> Handler () -> Handler () -> Handler () +hFileTypeDispatcher :: FilePath -> ResourceHandler () -> ResourceHandler () -> Handler ()  hFileTypeDispatcher dir hdir hfile =-  hWithDir dir-    $ hResource-    $ hJailedDispatch dir hdir hfile+  getM (path % uri % request) >>=+  hJailedDispatch dir hdir hfile . (dir ++) -hJailedDispatch :: FilePath -> Handler () -> Handler () -> ResourceHandler () +hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler ()  hJailedDispatch dir hdir hfile file = do   case jail dir file of     Nothing -> hError Forbidden-    Just f  -> do-      isDir <- lift (doesDirectoryExist f)-      bool hdir hfile isDir+    Just f  -> bool (hdir file) (hfile file)+           =<< lift (doesDirectoryExist f)
src/Network/Salvia/Handlers/Head.hs view
@@ -1,10 +1,10 @@ module Network.Salvia.Handlers.Head (hHead) where  import Control.Applicative-import Control.Monad.State--import Network.Salvia.Httpd+import Control.Monad.State (put)+import Data.Record.Label import Network.Protocol.Http+import Network.Salvia.Httpd  {- | The 'hHead' handler makes sure no response body is sent to the client when the@@ -15,9 +15,9 @@  hHead :: Handler a -> Handler a hHead handler = do-  m <- gets (method . request)+  m <- getM (method % request)   case m of-    HEAD -> withRequest (setMethod GET) handler-         <* emptyQueue+    HEAD -> withM (method % request) (put GET) $+              handler <* emptyQueue     _    -> handler
src/Network/Salvia/Handlers/Log.hs view
@@ -2,26 +2,26 @@  import Control.Concurrent.STM import Control.Monad.State-import System.IO--import Network.Salvia.Httpd  (Handler, request, response, address)-import Network.Protocol.Http+import Data.Record.Label import Misc.Terminal (red, green, reset)+import Network.Protocol.Http+import Network.Salvia.Httpd  (Handler, request, response, address)+import System.IO  -- TODO: handle should be tvar as well hLog :: TVar Int -> Handle -> Handler Handle hLog count handle = do   c    <- lift $ atomically $ readTVar count-  req  <- gets request-  res  <- gets response-  addr <- gets address-  let st   = status res-      code = codeFromStatus st+  mt   <- getM (method % request)+  ur   <- getM (uri    % request)+  st   <- getM (status % response)+  addr <- getM address+  let code = codeFromStatus st       clr  = if code >= 400 then red else green   lift $ hPutStrLn handle $ concat [       concat ["[", show addr, "] ", show c, "\t"]-    , show $ method req, "\t"-    , show $ uri req , " -> "+    , show mt, "\t"+    , show ur, " -> "     , clr     , show code, " "     , show st
src/Network/Salvia/Handlers/Login.hs view
@@ -21,24 +21,28 @@   , hLogin   , hLogout   , hLoginfo+   , hAuthorized+  , hAuthorizedUser    -- * Helper functions.   , readUserDatabase    ) where -import Data.List (intercalate)-import Data.Maybe (catMaybes) import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar) import Control.Monad.State (lift, liftM)-+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Record.Label+import Misc.Misc (atomModTVar, safeHead)+import Network.Protocol.Http (Status (Unauthorized, OK), status) import Network.Salvia.Handlers.Error (hCustomError, hError) import Network.Salvia.Handlers.Session-import Network.Salvia.Httpd hiding (start)-import Network.Protocol.Http (Status (Unauthorized, OK), setStatus)-import Misc.Misc (atomModTVar, safeHead)-import qualified Network.Protocol.Uri as URI+import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)+import Network.Protocol.Uri+import Data.ByteString.UTF8 (fromString)  ------------------------------------------------------------------------------- @@ -55,6 +59,7 @@ data User = User {     username :: Username   , password :: Password+  , email    :: String   , actions  :: Actions   } deriving (Eq, Show) @@ -72,7 +77,7 @@     dbUsers  :: Users   , dbGuest  :: Actions   , dbSource :: src-  }+  } deriving Show  type TUserDatabase src = TVar (UserDatabase src) @@ -113,11 +118,15 @@   where     parseUserLine line =       case words line of-        user:pass:acts -> Just (User user pass acts)-        _              -> Nothing+        user:pass:mail:acts -> Just (User user pass mail acts)+        _                   -> Nothing  printUserLine :: User -> String-printUserLine u = intercalate " " ([username u, password u] ++ actions u)+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@@ -131,7 +140,7 @@ hSignup tdb acts = do   db <- lift . atomically $ readTVar tdb   params <- uriEncodedPostParamsUTF8-  case freshUserPass params (dbUsers db) acts of+  case freshUserInfo params (dbUsers db) acts of     Nothing -> hCustomError Unauthorized "signup failed"     Just u  -> do       lift $ do@@ -140,13 +149,14 @@           $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)         appendFile (dbSource db) (printUserLine u) -freshUserPass :: Maybe URI.Parameters -> Users -> Actions -> Maybe User-freshUserPass params us acts = do+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 pass acts+    Nothing -> return $ User user (md5sum $ fromString pass) mail acts     Just _  -> Nothing  -------------------------------------------------------------------------------@@ -166,7 +176,7 @@     (loginSuccessful session)     (authenticate params db) -authenticate :: Maybe URI.Parameters -> UserDatabase a -> Maybe User+authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User authenticate params db = do   p <- params   user <- "username" `lookup` p >>= id@@ -174,7 +184,7 @@   case safeHead $ filter ((==user).username) (dbUsers db) of     Nothing -> Nothing     Just u  ->-      if password u == pass+      if password u == md5sum (fromString pass)       then return u       else Nothing @@ -182,7 +192,7 @@ loginSuccessful :: TUserSession a -> User -> Handler () loginSuccessful session user = do   lift $ atomModTVar (\s -> s {payload = Just (UserPayload user True Nothing)}) session-  modResponse $ setStatus OK+  setM (status % response) OK   sendStrLn "login successful"  -------------------------------------------------------------------------------@@ -201,9 +211,9 @@ that is included. -} -hLoginfo :: Show a => UserSessionHandler a ()-hLoginfo s = do-  s' <- lift $ atomically $ readTVar s+hLoginfo :: UserSessionHandler a ()+hLoginfo session = do+  s' <- lift $ atomically $ readTVar session    sendStrLn $ "sID="     ++ show (sID     s')   sendStrLn $ "start="   ++ show (start   s')@@ -211,8 +221,9 @@    case payload s' of     Nothing -> return ()-    Just (UserPayload (User uname _ acts) _ _) -> do+    Just (UserPayload (User uname _ mail acts) _ _) -> do       sendStrLn $ "username=" ++ uname+      sendStrLn $ "email="    ++ mail       sendStrLn $ "actions="  ++ intercalate " " acts  -------------------------------------------------------------------------------@@ -238,5 +249,24 @@       | action `elem` actions user -> handler (Just user)     Nothing       | action `elem` dbGuest db   -> handler Nothing+    _                              -> hError Unauthorized++{- |+Execute a handler only when the user for the current session is authorized to+do so. The user must have the specified action contained in its actions list in+order to be authorized. Otherwise an `Unauthorized' error will be produced. The+guest user will not be used in any case.+-}++hAuthorizedUser ::+     Action                      -- ^ The actions that should be authorized.+  -> (User -> Handler ())        -- ^ The handler to perform when authorized.+  -> UserSessionHandler a ()     -- ^ This handler requires a user session.++hAuthorizedUser action handler session = do+  load <- liftM payload (lift $ atomically $ readTVar session)+  case load of+    Just (UserPayload user _ _)+      | action `elem` actions user -> handler user     _                              -> hError Unauthorized
src/Network/Salvia/Handlers/MethodRouter.hs view
@@ -12,13 +12,14 @@   , hCONNECT   ) where +import Data.Record.Label+import Network.Protocol.Http import Network.Salvia.Handlers.Dispatching import Network.Salvia.Handlers.Error import Network.Salvia.Httpd-import Network.Protocol.Http  hMethod' :: Dispatcher Method a-hMethod' = hDispatch (method . request) (==)+hMethod' = hDispatch (method % request) (==)  hMethodRouter :: ListDispatcher Method a hMethodRouter = hListDispatch hMethod'
src/Network/Salvia/Handlers/Parser.hs view
@@ -1,11 +1,11 @@ module Network.Salvia.Handlers.Parser (hParser) where -import System.IO import Control.Monad.State-import Text.ParserCombinators.Parsec (parse)--import Network.Salvia.Httpd+import Data.Record.Label import Network.Protocol.Http+import Network.Salvia.Httpd+import System.IO+import Text.ParserCombinators.Parsec (parse)  {- | The 'hParser' handler is used to parse the raw request message into the@@ -21,13 +21,13 @@   -> Handler a  hParser onfail onsuccess = do-  h <- gets sock+  h <- getM sock   -- TODO use try and fail with bad request or reject silently.   msg <- lift $ readHeader h `catch` error "AAAAp"   case parse pRequest "" (msg "") of     Left err -> onfail (show err)     Right x -> do-      putRequest x+      setM request x       onsuccess  -- Read all lines until the first empty line.
src/Network/Salvia/Handlers/PathRouter.hs view
@@ -9,23 +9,23 @@  import Control.Monad.State import Data.List (isPrefixOf)--import Network.Salvia.Httpd+import Data.Record.Label import Network.Protocol.Http-import Network.Protocol.Uri (modPath, path, queryParams, Parameters)+import Network.Protocol.Uri (path, queryParams, Parameters) import Network.Salvia.Handlers.Dispatching+import Network.Salvia.Httpd  chop :: String -> Handler a -> Handler a-chop a = withRequest $ modUri $ modPath $ drop $ length a+chop a = withM (path % uri % request) (modify (drop $ length a))  hPath :: Dispatcher String a-hPath p h d = hDispatch (path . uri . request) (==) p (chop p h) d+hPath p h = hDispatch (path % uri % request) (==) p (chop p h)  hPathRouter :: ListDispatcher String b hPathRouter = hListDispatch hPath  hPrefix :: Dispatcher String a-hPrefix p h d = hDispatch (path . uri . request) isPrefixOf p (chop p h) d+hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)  hPrefixRouter :: ListDispatcher String b hPrefixRouter = hListDispatch hPrefix@@ -33,5 +33,5 @@ -- Path related utilities.  hParameters :: Handler Parameters-hParameters = gets (queryParams . uri . request)+hParameters = getM (uri % request) >>= return . queryParams
src/Network/Salvia/Handlers/Printer.hs view
@@ -1,7 +1,7 @@ module Network.Salvia.Handlers.Printer (hPrinter) where  import Control.Monad.State-+import Data.Record.Label (getM) import Network.Salvia.Httpd  {- |@@ -17,7 +17,7 @@   sendHeaders    -- Process all send actions in queue.-  s <- gets sock-  q <- gets queue+  s <- getM sock+  q <- getM queue   lift $ mapM_ ($ s) q
src/Network/Salvia/Handlers/Put.hs view
@@ -1,12 +1,11 @@ module Network.Salvia.Handlers.Put (hPut) where  import Control.Monad.State+import Network.Protocol.Http+import Network.Salvia.Handlers.Error+import Network.Salvia.Httpd import System.IO import qualified Data.ByteString.Lazy as B--import Network.Salvia.Httpd-import Network.Salvia.Handlers.Error-import Network.Protocol.Http  {- | First naive handler for the PUT request. This probably does not handle all the
src/Network/Salvia/Handlers/Redirect.hs view
@@ -1,12 +1,13 @@ module Network.Salvia.Handlers.Redirect (hRedirect) where -import Network.Salvia.Httpd+import Data.Record.Label import Network.Protocol.Http import Network.Protocol.Uri (URI)+import Network.Salvia.Httpd  hRedirect :: URI -> Handler ()-hRedirect u = do-  modResponse-    $ setLocation u-    . setStatus MovedPermanently+hRedirect u =+  enterM response $ do+    setM location (Just u)+    setM status MovedPermanently
src/Network/Salvia/Handlers/Rewrite.hs view
@@ -7,32 +7,32 @@   , hWithoutDir   ) where -import Data.List (isPrefixOf) import Control.Monad.State--import Network.Salvia.Httpd+import Data.List (isPrefixOf)+import Data.Record.Label import Network.Protocol.Http-import Network.Protocol.Uri (URI, modPath, modHost, path, modExtension)+import Network.Protocol.Uri (URI, host, path, extension)+import Network.Salvia.Httpd  hRewrite :: (URI -> URI) -> Handler a -> Handler a-hRewrite f h = withRequest (modUri f) h+hRewrite f = withM (uri % request) (modify f) +-- express these below in terms of the above?+ hRewriteHost :: (String -> String) -> Handler a -> Handler a-hRewriteHost f h = withRequest (modUri $ modHost f) h+hRewriteHost f = withM (host % uri % request) (modify f)  hRewritePath :: (String -> String) -> Handler a -> Handler a-hRewritePath f h = withRequest (modUri $ modPath f) h+hRewritePath f = withM (path % uri % request) (modify f) -hRewriteExt :: (String -> String) -> Handler a -> Handler a-hRewriteExt f = hRewrite (modExtension f)+hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a+hRewriteExt f = withM (extension % path % uri % request) (modify f)  hWithDir :: String -> Handler a -> Handler a hWithDir d = hRewritePath (d++)  hWithoutDir :: String -> Handler a -> Handler a hWithoutDir d h = do-  req <- gets request-  if (d `isPrefixOf` (path $ uri $ req))-    then hRewritePath (drop (length d)) h-    else h+  p <- getM (path % uri % request)+  (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h
src/Network/Salvia/Handlers/Session.hs view
@@ -14,15 +14,14 @@ import Control.Concurrent.STM import Control.Monad.State import Data.Time.LocalTime+import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)+import Network.Protocol.Cookie hiding (empty)+import Network.Salvia.Handlers.Cookie+import Network.Salvia.Httpd hiding (start) import Prelude hiding (lookup) import System.Random import qualified Data.Map as M -import Network.Salvia.Handlers.Cookie-import Network.Salvia.Httpd hiding (start)-import Network.Protocol.Cookie hiding (empty)-import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)- -------------------------------------------------------------------------------  -- A session identifier. Should be unique for every session.@@ -35,7 +34,7 @@   , start   :: LocalTime   , expire  :: LocalTime   , payload :: Maybe a-  }+  } deriving Show  -- A shared session. type TSession a = TVar (Session a)
src/Network/Salvia/Handlers/VirtualHosting.hs view
@@ -1,15 +1,15 @@ module Network.Salvia.Handlers.VirtualHosting (hVirtualHosting) where  import Data.List (isPrefixOf)--import Network.Salvia.Httpd-import Network.Protocol.Http-import Network.Salvia.Handlers.Dispatching+import Data.Record.Label+import Network.Protocol.Http (hostname)+import Network.Salvia.Handlers.Dispatching (Dispatcher, ListDispatcher, hListDispatch, hDispatch)+import Network.Salvia.Httpd (request)  -- isSuffixOf?  hVirtualHosting1 :: Dispatcher String a-hVirtualHosting1 = hDispatch (getHost . request) isPrefixOf+hVirtualHosting1 = hDispatch (hostname % request) isPrefixOf  hVirtualHosting :: ListDispatcher String a hVirtualHosting = hListDispatch hVirtualHosting1
src/Network/Salvia/Httpd.hs view
@@ -6,14 +6,18 @@    -- Httpd.Core.Handler   , Context (..)-  , makeContext+  , config+  , request+  , response+  , sock+  , address+  , queue +  , mkContext+   , Handler   , ResourceHandler   , UriHandler-  , putRequest, putResponse, putQueue-  , modRequest, modResponse, modQueue-  , withRequest, withResponse    -- Httpd.Core.IO   , sendHeaders