"
+ ]
+
diff --git a/src/Network/Salvia/Handlers/Dispatching.hs b/src/Network/Salvia/Handlers/Dispatching.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Dispatching.hs
@@ -0,0 +1,24 @@
+module Network.Salvia.Handlers.Dispatching (
+ Dispatcher
+ , ListDispatcher
+ , hDispatch
+ , hListDispatch
+ ) where
+
+import Control.Monad.State
+
+import Network.Salvia.Httpd
+
+type Dispatcher a b = a -> Handler b -> Handler b -> Handler b
+type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b
+
+hDispatch :: (Show c, Show a) => (Context -> c) -> (a -> c -> Bool) -> Dispatcher a b
+hDispatch f match a handler _default = do
+ ctx <- gets f
+ if a `match` ctx
+ then handler
+ else _default
+
+hListDispatch :: Dispatcher a b -> ListDispatcher a b
+hListDispatch disp = flip $ foldr $ uncurry disp
+
diff --git a/src/Network/Salvia/Handlers/Error.hs b/src/Network/Salvia/Handlers/Error.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Error.hs
@@ -0,0 +1,47 @@
+module Network.Salvia.Handlers.Error (
+ hError
+ , hCustomError
+ , hIOError
+ , safeIO
+ ) where
+
+import System.IO.Error
+
+import Control.Monad.State
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+
+{- |
+The 'hError' handler enables the creation of a default style of error responses
+for the specified HTTP status code.
+-}
+
+hError ::
+ Status -- ^ The HTTP status code.
+ -> Handler ()
+hError e = hCustomError e
+ (concat ["[", show (codeFromStatus e), "] ", show e, "\n"])
+
+hCustomError ::
+ Status -- ^ The HTTP status code.
+ -> String -- ^ Custom error message.
+ -> Handler ()
+hCustomError e m = do
+ modResponse
+ $ setStatus e
+ . setContentType "text/plain" Nothing
+ sendStr m
+
+-- | Map IO errors to a default style error response.
+hIOError :: IOError -> Handler ()
+hIOError e
+ | isDoesNotExistError e = hError NotFound
+ | isAlreadyInUseError e = hError ServiceUnavailable
+ | isPermissionError e = hError Forbidden
+ | True = hError InternalServerError
+
+-- | Execute an handler with the result of an IO action. When the IO actions
+-- fails a default error handler will be executed.
+safeIO :: IO a -> (a -> Handler ()) -> Handler ()
+safeIO io h = lift (try io) >>= either hIOError h
+
diff --git a/src/Network/Salvia/Handlers/ExtensionDispatcher.hs b/src/Network/Salvia/Handlers/ExtensionDispatcher.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/ExtensionDispatcher.hs
@@ -0,0 +1,16 @@
+module Network.Salvia.Handlers.ExtensionDispatcher (
+ hExtension
+ , hExtensionRouter
+ ) where
+
+import Network.Salvia.Httpd (request)
+import Network.Protocol.Http (uri)
+import Network.Protocol.Uri (extension)
+import Network.Salvia.Handlers.Dispatching
+
+hExtension :: Dispatcher (Maybe String) a
+hExtension = hDispatch (extension . uri . request) (==)
+
+hExtensionRouter :: ListDispatcher (Maybe String) a
+hExtensionRouter = hListDispatch hExtension
+
diff --git a/src/Network/Salvia/Handlers/Fallback.hs b/src/Network/Salvia/Handlers/Fallback.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Fallback.hs
@@ -0,0 +1,24 @@
+module Network.Salvia.Handlers.Fallback (hOr, hEither) where
+
+import Control.Applicative
+import Control.Monad.State
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+
+{- |
+Until I figure out how to do this correctly, this handler somewow implements
+the MonadPlus/Alternative instance using a custom function. When the first
+handler fails the response will be reset and the second handler is executed.
+-}
+
+hOr :: Handler a -> Handler a -> Handler a
+hOr h0 h1 = do
+ a <- h0
+ st <- gets (status . response)
+ if statusFailure st
+ then reset >> h1
+ else return a
+
+hEither :: Handler a -> Handler b -> Handler (Either a b)
+hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)
+
diff --git a/src/Network/Salvia/Handlers/File.hs b/src/Network/Salvia/Handlers/File.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/File.hs
@@ -0,0 +1,69 @@
+module Network.Salvia.Handlers.File (
+ hFile
+ , hFileResource
+
+ , hFileFilter
+ , hFileResourceFilter
+
+ , hResource
+ , hUri
+ ) where
+
+import Control.Monad.State
+import System.IO
+
+import Network.Salvia.Httpd
+import Network.Salvia.Handlers.Error
+import Network.Protocol.Http
+import Network.Protocol.Uri (mimetype, path, parseURI)
+import Network.Protocol.Mime
+
+hFile :: Handler ()
+hFile = hResource hFileResource
+
+hFileFilter :: (String -> String) -> Handler ()
+hFileFilter = hResource . hFileResourceFilter
+
+{-
+Turn a resource handler into a regular handler that utilizes the path part
+of the request URI as the resource identifier.
+-}
+
+hResource :: ResourceHandler a -> Handler a
+hResource rh = gets request >>= rh . path . uri
+
+{-
+Turn a URI handler into a regular handler that utilizes the request URI as the
+resource identifier.
+-}
+
+hUri :: UriHandler a -> Handler a
+hUri rh = gets request >>= rh . uri
+
+-------- HTTP deamon implementation -------------------------------------------
+
+-- Create a response message containing the file contents.
+-- TODO: what to do with encoding?
+hFileResource :: ResourceHandler ()
+hFileResource file = do
+ let m = maybe defaultMime id $ (parseURI file >>= mimetype)
+ safeIO (openBinaryFile file ReadMode)
+ $ \fd -> do
+ fs <- lift $ hFileSize fd
+ modResponse
+ $ setContentType m (Just "utf-8")
+ . setContentLength fs
+ . setStatus OK
+ spoolBs id fd
+
+-- TODO: what to do with encoding?
+hFileResourceFilter :: (String -> String) -> ResourceHandler ()
+hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter
+ let m = maybe defaultMime id $ (parseURI file >>= mimetype)
+ safeIO (openBinaryFile file ReadMode)
+ $ \fd -> do
+ modResponse
+ $ setContentType m (Just "utf-8")
+ . setStatus OK
+ spool fFilter fd
+
diff --git a/src/Network/Salvia/Handlers/FileSystem.hs b/src/Network/Salvia/Handlers/FileSystem.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/FileSystem.hs
@@ -0,0 +1,41 @@
+module Network.Salvia.Handlers.FileSystem (
+ hFileSystem
+ , hFileSystemNoIndexes
+ , hFileTypeDispatcher
+ ) where
+
+import Control.Monad.State
+import System.Directory (doesDirectoryExist)
+
+import Network.Salvia.Httpd
+import Network.Salvia.Handlers.Error
+import Network.Salvia.Handlers.File
+import Network.Salvia.Handlers.Directory
+import Network.Salvia.Handlers.Rewrite
+import Network.Protocol.Http
+import Network.Protocol.Uri (jail)
+import Misc.Misc (bool)
+
+-- Show file contents and show directory indexes.
+hFileSystem :: ResourceHandler ()
+hFileSystem dir = hFileTypeDispatcher dir hDirectory hFile
+
+-- Show file contents, do not show directory indexes.
+hFileSystemNoIndexes :: ResourceHandler ()
+hFileSystemNoIndexes dir = hFileTypeDispatcher dir (hError Forbidden) hFile
+
+-- Dispatch based on file type, regular files or directories.
+hFileTypeDispatcher :: FilePath -> Handler () -> Handler () -> Handler ()
+hFileTypeDispatcher dir hdir hfile =
+ hWithDir dir
+ $ hResource
+ $ hJailedDispatch dir hdir hfile
+
+hJailedDispatch :: FilePath -> Handler () -> Handler () -> ResourceHandler ()
+hJailedDispatch dir hdir hfile file = do
+ case jail dir file of
+ Nothing -> hError Forbidden
+ Just f -> do
+ isDir <- lift (doesDirectoryExist f)
+ bool hdir hfile isDir
+
diff --git a/src/Network/Salvia/Handlers/Head.hs b/src/Network/Salvia/Handlers/Head.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Head.hs
@@ -0,0 +1,23 @@
+module Network.Salvia.Handlers.Head (hHead) where
+
+import Control.Applicative
+import Control.Monad.State
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+
+{- |
+The 'hHead' handler makes sure no response body is sent to the client when the
+request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the
+specified sub handler will be executed under the assumption that the request
+was a 'GET' request, otherwise this handler will act as the identify function.
+-}
+
+hHead :: Handler a -> Handler a
+hHead handler = do
+ m <- gets (method . request)
+ case m of
+ HEAD -> withRequest (setMethod GET) handler
+ <* emptyQueue
+ _ -> handler
+
diff --git a/src/Network/Salvia/Handlers/Log.hs b/src/Network/Salvia/Handlers/Log.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Log.hs
@@ -0,0 +1,31 @@
+module Network.Salvia.Handlers.Log (hLog) where
+
+import Control.Concurrent.STM
+import Control.Monad.State
+import System.IO
+
+import Network.Salvia.Httpd (Handler, request, response, address)
+import Network.Protocol.Http
+import Misc.Terminal (red, green, reset)
+
+-- TODO: handle should be tvar as well
+hLog :: TVar Int -> Handle -> Handler Handle
+hLog count handle = do
+ c <- lift $ atomically $ readTVar count
+ req <- gets request
+ res <- gets response
+ addr <- gets address
+ let st = status res
+ code = codeFromStatus st
+ clr = if code >= 400 then red else green
+ lift $ hPutStrLn handle $ concat [
+ concat ["[", show addr, "] ", show c, "\t"]
+ , show $ method req, "\t"
+ , show $ uri req , " -> "
+ , clr
+ , show code, " "
+ , show st
+ , reset
+ ]
+ return handle
+
diff --git a/src/Network/Salvia/Handlers/Login.hs b/src/Network/Salvia/Handlers/Login.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Login.hs
@@ -0,0 +1,242 @@
+module Network.Salvia.Handlers.Login (
+
+ -- * Basic types.
+ Username
+ , Password
+ , Action
+ , Actions
+ , User (..)
+ , Users
+ , UserDatabase
+ , TUserDatabase
+
+ -- * User Sessions.
+ , UserPayload (..)
+ , UserSession
+ , TUserSession
+ , UserSessionHandler
+
+ -- * Handlers.
+ , hSignup
+ , hLogin
+ , hLogout
+ , hLoginfo
+ , hAuthorized
+
+ -- * Helper functions.
+ , readUserDatabase
+
+ ) where
+
+import Data.List (intercalate)
+import Data.Maybe (catMaybes)
+import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)
+import Control.Monad.State (lift, liftM)
+
+import Network.Salvia.Handlers.Error (hCustomError, hError)
+import Network.Salvia.Handlers.Session
+import Network.Salvia.Httpd hiding (start)
+import Network.Protocol.Http (Status (Unauthorized, OK), setStatus)
+import Misc.Misc (atomModTVar, safeHead)
+import qualified Network.Protocol.Uri as URI
+
+-------------------------------------------------------------------------------
+
+type Username = String
+type Password = String
+type Action = String
+type Actions = [Action]
+
+{- |
+User containg a username, password and a list of actions this user is allowed
+to perform within the system.
+-}
+
+data User = User {
+ username :: Username
+ , password :: Password
+ , actions :: Actions
+ } deriving (Eq, Show)
+
+type Users = [User]
+
+{- |
+A user database containing a list of users, a list of default actions the guest
+or `no-user' user is allowed to perform and a polymorphic reference to the
+place the database originates from. This source field cab be used by update
+functions synchronizing changes back to the database.
+-}
+
+data UserDatabase src =
+ UserDatabase {
+ dbUsers :: Users
+ , dbGuest :: Actions
+ , dbSource :: src
+ }
+
+type TUserDatabase src = TVar (UserDatabase src)
+
+{- |
+A user payload instance contains user related session information and can be
+used as the payload for regular sessions. It contains a reference to the user
+it is bound to, a flag to indicate whether the user is logged in or not and a
+possible user specific session payload.
+-}
+
+data UserPayload a = UserPayload {
+ upUser :: User
+ , upLoggedIn :: Bool
+ , upPayload :: Maybe a
+ } deriving (Eq, Show)
+
+type UserSession a = Session (UserPayload a)
+type TUserSession a = TSession (UserPayload a)
+
+-- A handler that requires a session with a user specific payload.
+type UserSessionHandler a b = SessionHandler (UserPayload a) b
+
+-------------------------------------------------------------------------------
+
+-- Read user data file.
+-- Format: username password action*
+
+readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)
+readUserDatabase file = do
+
+ -- First line contains the default `guest` actions, tail lines contain users.
+ gst:ls <- lines `liftM` readFile file
+
+ atomically $ newTVar $ UserDatabase
+ (catMaybes $ map parseUserLine ls)
+ (words gst)
+ file
+ where
+ parseUserLine line =
+ case words line of
+ user:pass:acts -> Just (User user pass acts)
+ _ -> Nothing
+
+printUserLine :: User -> String
+printUserLine u = intercalate " " ([username u, password u] ++ actions u)
+
+{- |
+The signup handler is used to create a new entry in the user database. It reads
+a new username and password from the HTTP POST parameters and adds a new entry
+in the database when no user with such name exists. The user gets the specified
+initial set of actions assigned. On failure an `Unauthorized' error will be
+produced.
+-}
+
+hSignup :: TUserDatabase FilePath -> Actions -> Handler ()
+hSignup tdb acts = do
+ db <- lift . atomically $ readTVar tdb
+ params <- uriEncodedPostParamsUTF8
+ case freshUserPass params (dbUsers db) acts of
+ Nothing -> hCustomError Unauthorized "signup failed"
+ Just u -> do
+ lift $ do
+ atomically
+ $ writeTVar tdb
+ $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)
+ appendFile (dbSource db) (printUserLine u)
+
+freshUserPass :: Maybe URI.Parameters -> Users -> Actions -> Maybe User
+freshUserPass params us acts = do
+ p <- params
+ user <- "username" `lookup` p >>= id
+ pass <- "password" `lookup` p >>= id
+ case safeHead $ filter ((==user).username) us of
+ Nothing -> return $ User user pass acts
+ Just _ -> Nothing
+
+-------------------------------------------------------------------------------
+
+{- |
+The login handler. Read the username and password values from the post data and
+use that to authenticate the user. When the user can be found in the database
+the user is logged in and stored in the session payload. Otherwise a
+`Unauthorized' response will be sent and the user has not logged in.
+-}
+
+hLogin :: UserDatabase b -> UserSessionHandler a ()
+hLogin db session = do
+ params <- uriEncodedPostParamsUTF8
+ maybe
+ (hCustomError Unauthorized "login failed")
+ (loginSuccessful session)
+ (authenticate params db)
+
+authenticate :: Maybe URI.Parameters -> UserDatabase a -> Maybe User
+authenticate params db = do
+ p <- params
+ user <- "username" `lookup` p >>= id
+ pass <- "password" `lookup` p >>= id
+ case safeHead $ filter ((==user).username) (dbUsers db) of
+ Nothing -> Nothing
+ Just u ->
+ if password u == pass
+ then return u
+ else Nothing
+
+-- Login user and create `Ok' response on successful user.
+loginSuccessful :: TUserSession a -> User -> Handler ()
+loginSuccessful session user = do
+ lift $ atomModTVar (\s -> s {payload = Just (UserPayload user True Nothing)}) session
+ modResponse $ setStatus OK
+ sendStrLn "login successful"
+
+-------------------------------------------------------------------------------
+
+hLogout :: TUserSession a -> Handler ()
+hLogout session = do
+ lift $ atomModTVar (\s -> s {payload = Nothing}) session
+ return ()
+
+-------------------------------------------------------------------------------
+
+{- |
+The `loginfo' handler exposes the current user session to the world using a
+simple text based file. The file contains information about the current session
+identifier, session start and expiration date and the possible user payload
+that is included.
+-}
+
+hLoginfo :: Show a => UserSessionHandler a ()
+hLoginfo s = do
+ s' <- lift $ atomically $ readTVar s
+
+ sendStrLn $ "sID=" ++ show (sID s')
+ sendStrLn $ "start=" ++ show (start s')
+ sendStrLn $ "expire=" ++ show (expire s')
+
+ case payload s' of
+ Nothing -> return ()
+ Just (UserPayload (User uname _ acts) _ _) -> do
+ sendStrLn $ "username=" ++ uname
+ sendStrLn $ "actions=" ++ intercalate " " acts
+
+-------------------------------------------------------------------------------
+
+{- |
+Execute a handler only when the user for the current session is authorized to
+do so. The user must have the specified action contained in its actions list in
+order to be authorized. Otherwise an `Unauthorized' error will be produced.
+When no user can be found in the current session or this user is not logged in
+the guest account from the user database is used for authorization.
+-}
+
+hAuthorized ::
+ UserDatabase b -- ^ The user database to read guest account from.
+ -> Action -- ^ The actions that should be authorized.
+ -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized.
+ -> UserSessionHandler a () -- ^ This handler requires a user session.
+
+hAuthorized db action handler session = do
+ load <- liftM payload (lift $ atomically $ readTVar session)
+ case load of
+ Just (UserPayload user _ _)
+ | action `elem` actions user -> handler (Just user)
+ Nothing
+ | action `elem` dbGuest db -> handler Nothing
+ _ -> hError Unauthorized
+
diff --git a/src/Network/Salvia/Handlers/MethodRouter.hs b/src/Network/Salvia/Handlers/MethodRouter.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/MethodRouter.hs
@@ -0,0 +1,41 @@
+module Network.Salvia.Handlers.MethodRouter (
+ hMethod
+ , hMethodRouter
+
+ , hOPTIONS
+ , hGET
+ , hHEAD
+ , hPOST
+ , hPUT
+ , hDELETE
+ , hTRACE
+ , hCONNECT
+ ) where
+
+import Network.Salvia.Handlers.Dispatching
+import Network.Salvia.Handlers.Error
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+
+hMethod' :: Dispatcher Method a
+hMethod' = hDispatch (method . request) (==)
+
+hMethodRouter :: ListDispatcher Method a
+hMethodRouter = hListDispatch hMethod'
+
+hMethod :: Method -> Handler () -> Handler ()
+hMethod m k = hMethod' m k (hError NotFound)
+
+-- Shortcut handlers that only work for specific method types or fail.
+hOPTIONS, hGET, hHEAD, hPOST, hPUT, hDELETE, hTRACE, hCONNECT
+ :: Handler () -> Handler ()
+
+hOPTIONS = hMethod OPTIONS
+hGET = hMethod GET
+hHEAD = hMethod HEAD
+hPOST = hMethod POST
+hPUT = hMethod PUT
+hDELETE = hMethod DELETE
+hTRACE = hMethod TRACE
+hCONNECT = hMethod CONNECT
+
diff --git a/src/Network/Salvia/Handlers/Parser.hs b/src/Network/Salvia/Handlers/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Parser.hs
@@ -0,0 +1,41 @@
+module Network.Salvia.Handlers.Parser (hParser) where
+
+import System.IO
+import Control.Monad.State
+import Text.ParserCombinators.Parsec (parse)
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+
+{- |
+The 'hParser' handler is used to parse the raw request message into the
+'Message' data type. This handler is generally used as (one of) the first
+handlers in a configuration. The first handler argument is executed when the
+request is invalid, possibly due to parser errors. The second handler argument
+is executed when the request is valid.
+-}
+
+hParser ::
+ (String -> Handler a) -- ^ The fail handler.
+ -> Handler a -- ^ The succeed handler.
+ -> Handler a
+
+hParser onfail onsuccess = do
+ h <- gets sock
+ -- TODO use try and fail with bad request or reject silently.
+ msg <- lift $ readHeader h `catch` error "AAAAp"
+ case parse pRequest "" (msg "") of
+ Left err -> onfail (show err)
+ Right x -> do
+ putRequest x
+ onsuccess
+
+-- Read all lines until the first empty line.
+readHeader :: Handle -> IO (String -> String)
+readHeader h = do
+ l <- hGetLine h
+ let lf = showChar '\n'
+ if l `elem` ["", "\r"]
+ then return lf
+ else liftM ((showString l . lf) .) (readHeader h)
+
diff --git a/src/Network/Salvia/Handlers/PathRouter.hs b/src/Network/Salvia/Handlers/PathRouter.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/PathRouter.hs
@@ -0,0 +1,37 @@
+module Network.Salvia.Handlers.PathRouter (
+ hPath
+ , hPathRouter
+ , hPrefix
+ , hPrefixRouter
+
+ , hParameters
+ ) where
+
+import Control.Monad.State
+import Data.List (isPrefixOf)
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+import Network.Protocol.Uri (modPath, path, queryParams, Parameters)
+import Network.Salvia.Handlers.Dispatching
+
+chop :: String -> Handler a -> Handler a
+chop a = withRequest $ modUri $ modPath $ drop $ length a
+
+hPath :: Dispatcher String a
+hPath p h d = hDispatch (path . uri . request) (==) p (chop p h) d
+
+hPathRouter :: ListDispatcher String b
+hPathRouter = hListDispatch hPath
+
+hPrefix :: Dispatcher String a
+hPrefix p h d = hDispatch (path . uri . request) isPrefixOf p (chop p h) d
+
+hPrefixRouter :: ListDispatcher String b
+hPrefixRouter = hListDispatch hPrefix
+
+-- Path related utilities.
+
+hParameters :: Handler Parameters
+hParameters = gets (queryParams . uri . request)
+
diff --git a/src/Network/Salvia/Handlers/Printer.hs b/src/Network/Salvia/Handlers/Printer.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Printer.hs
@@ -0,0 +1,23 @@
+module Network.Salvia.Handlers.Printer (hPrinter) where
+
+import Control.Monad.State
+
+import Network.Salvia.Httpd
+
+{- |
+The 'hPrinter' handler print the entire response including the headers to the
+client. This handler is generally used as (one of) the last handler in a
+configuration.
+-}
+
+hPrinter :: Handler ()
+hPrinter = do
+
+ -- Send the entire HTTP response header.
+ sendHeaders
+
+ -- Process all send actions in queue.
+ s <- gets sock
+ q <- gets queue
+ lift $ mapM_ ($ s) q
+
diff --git a/src/Network/Salvia/Handlers/Put.hs b/src/Network/Salvia/Handlers/Put.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Put.hs
@@ -0,0 +1,27 @@
+module Network.Salvia.Handlers.Put (hPut) where
+
+import Control.Monad.State
+import System.IO
+import qualified Data.ByteString.Lazy as B
+
+import Network.Salvia.Httpd
+import Network.Salvia.Handlers.Error
+import Network.Protocol.Http
+
+{- |
+First naive handler for the PUT request. This probably does not handle all the
+quirks that the HTTP protocol specifies, but it does the job for now. When a
+'ContentLength' header field is available only this fixed number of bytes will
+be spooled from socket to the resource. When both the KeepAlive' and
+'ContentLength' header fields are not available the entire payload of the
+request is spooled to the resource.
+--}
+
+hPut :: ResourceHandler ()
+hPut name =
+ safeIO (openBinaryFile name WriteMode)
+ $ (contents >>=) . maybe putError . putOk
+ where
+ putError = hError NotImplemented
+ putOk fd c = lift (B.hPut fd c >> hClose fd)
+
diff --git a/src/Network/Salvia/Handlers/Redirect.hs b/src/Network/Salvia/Handlers/Redirect.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Redirect.hs
@@ -0,0 +1,12 @@
+module Network.Salvia.Handlers.Redirect (hRedirect) where
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+import Network.Protocol.Uri (URI)
+
+hRedirect :: URI -> Handler ()
+hRedirect u = do
+ modResponse
+ $ setLocation u
+ . setStatus MovedPermanently
+
diff --git a/src/Network/Salvia/Handlers/Rewrite.hs b/src/Network/Salvia/Handlers/Rewrite.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Rewrite.hs
@@ -0,0 +1,38 @@
+module Network.Salvia.Handlers.Rewrite (
+ hRewrite
+ , hRewritePath
+ , hRewriteHost
+ , hRewriteExt
+ , hWithDir
+ , hWithoutDir
+ ) where
+
+import Data.List (isPrefixOf)
+import Control.Monad.State
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+import Network.Protocol.Uri (URI, modPath, modHost, path, modExtension)
+
+hRewrite :: (URI -> URI) -> Handler a -> Handler a
+hRewrite f h = withRequest (modUri f) h
+
+hRewriteHost :: (String -> String) -> Handler a -> Handler a
+hRewriteHost f h = withRequest (modUri $ modHost f) h
+
+hRewritePath :: (String -> String) -> Handler a -> Handler a
+hRewritePath f h = withRequest (modUri $ modPath f) h
+
+hRewriteExt :: (String -> String) -> Handler a -> Handler a
+hRewriteExt f = hRewrite (modExtension f)
+
+hWithDir :: String -> Handler a -> Handler a
+hWithDir d = hRewritePath (d++)
+
+hWithoutDir :: String -> Handler a -> Handler a
+hWithoutDir d h = do
+ req <- gets request
+ if (d `isPrefixOf` (path $ uri $ req))
+ then hRewritePath (drop (length d)) h
+ else h
+
diff --git a/src/Network/Salvia/Handlers/Session.hs b/src/Network/Salvia/Handlers/Session.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/Session.hs
@@ -0,0 +1,181 @@
+module Network.Salvia.Handlers.Session (
+ hSession
+
+ , SessionID
+ , Session (..)
+ , TSession
+ , SessionHandler
+ , Sessions
+
+ , mkSessions
+ ) where
+
+import Control.Applicative hiding (empty)
+import Control.Concurrent.STM
+import Control.Monad.State
+import Data.Time.LocalTime
+import Prelude hiding (lookup)
+import System.Random
+import qualified Data.Map as M
+
+import Network.Salvia.Handlers.Cookie
+import Network.Salvia.Httpd hiding (start)
+import Network.Protocol.Cookie hiding (empty)
+import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)
+
+-------------------------------------------------------------------------------
+
+-- A session identifier. Should be unique for every session.
+newtype SessionID = SID Integer
+ deriving (Eq, Ord)
+
+-- The session data type with polymorph payload.
+data Session a = Session {
+ sID :: SessionID
+ , start :: LocalTime
+ , expire :: LocalTime
+ , payload :: Maybe a
+ }
+
+-- A shared session.
+type TSession a = TVar (Session a)
+
+-- A handler that expects a session.
+type SessionHandler a b = TSession a -> Handler b
+
+-- Create a new, empty, shared session.
+mkSession :: SessionID -> LocalTime -> IO (TSession a)
+mkSession sid e = do
+ s <- now
+ atomically $ newTVar $ Session sid s e Nothing
+
+-------------------------------------------------------------------------------
+
+type Sessions a = TVar (M.Map SessionID (TSession a))
+
+instance Show SessionID where
+ show (SID sid) = show sid
+
+mkSessions :: IO (Sessions a)
+mkSessions = atomically $ newTVar M.empty
+
+-------------------------------------------------------------------------------
+
+{-
+The session handler. This handler will try to return an existing session from
+the sessions map based on a session identifier found in the HTTP cookie. When
+such a session can be found the expiration date will be updated to a number of
+seconds in the future. When no session can be found a new one will be created.
+A cookie will be set that informs the client of the current session.
+-}
+
+hSession :: Sessions a -> Integer -> Handler (TSession a)
+hSession smap expiration = do
+
+ -- Get the session identifier from an existing cookie or create a new one.
+ prev <- getSessionID <$> hGetCookies
+
+ -- Compute current time and expiration time.
+ (n, ex) <- lift $ liftM2 (,) now (later expiration)
+
+ -- Either create a new session or try to reuse current one.
+ tsession <-
+ maybe
+ (newSession smap ex)
+ (existingSession smap ex n)
+ prev
+
+ setSessionCookie tsession ex
+ return tsession
+
+-------------------------------------------------------------------------------
+
+{-
+Given the (possible wrong) request cookie, try to recover the existing --
+session identifier.
+-}
+
+getSessionID :: Maybe Cookies -> Maybe SessionID
+getSessionID prev = do
+ ck <- prev
+ sid <- cookie "sid" ck
+ sid' <- safeRead $ value sid
+ return (SID sid')
+
+{-
+Generate a fresh, random session identifier using the default system random
+generator.
+-}
+
+genSessionID :: IO SessionID
+genSessionID = do
+ g <- getStdGen
+ let (sid, g') = random g
+ setStdGen g'
+ return (SID (abs sid))
+
+
+{-
+This handler sets the HTTP cookie for the specified session. It will use a
+default cookie with an additional `sid' attribute with the session identifier
+as value. The session expiration date will be used as the cookie expire field.
+-}
+
+setSessionCookie :: TSession a -> LocalTime -> Handler ()
+setSessionCookie tsession ex = do
+ ck <- newCookie ex
+ sid <- lift $ liftM sID $ atomReadTVar tsession
+ hSetCookies $
+ cookies [ck {
+ name = "sid"
+ , value = show sid
+ }]
+
+{-
+Handler when no (valid) session is available. Create a new session with a
+specified expiration date. The session will be stored in the session map.
+-}
+
+newSession :: Sessions a -> LocalTime -> Handler (TSession a)
+newSession sessions ex = lift $ do
+
+ -- Fresh session identifier.
+ sid <- genSessionID
+
+ -- Fresh session.
+ session <- mkSession sid ex
+
+ -- Place in session mapping usinf session identifier as key.
+ atomModTVar (M.insert sid session) sessions
+ return session
+
+{-
+Handler for existing sessions. Given an existing session identifier lookup a
+session from the session map. When no session is available, or the session is
+expired, create a new one using the `newSession' function. Otherwise the
+expiration date of the existing session is updated.
+-}
+
+existingSession ::
+ Sessions a -> LocalTime -> LocalTime
+ -> SessionID -> Handler (TSession a)
+existingSession sessions ex n sid = do
+
+ -- Lookup the session in the session map given the session identifier.
+ mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)
+ case mtsession of
+
+ -- Unrecognized session identifiers are penalised by a fresh session.
+ Nothing -> newSession sessions ex
+ Just tsession -> do
+ expd <- lift $ liftM expire (atomReadTVar tsession)
+ if expd < n
+
+ -- Session is expired, create a new one.
+ then newSession sessions ex
+
+ -- Existing session, update expiration date.
+ else lift $ do
+ atomModTVar (\s -> s {expire = ex}) tsession
+ return tsession
+
diff --git a/src/Network/Salvia/Handlers/VirtualHosting.hs b/src/Network/Salvia/Handlers/VirtualHosting.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers/VirtualHosting.hs
@@ -0,0 +1,16 @@
+module Network.Salvia.Handlers.VirtualHosting (hVirtualHosting) where
+
+import Data.List (isPrefixOf)
+
+import Network.Salvia.Httpd
+import Network.Protocol.Http
+import Network.Salvia.Handlers.Dispatching
+
+-- isSuffixOf?
+
+hVirtualHosting1 :: Dispatcher String a
+hVirtualHosting1 = hDispatch (getHost . request) isPrefixOf
+
+hVirtualHosting :: ListDispatcher String a
+hVirtualHosting = hListDispatch hVirtualHosting1
+
diff --git a/src/Network/Salvia/Httpd.hs b/src/Network/Salvia/Httpd.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Httpd.hs
@@ -0,0 +1,44 @@
+module Network.Salvia.Httpd (
+
+ -- Httpd.Core.Config
+ HttpdConfig (..)
+ , defaultConfig
+
+ -- Httpd.Core.Handler
+ , Context (..)
+ , makeContext
+
+ , Handler
+ , ResourceHandler
+ , UriHandler
+ , putRequest, putResponse, putQueue
+ , modRequest, modResponse, modQueue
+ , withRequest, withResponse
+
+ -- Httpd.Core.IO
+ , sendHeaders
+ , send
+ , sendStr
+ , sendStrLn
+ , sendBs
+ , spool
+ , spoolBs
+ , spoolAll
+ , spoolN
+ , emptyQueue
+ , reset
+
+ , contents
+ , contentsUtf8
+ , uriEncodedPostParamsUTF8
+
+ -- Httpd.Core.Main
+ , start
+
+ ) where
+
+import Network.Salvia.Core.Config
+import Network.Salvia.Core.Handler
+import Network.Salvia.Core.IO
+import Network.Salvia.Core.Main
+