"
+ ]
+
diff --git a/src/Network/Salvia/Handler/Dispatching.hs b/src/Network/Salvia/Handler/Dispatching.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Dispatching.hs
@@ -0,0 +1,48 @@
+module Network.Salvia.Handler.Dispatching (
+ Dispatcher
+ , ListDispatcher
+ , hDispatch
+ , hListDispatch
+ ) where
+
+import Data.Record.Label
+import Network.Salvia.Httpd
+
+{- |
+The dispatcher type takes one value to dispatch on and two handlers. The first
+handler will be used when the predicate on the dispatch value returned `True`,
+the second (default) handler will be used when the predicate returs
+`False`.
+-}
+
+type Dispatcher a b = a -> Handler b -> Handler b -> Handler b
+
+{- |
+A list dispatcher takes a mapping from dispatch values and handlers and one
+default handler.
+-}
+
+type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b
+
+{- |
+Dispatch on an arbitrary part of the context using an arbitrary predicate. When
+the predicate returns true on the value selected with the `Label` the first
+handler will be invoked, otherwise the second handler will be used.
+-}
+
+hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b
+hDispatch f match a handler _default = do
+ ctx <- getM f
+ if a `match` ctx
+ then handler
+ else _default
+
+{- |
+Turns a dispatcher function into a list dispatcher. This enables handler
+routing based on arbitrary values from the context. When non of the predicates
+in the `ListDispatcher` type hold the default handler will be invoked.
+-}
+
+hListDispatch :: Dispatcher a b -> ListDispatcher a b
+hListDispatch disp = flip $ foldr $ uncurry disp
+
diff --git a/src/Network/Salvia/Handler/Environment.hs b/src/Network/Salvia/Handler/Environment.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Environment.hs
@@ -0,0 +1,78 @@
+module Network.Salvia.Handler.Environment (
+ hDefaultEnv
+ , hSessionEnv
+ ) where
+
+import Control.Concurrent.STM
+import Network.Protocol.Http
+import Network.Salvia.Handler.Banner
+import Network.Salvia.Handler.Counter
+import Network.Salvia.Handler.Close
+import Network.Salvia.Handler.Error
+import Network.Salvia.Handler.Head
+import Network.Salvia.Handler.Log
+import Network.Salvia.Handler.Parser
+import Network.Salvia.Handler.Printer
+import Network.Salvia.Handler.Session
+import Network.Salvia.Httpd
+import System.IO
+
+{- |
+This is the default stateless handler evnironment. It takes care of request
+parsing (`hParser`), response printing (`hPrinter`), request logging (`hLog`),
+connection keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and
+printing the `salvia-httpd` server banner (`hBanner`).
+-}
+
+hDefaultEnv
+ :: Handler () -- ^ Handler to run in the default environment.
+ -> Handler ()
+hDefaultEnv handler =
+ hKeepAlive $
+ hParser (1000 * 15)
+ (wrapper Nothing . parseError)
+ (wrapper Nothing $ hHead handler)
+
+{- |
+This function is a more advanced version of the `hDefaultEnv` handler
+environment that takes a global state into account. It takes a shared variable
+containg the connection counter (used by `hCounter`) and a variable containing
+all session information (used by `hSession`). Handlers that run in this
+environment take should be parametrized with a session.
+-}
+
+hSessionEnv
+ :: TVar Int -- ^ Request count variable.
+ -> Sessions a -- ^ Session collection variable.
+ -> SessionHandler a () -- ^ Handler parametrized with current session.
+ -> Handler ()
+hSessionEnv count sessions handler =
+ hKeepAlive $
+ hParser (1000 * 15)
+ (wrapper (Just count) . parseError)
+ (wrapper (Just count) $
+ do session <- hSession sessions 300
+ hHead (handler session))
+
+-- Helper functions.
+
+before :: Handler ()
+before = hBanner "salvia-httpd"
+
+after :: Maybe (TVar Int) -> Handler ()
+after mc =
+ do hPrinter
+ maybe
+ (hLog stdout)
+ (\c -> hCounter c >> hLogWithCounter c stdout)
+ mc
+
+wrapper :: Maybe (TVar Int) -> Handler a -> Handler ()
+wrapper c h = before >> h >> after c
+
+parseError :: String -> Handler ()
+parseError err =
+ do hError BadRequest
+ sendStrLn []
+ sendStrLn err
+
diff --git a/src/Network/Salvia/Handler/Error.hs b/src/Network/Salvia/Handler/Error.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Error.hs
@@ -0,0 +1,58 @@
+module Network.Salvia.Handler.Error (
+ hError
+ , hCustomError
+ , hIOError
+ , safeIO
+ ) where
+
+import Control.Monad.State
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Salvia.Httpd
+import System.IO.Error
+
+{- |
+The 'hError' handler enables the creation of a default style of error responses
+for the specified HTTP `Status` code.
+-}
+
+hError :: Status -> Handler ()
+hError e = hCustomError e
+ (concat ["[", show (codeFromStatus e), "] ", show e, "\n"])
+
+{- | Like `hError` but with a custom error message. -}
+
+hCustomError :: Status -> String -> Handler ()
+hCustomError e m = do
+ enterM response $ do
+ setM status e
+ setM contentLength (Just $ length m)
+ setM contentType ("text/plain", Nothing)
+ sendStr m
+
+{- |
+Map an `IOError` to a default style error response.
+
+The mapping from an IO error to an error response is rather straightforward:
+
+> | isDoesNotExistError e = hError NotFound
+> | isAlreadyInUseError e = hError ServiceUnavailable
+> | isPermissionError e = hError Forbidden
+> | True = hError InternalServerError
+-}
+
+hIOError :: IOError -> Handler ()
+hIOError e
+ | isDoesNotExistError e = hError NotFound
+ | isAlreadyInUseError e = hError ServiceUnavailable
+ | isPermissionError e = hError Forbidden
+ | True = hError InternalServerError
+
+{- |
+Execute an handler with the result of an IO action. When the IO actions fails a
+default error handler will be executed.
+-}
+
+safeIO :: IO a -> (a -> Handler ()) -> Handler ()
+safeIO io h = lift (try io) >>= either hIOError h
+
diff --git a/src/Network/Salvia/Handler/ExtensionDispatcher.hs b/src/Network/Salvia/Handler/ExtensionDispatcher.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/ExtensionDispatcher.hs
@@ -0,0 +1,21 @@
+module Network.Salvia.Handler.ExtensionDispatcher (
+ hExtension
+ , hExtensionRouter
+ ) where
+
+import Data.Record.Label
+import Network.Protocol.Http (uri)
+import Network.Protocol.Uri (extension, path)
+import Network.Salvia.Handler.Dispatching
+import Network.Salvia.Httpd (request)
+
+{- | Request dispatcher based on the request path file extenstion. -}
+
+hExtension :: Dispatcher (Maybe String) a
+hExtension = hDispatch (extension % path % uri % request) (==)
+
+{- | List dispatcher version of `hExtension`. -}
+
+hExtensionRouter :: ListDispatcher (Maybe String) a
+hExtensionRouter = hListDispatch hExtension
+
diff --git a/src/Network/Salvia/Handler/Fallback.hs b/src/Network/Salvia/Handler/Fallback.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Fallback.hs
@@ -0,0 +1,33 @@
+module Network.Salvia.Handler.Fallback (hOr, hEither) where
+
+import Control.Applicative
+import Control.Monad.State
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Salvia.Httpd
+
+{- |
+Until I figure out how to do this correctly, this handler somewow implements
+the MonadPlus/Alternative instance using a custom function.
+
+When the first handler fails the response will be reset and the second handler
+is executed. Failure is indicated by an HTTP response `Status` bigger than or
+equal to 400 (`BadRequest`). See `statusFailure`.
+-}
+
+hOr :: Handler a -> Handler a -> Handler a
+hOr h0 h1 = do
+ a <- h0
+ st <- getM (status % response)
+ if statusFailure st
+ then reset >> h1
+ else return a
+
+{- |
+Like the `hOr` function, but the types of the alternatives may differ because
+the values are packed up in an `Either`.
+-}
+
+hEither :: Handler a -> Handler b -> Handler (Either a b)
+hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)
+
diff --git a/src/Network/Salvia/Handler/File.hs b/src/Network/Salvia/Handler/File.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/File.hs
@@ -0,0 +1,88 @@
+module Network.Salvia.Handler.File (
+ hFile
+ , hFileResource
+
+ , hFileFilter
+ , hFileResourceFilter
+
+ , hResource
+ , hUri
+ ) where
+
+import Control.Monad.State
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Protocol.Mime
+import Network.Protocol.Uri (mimetype, path, parseURI)
+import Network.Salvia.Handler.Error
+import Network.Salvia.Httpd
+import System.IO
+
+{- |
+Serve a file from the filesystem indicated by the specified filepath. When
+there is some kind of `IOError` the `safeIO` function will be used to produce a
+corresponding error response. The `contentType` will be the mime-type based on
+the filename extension using the `mimetype` function. The `contentLength` will
+be set the file's size.
+-}
+
+-- TODO: what to do with encoding?
+hFileResource :: ResourceHandler ()
+hFileResource file = do
+ let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)
+ safeIO (openBinaryFile file ReadMode)
+ $ \fd -> do
+ fs <- lift $ hFileSize fd
+ enterM response $ do
+ setM contentType (m, Just "utf-8")
+ setM contentLength (Just fs)
+ setM status OK
+ spoolBs id fd
+
+{- |
+Like the `hFileResource` handler, but with a custom filter over the content.
+This function will assume the content is an UTF-8 encoded text file. No
+`contentLength` header will be set using this handler.
+-}
+
+-- TODO: what to do with encoding?
+hFileResourceFilter :: (String -> String) -> ResourceHandler ()
+hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter
+ let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)
+ safeIO (openBinaryFile file ReadMode)
+ $ \fd -> do
+ enterM response $ do
+ setM contentType (m, Just "utf-8")
+ setM status OK
+ spool fFilter fd
+
+{- |
+Turn a resource handler into a regular handler that utilizes the path part of
+the request URI as the resource identifier.
+-}
+
+hResource :: ResourceHandler a -> Handler a
+hResource rh = getM (path % uri % request) >>= rh
+
+{- |
+Turn a URI handler into a regular handler that utilizes the request URI as the
+resource identifier.
+-}
+
+hUri :: UriHandler a -> Handler a
+hUri rh = getM (uri % request) >>= rh
+
+{- |
+Like `hFileResource` but uses the path of the current request URI.
+-}
+
+hFile :: Handler ()
+hFile = hResource hFileResource
+
+{- |
+Like `hFileResourceFilter` but uses the path of the current request URI.
+-}
+
+hFileFilter :: (String -> String) -> Handler ()
+hFileFilter = hResource . hFileResourceFilter
+
diff --git a/src/Network/Salvia/Handler/FileSystem.hs b/src/Network/Salvia/Handler/FileSystem.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/FileSystem.hs
@@ -0,0 +1,56 @@
+module Network.Salvia.Handler.FileSystem (
+ hFileSystem
+ , hFileSystemNoIndexes
+ , hFileTypeDispatcher
+ ) where
+
+import Control.Monad.State
+import Data.Record.Label
+import Misc.Misc (bool)
+import Network.Protocol.Http
+import Network.Protocol.Uri (jail, path)
+import Network.Salvia.Handler.Directory
+import Network.Salvia.Handler.Error
+import Network.Salvia.Handler.File
+import Network.Salvia.Httpd
+import System.Directory (doesDirectoryExist)
+
+{- |
+Dispatch based on file type; regular files or directories. The first handler
+specified will be invoked in case the resource to be served is an directory,
+the second handler otherwise. The path from the request URI will be appended to
+the directory resource specified as a parameter, this new path will be used to
+lookup the real resource on the file system. Every request will be jailed in
+the specified directory resource to prevent users from requesting arbitrary
+parts of the file system.
+-}
+
+hFileTypeDispatcher :: ResourceHandler () -> ResourceHandler () -> ResourceHandler ()
+hFileTypeDispatcher hdir hfile dir =
+ getM (path % uri % request) >>=
+ hJailedDispatch dir hdir hfile . (dir ++)
+
+{- |
+Serve single directory by combining the `hDirectoryResource` and
+`hFileResource` handlers in the `hFileTypeDispatcher`.
+-}
+
+hFileSystem :: ResourceHandler ()
+hFileSystem = hFileTypeDispatcher hDirectoryResource hFileResource
+
+{- |
+Serve single directory like `hFileSystem` but do not show directory indices.
+Instead of an directory index an `Forbidden` response will be created.
+-}
+
+-- Show file contents, do not show directory indexes.
+hFileSystemNoIndexes :: ResourceHandler ()
+hFileSystemNoIndexes = hFileTypeDispatcher (const $ hError Forbidden) hFileResource
+
+hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler ()
+hJailedDispatch dir hdir hfile file = do
+ case jail dir file of
+ Nothing -> hError Forbidden
+ Just f -> bool (hdir file) (hfile file)
+ =<< lift (doesDirectoryExist f)
+
diff --git a/src/Network/Salvia/Handler/Head.hs b/src/Network/Salvia/Handler/Head.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Head.hs
@@ -0,0 +1,23 @@
+module Network.Salvia.Handler.Head (hHead) where
+
+import Control.Applicative
+import Control.Monad.State (put)
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Salvia.Httpd
+
+{- |
+The 'hHead' handler makes sure no response body is sent to the client when the
+request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the
+specified sub handler will be executed under the assumption that the request
+was a 'GET' request, otherwise this handler will act as the identify function.
+-}
+
+hHead :: Handler a -> Handler a
+hHead handler = do
+ m <- getM (method % request)
+ case m of
+ HEAD -> withM (method % request) (put GET) $
+ handler <* emptyQueue
+ _ -> handler
+
diff --git a/src/Network/Salvia/Handler/Log.hs b/src/Network/Salvia/Handler/Log.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Log.hs
@@ -0,0 +1,47 @@
+module Network.Salvia.Handler.Log (
+ hLog
+ , hLogWithCounter
+ ) where
+
+import Control.Concurrent.STM
+import Control.Monad.State
+import Data.Record.Label
+import Misc.Terminal (red, green, reset)
+import Network.Protocol.Http
+import Network.Salvia.Httpd (Handler, request, response, address)
+import System.IO
+
+{- |
+A simple logger that prints a summery of the request information to the
+specified file handle.
+-}
+
+hLog :: Handle -> Handler ()
+hLog = logger Nothing
+
+{- | Like `hLog` but also prints the request count since server startup. -}
+
+hLogWithCounter :: TVar Int -> Handle -> Handler ()
+hLogWithCounter a = logger (Just a)
+
+logger :: Maybe (TVar Int) -> Handle -> Handler ()
+logger count handle = do
+ c <- case count of
+ Nothing -> return ""
+ Just c' -> liftIO (show `liftM` atomically (readTVar c'))
+ mt <- getM (method % request)
+ ur <- getM (uri % request)
+ st <- getM (status % response)
+ addr <- getM address
+ let code = codeFromStatus st
+ clr = if code >= 400 then red else green
+ liftIO $ hPutStrLn handle $ concat [
+ concat ["[", show addr, "] ", c, "\t"]
+ , show mt, "\t"
+ , show ur, " -> "
+ , clr
+ , show code, " "
+ , show st
+ , reset
+ ]
+
diff --git a/src/Network/Salvia/Handler/Login.hs b/src/Network/Salvia/Handler/Login.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Login.hs
@@ -0,0 +1,276 @@
+module Network.Salvia.Handler.Login (
+
+ -- * Basic types.
+ Username
+ , Password
+ , Action
+ , Actions
+ , User (..)
+ , Users
+ , UserDatabase
+ , TUserDatabase
+
+ -- * User Sessions.
+ , UserPayload (..)
+ , UserSession
+ , TUserSession
+ , UserSessionHandler
+
+ -- * Handlers.
+ , hSignup
+ , hLogin
+ , hLogout
+ , hLoginfo
+
+ , hAuthorized
+ , hAuthorizedUser
+
+ -- * Helper functions.
+ , readUserDatabase
+
+ ) where
+
+import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)
+import Control.Monad.State (lift, liftM)
+import Data.Digest.Pure.MD5 (md5)
+import Data.List (intercalate)
+import Data.Maybe (catMaybes)
+import Data.Record.Label
+import Misc.Misc (atomModTVar, safeHead)
+import Network.Protocol.Http (Status (Unauthorized, OK), status)
+import Network.Salvia.Handler.Error (hCustomError, hError)
+import Network.Salvia.Handler.Session
+import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)
+import Network.Protocol.Uri
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+-------------------------------------------------------------------------------
+
+type Username = String
+type Password = String
+type Action = String
+type Actions = [Action]
+
+{- |
+User containg a username, password and a list of actions this user is allowed
+to perform within the system.
+-}
+
+data User = User {
+ username :: Username
+ , password :: Password
+ , email :: String
+ , actions :: Actions
+ } deriving (Eq, Show)
+
+type Users = [User]
+
+{- |
+A user database containing a list of users, a list of default actions the guest
+or `no-user' user is allowed to perform and a polymorphic reference to the
+place the database originates from. This source field can be used by update
+functions synchronizing changes back to the database.
+-}
+
+data UserDatabase src =
+ UserDatabase {
+ dbUsers :: Users
+ , dbGuest :: Actions
+ , dbSource :: src
+ } deriving Show
+
+type TUserDatabase src = TVar (UserDatabase src)
+
+{- |
+A user payload instance contains user related session information and can be
+used as the payload for regular sessions. It contains a reference to the user
+it is bound to, a flag to indicate whether the user is logged in or not and a
+possible user specific session payload.
+-}
+
+data UserPayload a = UserPayload {
+ upUser :: User
+ , upLoggedIn :: Bool
+ , upPayload :: Maybe a
+ } deriving (Eq, Show)
+
+type UserSession a = Session (UserPayload a)
+type TUserSession a = TSession (UserPayload a)
+
+{- | A handler that requires a session with a user specific payload. -}
+
+type UserSessionHandler a b = SessionHandler (UserPayload a) b
+
+-------------------------------------------------------------------------------
+
+{-|
+Read a user data from file. Format: /username password email action*/.
+-}
+
+readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)
+readUserDatabase file = do
+
+ -- First line contains the default `guest` actions, tail lines contain users.
+ gst:ls <- lines `liftM` readFile file
+
+ atomically $ newTVar $ UserDatabase
+ (catMaybes $ map parseUserLine ls)
+ (words gst)
+ file
+ where
+ parseUserLine line =
+ case words line of
+ user:pass:mail:acts -> Just (User user pass mail acts)
+ _ -> Nothing
+
+printUserLine :: User -> String
+printUserLine u = intercalate " " ([
+ username u
+ , password u
+ , email u
+ ] ++ actions u)
+
+{- |
+The signup handler is used to create a new entry in the user database. It reads
+a new username and password from the HTTP POST parameters and adds a new entry
+in the database when no user with such name exists. The user gets the specified
+initial set of actions assigned. On failure an `Unauthorized' error will be
+produced.
+-}
+
+hSignup :: TUserDatabase FilePath -> Actions -> Handler ()
+hSignup tdb acts = do
+ db <- lift . atomically $ readTVar tdb
+ params <- uriEncodedPostParamsUTF8
+ case freshUserInfo params (dbUsers db) acts of
+ Nothing -> hCustomError Unauthorized "signup failed"
+ Just u -> do
+ lift $ do
+ atomically
+ $ writeTVar tdb
+ $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)
+ appendFile (dbSource db) (printUserLine u)
+
+freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User
+freshUserInfo params us acts = do
+ p <- params
+ user <- "username" `lookup` p >>= id
+ pass <- "password" `lookup` p >>= id
+ mail <- "email" `lookup` p >>= id
+ case safeHead $ filter ((==user).username) us of
+ Nothing -> return $ User user (show $ md5 $ fromString pass) mail acts
+ Just _ -> Nothing
+
+-------------------------------------------------------------------------------
+
+{- |
+The login handler. Read the username and password values from the post data and
+use that to authenticate the user. When the user can be found in the database
+the user is logged in and stored in the session payload. Otherwise a
+`Unauthorized' response will be sent and the user has not logged in.
+-}
+
+hLogin :: UserDatabase b -> UserSessionHandler a ()
+hLogin db session = do
+ params <- uriEncodedPostParamsUTF8
+ maybe
+ (hCustomError Unauthorized "login failed")
+ (loginSuccessful session)
+ (authenticate params db)
+
+authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User
+authenticate params db = do
+ p <- params
+ user <- "username" `lookup` p >>= id
+ pass <- "password" `lookup` p >>= id
+ case safeHead $ filter ((==user).username) (dbUsers db) of
+ Nothing -> Nothing
+ Just u ->
+ if password u == (show $ md5 $ fromString pass)
+ then return u
+ else Nothing
+
+-- Login user and create `Ok' response on successful user.
+loginSuccessful :: TUserSession a -> User -> Handler ()
+loginSuccessful session user = do
+ lift $ atomModTVar (\s -> s {sPayload = Just (UserPayload user True Nothing)}) session
+ setM (status % response) OK
+ sendStrLn "login successful"
+
+-------------------------------------------------------------------------------
+
+{- | Logout the current user by emptying the session payload. -}
+
+hLogout :: TUserSession a -> Handler ()
+hLogout session = do
+ lift $ atomModTVar (\s -> s {sPayload = Nothing}) session
+ return ()
+
+-------------------------------------------------------------------------------
+
+{- |
+The `loginfo' handler exposes the current user session to the world using a
+simple text based file. The file contains information about the current session
+identifier, session start and expiration date and the possible user payload
+that is included.
+-}
+
+hLoginfo :: UserSessionHandler a ()
+hLoginfo session = do
+ s' <- lift $ atomically $ readTVar session
+
+ sendStrLn $ "sID=" ++ show (sID s')
+ sendStrLn $ "start=" ++ show (sStart s')
+ sendStrLn $ "expire=" ++ show (sExpire s')
+
+ case sPayload s' of
+ Nothing -> return ()
+ Just (UserPayload (User uname _ mail acts) _ _) -> do
+ sendStrLn $ "username=" ++ uname
+ sendStrLn $ "email=" ++ mail
+ sendStrLn $ "actions=" ++ intercalate " " acts
+
+-------------------------------------------------------------------------------
+
+{- |
+Execute a handler only when the user for the current session is authorized to
+do so. The user must have the specified action contained in its actions list in
+order to be authorized. Otherwise an `Unauthorized' error will be produced.
+When no user can be found in the current session or this user is not logged in
+the guest account from the user database is used for authorization.
+-}
+
+hAuthorized ::
+ UserDatabase b -- ^ The user database to read guest account from.
+ -> Action -- ^ The actions that should be authorized.
+ -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized.
+ -> UserSessionHandler a () -- ^ This handler requires a user session.
+
+hAuthorized db action handler session = do
+ load <- liftM sPayload (lift $ atomically $ readTVar session)
+ case load of
+ Just (UserPayload user _ _)
+ | action `elem` actions user -> handler (Just user)
+ Nothing
+ | action `elem` dbGuest db -> handler Nothing
+ _ -> hError Unauthorized
+
+{- |
+Execute a handler only when the user for the current session is authorized to
+do so. The user must have the specified action contained in its actions list in
+order to be authorized. Otherwise an `Unauthorized' error will be produced. The
+guest user will not be used in any case.
+-}
+
+hAuthorizedUser ::
+ Action -- ^ The actions that should be authorized.
+ -> (User -> Handler ()) -- ^ The handler to perform when authorized.
+ -> UserSessionHandler a () -- ^ This handler requires a user session.
+
+hAuthorizedUser action handler session = do
+ load <- liftM sPayload (lift $ atomically $ readTVar session)
+ case load of
+ Just (UserPayload user _ _)
+ | action `elem` actions user -> handler user
+ _ -> hError Unauthorized
+
diff --git a/src/Network/Salvia/Handler/MethodRouter.hs b/src/Network/Salvia/Handler/MethodRouter.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/MethodRouter.hs
@@ -0,0 +1,78 @@
+module Network.Salvia.Handler.MethodRouter (
+ hMethod
+ , hMethodRouter
+
+ , hOPTIONS
+ , hGET
+ , hHEAD
+ , hPOST
+ , hPUT
+ , hDELETE
+ , hTRACE
+ , hCONNECT
+ ) where
+
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Salvia.Handler.Dispatching
+import Network.Salvia.Handler.Error
+import Network.Salvia.Httpd
+
+{- |
+Request dispatcher based on the HTTP request `Method`. When the method does not
+match an HTTP `NotFound` will be created and `Nothing` will be returned.
+-}
+
+hMethod :: Method -> Handler a -> Handler (Maybe a)
+hMethod m h = hMethod' m
+ (Just `fmap` h)
+ (const Nothing `fmap` hError NotFound)
+
+{- | Request list dispatcher based on the `hMethod` dispatcher. -}
+
+hMethodRouter :: ListDispatcher Method ()
+hMethodRouter = hListDispatch hMethod'
+
+{- | Only invoke a handler on an `OPTIONS` request. -}
+
+hOPTIONS :: Handler a -> Handler (Maybe a)
+hOPTIONS = hMethod OPTIONS
+
+{- | Only invoke a handler on a `GET` request. -}
+
+hGET :: Handler a -> Handler (Maybe a)
+hGET = hMethod GET
+
+{- | Only invoke a handler on a `HEAD` request. -}
+
+hHEAD :: Handler a -> Handler (Maybe a)
+hHEAD = hMethod HEAD
+
+{- | Only invoke a handler on a `POST` request. -}
+
+hPOST :: Handler a -> Handler (Maybe a)
+hPOST = hMethod POST
+
+{- | Only invoke a handler on a `PUT` request. -}
+
+hPUT :: Handler a -> Handler (Maybe a)
+hPUT = hMethod PUT
+
+{- | Only invoke a handler on a `DELETE` request. -}
+
+hDELETE :: Handler a -> Handler (Maybe a)
+hDELETE = hMethod DELETE
+
+{- | Only invoke a handler on a `TRACE` request. -}
+
+hTRACE :: Handler a -> Handler (Maybe a)
+hTRACE = hMethod TRACE
+
+{- | Only invoke a handler on a `CONNECT` request. -}
+
+hCONNECT :: Handler a -> Handler (Maybe a)
+hCONNECT = hMethod CONNECT
+
+hMethod' :: Dispatcher Method a
+hMethod' = hDispatch (method % request) (==)
+
diff --git a/src/Network/Salvia/Handler/Parser.hs b/src/Network/Salvia/Handler/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Parser.hs
@@ -0,0 +1,51 @@
+module Network.Salvia.Handler.Parser (hParser) where
+
+import Control.Monad.State
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Salvia.Httpd
+import System.IO
+import System.Timeout
+
+{- |
+The 'hParser' handler is used to parse the raw request message into the
+'Message' data type. This handler is generally used as (one of) the first
+handlers in an environment. The first handler argument is executed when the
+request is invalid, possibly due to parser errors, and is parametrized with the
+error string. The second handler argument is executed when the request is
+valid. When the message could be parsed within the time specified with the
+first argument the function silently returns.
+-}
+
+hParser ::
+ Int -- ^ Timeout in milliseconds.
+ -> (String -> Handler ()) -- ^ The fail handler.
+ -> Handler () -- ^ The success handler.
+ -> Handler ()
+
+hParser t onfail onsuccess = do
+ h <- getM sock
+ -- TODO use try and fail with bad request or reject silently.
+ mMsg <- liftIO $ timeout (t * 1000) $
+ -- TODO: Using NoBuffering here may crash the entire program (GHC
+ -- runtime?) when processing more requests than just a few:
+ do hSetBuffering h (BlockBuffering (Just (64*1024)))
+ fmap Just (readHeader h) `catch` const (return Nothing)
+ case join mMsg of
+ Nothing -> return ()
+ Just msg ->
+ do case parseRequest (msg "") of
+ Left err -> onfail (show err)
+ Right x -> do
+ setM request x
+ onsuccess
+
+-- Read all lines until the first empty line.
+readHeader :: Handle -> IO (String -> String)
+readHeader h = do
+ l <- hGetLine h
+ let lf = showChar '\n'
+ if l `elem` ["", "\r"]
+ then return lf
+ else liftM ((showString l . lf) .) (readHeader h)
+
diff --git a/src/Network/Salvia/Handler/PathRouter.hs b/src/Network/Salvia/Handler/PathRouter.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/PathRouter.hs
@@ -0,0 +1,45 @@
+module Network.Salvia.Handler.PathRouter (
+ hPath
+ , hPathRouter
+ , hPrefix
+ , hPrefixRouter
+
+ , hParameters
+ ) where
+
+import Control.Monad.State
+import Data.List (isPrefixOf)
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Protocol.Uri (path, queryParams, Parameters)
+import Network.Salvia.Handler.Dispatching
+import Network.Salvia.Httpd
+
+{- | Request dispatcher based on the request path. -}
+
+hPath :: Dispatcher String a
+hPath p h = hDispatch (path % uri % request) (==) p (chop p h)
+
+{- | List dispatcher version of `hPath`. -}
+
+hPathRouter :: ListDispatcher String b
+hPathRouter = hListDispatch hPath
+
+{- | Request dispatcher based on a prefix of the request path. -}
+
+hPrefix :: Dispatcher String a
+hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)
+
+{- | List dispatcher version of `hPrefix`. -}
+
+hPrefixRouter :: ListDispatcher String b
+hPrefixRouter = hListDispatch hPrefix
+
+{- | Helper function to fetch the URI parameters from the request. -}
+
+hParameters :: Handler Parameters
+hParameters = getM (uri % request) >>= return . queryParams
+
+chop :: String -> Handler a -> Handler a
+chop a = withM (path % uri % request) (modify (drop $ length a))
+
diff --git a/src/Network/Salvia/Handler/Printer.hs b/src/Network/Salvia/Handler/Printer.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Printer.hs
@@ -0,0 +1,15 @@
+module Network.Salvia.Handler.Printer (hPrinter) where
+
+import Network.Salvia.Httpd
+
+{- |
+The 'hPrinter' handler print the entire response including the headers to the
+client. This handler is generally used as (one of) the last handler in a
+handler environment.
+-}
+
+hPrinter :: Handler ()
+hPrinter =
+ do flushHeaders
+ flushQueue
+
diff --git a/src/Network/Salvia/Handler/Put.hs b/src/Network/Salvia/Handler/Put.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Put.hs
@@ -0,0 +1,26 @@
+module Network.Salvia.Handler.Put (hPut) where
+
+import Control.Monad.State
+import Network.Protocol.Http
+import Network.Salvia.Handler.Error
+import Network.Salvia.Httpd
+import System.IO
+import qualified Data.ByteString.Lazy as B
+
+{- |
+First naive handler for the HTTP `PUT` request. This probably does not handle
+all the quirks that the HTTP protocol specifies, but it does the job for now.
+When a 'contentLength' header field is available only this fixed number of
+bytes will be spooled from socket to the resource. When both the `keepAlive'
+and 'contentLength' header fields are not available the entire payload of the
+request is spooled to the resource.
+-}
+
+hPut :: ResourceHandler ()
+hPut name =
+ safeIO (openBinaryFile name WriteMode)
+ $ (contents >>=) . maybe putError . putOk
+ where
+ putError = hError NotImplemented
+ putOk fd c = lift (B.hPut fd c >> hClose fd)
+
diff --git a/src/Network/Salvia/Handler/Redirect.hs b/src/Network/Salvia/Handler/Redirect.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Redirect.hs
@@ -0,0 +1,18 @@
+module Network.Salvia.Handler.Redirect (hRedirect) where
+
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Protocol.Uri (URI)
+import Network.Salvia.Httpd
+
+{- |
+Redirect a client to another location by creating a `MovedPermanently` response
+message with the specified `URI` in the `location' header.
+-}
+
+hRedirect :: URI -> Handler ()
+hRedirect u =
+ enterM response $ do
+ setM location (Just u)
+ setM status MovedPermanently
+
diff --git a/src/Network/Salvia/Handler/Rewrite.hs b/src/Network/Salvia/Handler/Rewrite.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Rewrite.hs
@@ -0,0 +1,60 @@
+module Network.Salvia.Handler.Rewrite (
+ hRewrite
+ , hRewritePath
+ , hRewriteHost
+ , hRewriteExt
+ , hWithDir
+ , hWithoutDir
+ ) where
+
+import Control.Monad.State
+import Data.List (isPrefixOf)
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Protocol.Uri (URI, host, path, extension)
+import Network.Salvia.Httpd
+
+{- |
+Run an handler in a modified context in which the request `URI` has been
+changed by the specified modifier function. After the handler completes the `URI`
+remains untouched.
+-}
+
+hRewrite :: (URI -> URI) -> Handler a -> Handler a
+hRewrite f = withM (uri % request) (modify f)
+
+-- express these below in terms of the above?
+
+{- | Run handler in a context with a modified host. -}
+
+hRewriteHost :: (String -> String) -> Handler a -> Handler a
+hRewriteHost f = withM (host % uri % request) (modify f)
+
+{- | Run handler in a context with a modified path. -}
+
+hRewritePath :: (String -> String) -> Handler a -> Handler a
+hRewritePath f = withM (path % uri % request) (modify f)
+
+{- | Run handler in a context with a modified file extension. -}
+
+hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a
+hRewriteExt f = withM (extension % path % uri % request) (modify f)
+
+{- |
+Run handler in a context with a modified path. The specified prefix will be
+prepended to the path.
+-}
+
+hWithDir :: String -> Handler a -> Handler a
+hWithDir d = hRewritePath (d++)
+
+{- |
+Run handler in a context with a modified path. The specified prefix will be
+stripped form the path.
+-}
+
+hWithoutDir :: String -> Handler a -> Handler a
+hWithoutDir d h = do
+ p <- getM (path % uri % request)
+ (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h
+
diff --git a/src/Network/Salvia/Handler/Session.hs b/src/Network/Salvia/Handler/Session.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/Session.hs
@@ -0,0 +1,192 @@
+module Network.Salvia.Handler.Session (
+ hSession
+
+ , SessionID
+ , Session (..)
+ , TSession
+ , SessionHandler
+ , Sessions
+
+ , mkSessions
+ ) where
+
+import Control.Applicative hiding (empty)
+import Control.Concurrent.STM
+import Control.Monad.State
+import Data.Time.LocalTime
+import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)
+import Network.Protocol.Cookie hiding (empty)
+import Network.Salvia.Handler.Cookie
+import Network.Salvia.Httpd
+import Prelude hiding (lookup)
+import System.Random
+import qualified Data.Map as M
+
+-------------------------------------------------------------------------------
+
+{- | A session identifier. Should be unique for every session. -}
+
+newtype SessionID = SID Integer
+ deriving (Eq, Ord)
+
+{- | The session data type with polymorphic payload. -}
+
+data Session a = Session {
+ sID :: SessionID -- ^ A globally unique session identifier.
+ , sStart :: LocalTime -- ^ The time the session started.
+ , sExpire :: LocalTime -- ^ The time after which the session is expired.
+ , sPayload :: Maybe a -- ^ The information this session stores.
+ } deriving Show
+
+{- | A shared session. -}
+
+type TSession a = TVar (Session a)
+
+{- | A handler that expects a session. -}
+
+type SessionHandler a b = TSession a -> Handler b
+
+{- | Create a new, empty, shared session. -}
+
+mkSession :: SessionID -> LocalTime -> IO (TSession a)
+mkSession sid e = do
+ s <- now
+ atomically $ newTVar $ Session sid s e Nothing
+
+-------------------------------------------------------------------------------
+
+{- | A mapping from unique session IDs to shared session variables. -}
+
+type Sessions a = TVar (M.Map SessionID (TSession a))
+
+instance Show SessionID where
+ show (SID sid) = show sid
+
+{- | Create a new, empty, store of sessions. -}
+
+mkSessions :: IO (Sessions a)
+mkSessions = atomically $ newTVar M.empty
+
+-------------------------------------------------------------------------------
+
+{- |
+The session handler. This handler will try to return an existing session from
+the sessions map based on a session identifier found in the HTTP `cookie`. When
+such a session can be found the expiration date will be updated to a number of
+seconds in the future. When no session can be found a new one will be created.
+A cookie will be set that informs the client of the current session.
+-}
+
+hSession
+ :: Sessions a -- ^ Map of shared session variables.
+ -> Integer -- ^ Number of seconds to be added to the session expiritation time.
+ -> Handler (TSession a)
+hSession smap expiration = do
+
+ -- Get the session identifier from an existing cookie or create a new one.
+ prev <- getSessionID <$> hGetCookies
+
+ -- Compute current time and expiration time.
+ (n, ex) <- lift $ liftM2 (,) now (later expiration)
+
+ -- Either create a new session or try to reuse current one.
+ tsession <-
+ maybe
+ (newSession smap ex)
+ (existingSession smap ex n)
+ prev
+
+ setSessionCookie tsession ex
+ return tsession
+
+-------------------------------------------------------------------------------
+
+{-
+Given the (possible wrong) request cookie, try to recover the existing --
+session identifier.
+-}
+
+getSessionID :: Maybe Cookies -> Maybe SessionID
+getSessionID prev = do
+ ck <- prev
+ sid <- cookie "sid" ck
+ sid' <- safeRead $ value sid
+ return (SID sid')
+
+{-
+Generate a fresh, random session identifier using the default system random
+generator.
+-}
+
+genSessionID :: IO SessionID
+genSessionID = do
+ g <- getStdGen
+ let (sid, g') = random g
+ setStdGen g'
+ return (SID (abs sid))
+
+
+{-
+This handler sets the HTTP cookie for the specified session. It will use a
+default cookie with an additional `sid' attribute with the session identifier
+as value. The session expiration date will be used as the cookie expire field.
+-}
+
+setSessionCookie :: TSession a -> LocalTime -> Handler ()
+setSessionCookie tsession ex = do
+ ck <- newCookie ex
+ sid <- lift $ liftM sID $ atomReadTVar tsession
+ hSetCookies $
+ cookies [ck {
+ name = "sid"
+ , value = show sid
+ }]
+
+{-
+Handler when no (valid) session is available. Create a new session with a
+specified expiration date. The session will be stored in the session map.
+-}
+
+newSession :: Sessions a -> LocalTime -> Handler (TSession a)
+newSession sessions ex = lift $ do
+
+ -- Fresh session identifier.
+ sid <- genSessionID
+
+ -- Fresh session.
+ session <- mkSession sid ex
+
+ -- Place in session mapping usinf session identifier as key.
+ atomModTVar (M.insert sid session) sessions
+ return session
+
+{-
+Handler for existing sessions. Given an existing session identifier lookup a
+session from the session map. When no session is available, or the session is
+expired, create a new one using the `newSession' function. Otherwise the
+expiration date of the existing session is updated.
+-}
+
+existingSession ::
+ Sessions a -> LocalTime -> LocalTime
+ -> SessionID -> Handler (TSession a)
+existingSession sessions ex n sid = do
+
+ -- Lookup the session in the session map given the session identifier.
+ mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)
+ case mtsession of
+
+ -- Unrecognized session identifiers are penalised by a fresh session.
+ Nothing -> newSession sessions ex
+ Just tsession -> do
+ expd <- lift $ liftM sExpire (atomReadTVar tsession)
+ if expd < n
+
+ -- Session is expired, create a new one.
+ then newSession sessions ex
+
+ -- Existing session, update expiration date.
+ else lift $ do
+ atomModTVar (\s -> s {sExpire = ex}) tsession
+ return tsession
+
diff --git a/src/Network/Salvia/Handler/VirtualHosting.hs b/src/Network/Salvia/Handler/VirtualHosting.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handler/VirtualHosting.hs
@@ -0,0 +1,34 @@
+module Network.Salvia.Handler.VirtualHosting (
+ hHostRouter
+ , hVirtualHosting
+ ) where
+
+import Data.Ord
+import Data.List
+import Data.Record.Label
+import Network.Protocol.Http
+import Network.Protocol.Uri
+import Network.Salvia.Handler.Dispatching
+import Network.Salvia.Httpd hiding (hostname)
+
+{- |
+List dispatcher based on the host part of the hostname request header.
+Everything not part of the real hostname (like the port number) will be
+ignored.
+-}
+
+hVirtualHosting :: ListDispatcher String a
+hVirtualHosting = (hListDispatch disp) . parse
+ where
+ disp = hDispatch (hostname % request) cmp
+ parse = map (\(a, b) -> (parseAuthority a, b))
+ cmp a b = (==EQ) $ comparing (fmap (lget _host)) a b
+
+{- |
+List dispatcher based on the hostname request header. This header field is
+parsed and interpreted as an `Authority` field.
+-}
+
+hHostRouter :: ListDispatcher (Maybe Authority) a
+hHostRouter = hListDispatch $ hDispatch (hostname % request) (==)
+
diff --git a/src/Network/Salvia/Handlers.hs b/src/Network/Salvia/Handlers.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Salvia/Handlers.hs
@@ -0,0 +1,213 @@
+module Network.Salvia.Handlers (
+
+ -- * Fundamental protocol handlers.
+
+ -- ** Default handler environments.
+
+ hDefaultEnv
+ , hSessionEnv
+
+ -- ** Parse client requests.
+
+ , hParser
+
+ -- ** Print server responses.
+
+ , hPrinter
+
+ -- ** HTTP header banner.
+
+ , hBanner
+
+ -- ** Closing or keeping alive connections.
+
+ , hCloseConn
+ , hKeepAlive
+
+ -- ** Enable HTTP HEAD requests.
+
+ , hHead
+
+ -- * Error handling and logging.
+
+ -- ** Default error handlers.
+
+ , hError
+ , hCustomError
+ , hIOError
+ , safeIO
+
+ -- ** Logging of client requests.
+
+ , hLog
+ , hLogWithCounter
+
+ -- ** Fallback handlers.
+
+ , hOr
+ , hEither
+
+ -- ** Request counter.
+
+ , hCounter
+
+ -- * Redirecting and rewriting.
+
+ -- ** Redirecting the client.
+
+ , hRedirect
+
+ -- ** Request URI rewriting.
+
+ , hRewrite
+ , hRewriteHost
+ , hRewritePath
+ , hRewriteExt
+ , hWithDir
+ , hWithoutDir
+
+ -- * File and directory serving.
+
+ -- ** Serve static file resources.
+
+ , hFileResource
+ , hFileResourceFilter
+ , hResource
+ , hUri
+ , hFile
+ , hFileFilter
+
+ -- ** Serve directory indices.
+
+ , hDirectory
+ , hDirectoryResource
+
+ -- ** Serve file system directory.
+
+ , hFileTypeDispatcher
+ , hFileSystem
+ , hFileSystemNoIndexes
+
+ -- ** Enable PUTing resources to the files ystem.
+
+ , hPut
+
+ -- ** Serving CGI scripts.
+
+ , hCGI
+
+ -- * Dispatching.
+
+ -- ** Custom request dispatchers.
+
+ , Dispatcher
+ , ListDispatcher
+ , hDispatch
+ , hListDispatch
+
+ -- ** Dispatch based on request method.
+
+ , hMethod
+ , hMethodRouter
+
+ , hOPTIONS
+ , hGET
+ , hHEAD
+ , hPOST
+ , hPUT
+ , hDELETE
+ , hTRACE
+ , hCONNECT
+
+ -- ** Dispatch based on request path.
+
+ , hPath
+ , hPathRouter
+ , hPrefix
+ , hPrefixRouter
+ , hParameters
+
+ -- ** Dispatch based on filename extension.
+
+ , hExtension
+ , hExtensionRouter
+
+ -- ** Dispatch based on host name.
+
+ , hHostRouter
+ , hVirtualHosting
+
+ -- * Session and user management.
+
+ -- ** Cookie handling.
+
+ , hSetCookies
+ , hGetCookies
+ , newCookie
+
+ -- ** Session management.
+
+ , hSession
+
+ , SessionID
+ , Session (..)
+ , TSession
+ , SessionHandler
+ , Sessions
+
+ , mkSessions
+
+ -- ** User management.
+
+ , Username
+ , Password
+ , Action
+ , Actions
+ , User (..)
+ , Users
+ , UserDatabase
+ , TUserDatabase
+
+ , UserPayload (..)
+ , UserSession
+ , TUserSession
+ , UserSessionHandler
+
+ , hSignup
+ , hLogin
+ , hLogout
+ , hLoginfo
+
+ , hAuthorized
+ , hAuthorizedUser
+
+ , readUserDatabase
+
+ ) where
+
+import Network.Salvia.Handler.Banner
+import Network.Salvia.Handler.CGI
+import Network.Salvia.Handler.Close
+import Network.Salvia.Handler.Cookie
+import Network.Salvia.Handler.Counter
+import Network.Salvia.Handler.Directory
+import Network.Salvia.Handler.Dispatching
+import Network.Salvia.Handler.Environment
+import Network.Salvia.Handler.Error
+import Network.Salvia.Handler.ExtensionDispatcher
+import Network.Salvia.Handler.Fallback
+import Network.Salvia.Handler.File
+import Network.Salvia.Handler.FileSystem
+import Network.Salvia.Handler.Head
+import Network.Salvia.Handler.Log
+import Network.Salvia.Handler.Login
+import Network.Salvia.Handler.MethodRouter
+import Network.Salvia.Handler.Parser
+import Network.Salvia.Handler.PathRouter
+import Network.Salvia.Handler.Printer
+import Network.Salvia.Handler.Put
+import Network.Salvia.Handler.Redirect
+import Network.Salvia.Handler.Rewrite
+import Network.Salvia.Handler.Session
+import Network.Salvia.Handler.VirtualHosting
+
diff --git a/src/Network/Salvia/Handlers/Banner.hs b/src/Network/Salvia/Handlers/Banner.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Banner.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module Network.Salvia.Handlers.Banner (hBanner) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Format (formatTime)
-import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-import System.Locale (defaultTimeLocale)
-
--- | The 'hBanner' handler adds the current date-/timestamp and a custom server
--- name to the response headers.
-
-hBanner ::
- String -- ^ The HTTP server name.
- -> Handler ()
-hBanner sv = do
- dt <- lift $ do
- zone <- getCurrentTimeZone
- time <- liftM (utcToLocalTime zone) getCurrentTime
- return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time
- enterM response $ do
- setM date dt
- setM server sv
-
diff --git a/src/Network/Salvia/Handlers/CGI.hs b/src/Network/Salvia/Handlers/CGI.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/CGI.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Network.Salvia.Handlers.CGI (hCGI) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-import System.IO
-import System.Process (runProcess, waitForProcess)
-
-hCGI :: FilePath -> Handler ()
-hCGI name = do
- setM (status % response) OK
- h <- getM sock
- lift $ do
- p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr)
- waitForProcess p
- return ()
-
diff --git a/src/Network/Salvia/Handlers/Cookie.hs b/src/Network/Salvia/Handlers/Cookie.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Cookie.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module Network.Salvia.Handlers.Cookie (
- hSetCookies
- , hGetCookies
-
- , newCookie
- ) where
-
-import Control.Applicative hiding (empty)
-import Control.Monad.State
-import Data.Record.Label
-import Data.Time.Format
-import Data.Time.LocalTime
-import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires)
-import Network.Protocol.Http (cookie)
-import Network.Salvia.Httpd
-import System.Locale (defaultTimeLocale)
-
-hSetCookies :: Cookies -> Handler ()
-hSetCookies = setM (cookie % response) . showCookies
-
-hGetCookies :: Handler (Maybe Cookies)
-hGetCookies = parseCookies <$> getM (cookie % request)
-
--- Convenient method for creating cookies that expire in the near future and
--- are bound to the domain and port this server runs on. The path will be
--- locked to root.
-newCookie :: LocalTime -> Handler Cookie
-newCookie expire = do
- httpd <- getM config
- return $ empty {
- path = Just "/"
--- , domain = Just $ '.' : hostname httpd
- , port = [fromEnum $ listenPort httpd]
- , expires = Just $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire
- }
-
-
diff --git a/src/Network/Salvia/Handlers/Counter.hs b/src/Network/Salvia/Handlers/Counter.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Counter.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Network.Salvia.Handlers.Counter (hCounter) where
-
-import Control.Concurrent.STM
-import Control.Monad.State
-import Network.Salvia.Httpd
-
-hCounter :: TVar Int -> Handler ()
-hCounter c = lift $ atomically
- $ readTVar c >>= writeTVar c . (+1)
-
diff --git a/src/Network/Salvia/Handlers/Default.hs b/src/Network/Salvia/Handlers/Default.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Default.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Network.Salvia.Handlers.Default (hDefault) where
-
-import Control.Concurrent.STM
-import Network.Protocol.Http
-import Network.Salvia.Handlers.Banner
-import Network.Salvia.Handlers.Counter
-import Network.Salvia.Handlers.Error
-import Network.Salvia.Handlers.Head
-import Network.Salvia.Handlers.Log
-import Network.Salvia.Handlers.Parser
-import Network.Salvia.Handlers.Printer
-import Network.Salvia.Handlers.Session
-import Network.Salvia.Httpd
-import System.IO
-
-hDefault :: Show a => TVar Int -> Sessions a -> SessionHandler a () -> Handler ()
-hDefault count sessions handler = do
- hBanner "salvia-httpd"
- hParser onerror $ do
- session <- hSession sessions 300
- hHead $ handler session
- hPrinter
- hLog count stdout
- hCounter count
- where
- onerror err = do
- hError BadRequest
- sendStrLn []
- sendStrLn err
-
diff --git a/src/Network/Salvia/Handlers/Directory.hs b/src/Network/Salvia/Handlers/Directory.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Directory.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module Network.Salvia.Handlers.Directory (
- hDirectory
- , hDirectoryResource
- ) where
-
-import Control.Monad.State
-import Data.List (sort)
-import Data.Record.Label
-import Misc.Misc (bool)
-import Network.Protocol.Http
-import Network.Protocol.Uri (path)
-import Network.Salvia.Handlers.File (hResource)
-import Network.Salvia.Handlers.Redirect
-import Network.Salvia.Httpd
-import System.Directory (doesDirectoryExist, getDirectoryContents)
-
-hDirectory :: Handler ()
-hDirectory = hResource hDirectoryResource
-
-hDirectoryResource :: ResourceHandler ()
-hDirectoryResource dirName = do
- (u, p) <- bothM (uri % request) (getM path)
- if (null p) || last p /= '/'
- then hRedirect (lmod path (++"/") u)
- else dirHandler dirName
-
-dirHandler:: ResourceHandler ()
-dirHandler dirName = do
- p <- getM (path % uri % request)
- filenames <- lift $ getDirectoryContents dirName
- processed <- lift $ mapM (processFilename dirName) (sort filenames)
- let b = listing p processed
- enterM response $ do
- setM contentType ("text/html", Nothing)
- setM contentLength (Just $ fromIntegral $ length b)
- setM status OK
- sendStr b
-
--- Add trailing slash to a directory name.
-processFilename :: FilePath -> FilePath -> IO FilePath
-processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f)
-
--- Turn a list of filenames into HTML directory listing.
-listing :: FilePath -> [FilePath] -> String
-listing dirName fileNames =
- concat [
- "Index of "
- , dirName
- , "
"
- ]
-
diff --git a/src/Network/Salvia/Handlers/Dispatching.hs b/src/Network/Salvia/Handlers/Dispatching.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Dispatching.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Network.Salvia.Handlers.Dispatching (
- Dispatcher
- , ListDispatcher
- , hDispatch
- , hListDispatch
- ) where
-
-import Data.Record.Label
-import Network.Salvia.Httpd
-
-type Dispatcher a b = a -> Handler b -> Handler b -> Handler b
-type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b
-
-hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b
-hDispatch f match a handler _default = do
- ctx <- getM f
- if a `match` ctx
- then handler
- else _default
-
-hListDispatch :: Dispatcher a b -> ListDispatcher a b
-hListDispatch disp = flip $ foldr $ uncurry disp
-
diff --git a/src/Network/Salvia/Handlers/Error.hs b/src/Network/Salvia/Handlers/Error.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Error.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Network.Salvia.Handlers.Error (
- hError
- , hCustomError
- , hIOError
- , safeIO
- ) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-import System.IO.Error
-
-{- |
-The 'hError' handler enables the creation of a default style of error responses
-for the specified HTTP status code.
--}
-
-hError ::
- Status -- ^ The HTTP status code.
- -> Handler ()
-hError e = hCustomError e
- (concat ["[", show (codeFromStatus e), "] ", show e, "\n"])
-
-hCustomError ::
- Status -- ^ The HTTP status code.
- -> String -- ^ Custom error message.
- -> Handler ()
-hCustomError e m = do
- enterM response $ do
- setM status e
- setM contentType ("text/plain", Nothing)
- sendStr m
-
--- | Map IO errors to a default style error response.
-hIOError :: IOError -> Handler ()
-hIOError e
- | isDoesNotExistError e = hError NotFound
- | isAlreadyInUseError e = hError ServiceUnavailable
- | isPermissionError e = hError Forbidden
- | True = hError InternalServerError
-
--- | Execute an handler with the result of an IO action. When the IO actions
--- fails a default error handler will be executed.
-safeIO :: IO a -> (a -> Handler ()) -> Handler ()
-safeIO io h = lift (try io) >>= either hIOError h
-
diff --git a/src/Network/Salvia/Handlers/ExtensionDispatcher.hs b/src/Network/Salvia/Handlers/ExtensionDispatcher.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/ExtensionDispatcher.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Network.Salvia.Handlers.ExtensionDispatcher (
- hExtension
- , hExtensionRouter
- ) where
-
-import Data.Record.Label
-import Network.Protocol.Http (uri)
-import Network.Protocol.Uri (extension, path)
-import Network.Salvia.Handlers.Dispatching
-import Network.Salvia.Httpd (request)
-
-hExtension :: Dispatcher (Maybe String) a
-hExtension = hDispatch (extension % path % uri % request) (==)
-
-hExtensionRouter :: ListDispatcher (Maybe String) a
-hExtensionRouter = hListDispatch hExtension
-
diff --git a/src/Network/Salvia/Handlers/Fallback.hs b/src/Network/Salvia/Handlers/Fallback.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Fallback.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Network.Salvia.Handlers.Fallback (hOr, hEither) where
-
-import Control.Applicative
-import Control.Monad.State
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-
-{- |
-Until I figure out how to do this correctly, this handler somewow implements
-the MonadPlus/Alternative instance using a custom function. When the first
-handler fails the response will be reset and the second handler is executed.
--}
-
-hOr :: Handler a -> Handler a -> Handler a
-hOr h0 h1 = do
- a <- h0
- st <- getM (status % response)
- if statusFailure st
- then reset >> h1
- else return a
-
-hEither :: Handler a -> Handler b -> Handler (Either a b)
-hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1)
-
diff --git a/src/Network/Salvia/Handlers/File.hs b/src/Network/Salvia/Handlers/File.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/File.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-module Network.Salvia.Handlers.File (
- hFile
- , hFileResource
-
- , hFileFilter
- , hFileResourceFilter
-
- , hResource
- , hUri
- ) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Protocol.Mime
-import Network.Protocol.Uri (mimetype, path, parseURI)
-import Network.Salvia.Handlers.Error
-import Network.Salvia.Httpd
-import System.IO
-
-hFile :: Handler ()
-hFile = hResource hFileResource
-
-hFileFilter :: (String -> String) -> Handler ()
-hFileFilter = hResource . hFileResourceFilter
-
-{-
-Turn a resource handler into a regular handler that utilizes the path part
-of the request URI as the resource identifier.
--}
-
-hResource :: ResourceHandler a -> Handler a
-hResource rh = getM (path % uri % request) >>= rh
-
-{-
-Turn a URI handler into a regular handler that utilizes the request URI as the
-resource identifier.
--}
-
-hUri :: UriHandler a -> Handler a
-hUri rh = getM (uri % request) >>= rh
-
--------- HTTP deamon implementation -------------------------------------------
-
--- Create a response message containing the file contents.
--- TODO: what to do with encoding?
-hFileResource :: ResourceHandler ()
-hFileResource file = do
- let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)
- safeIO (openBinaryFile file ReadMode)
- $ \fd -> do
- fs <- lift $ hFileSize fd
- enterM response $ do
- setM contentType (m, Just "utf-8")
- setM contentLength (Just fs)
- setM status OK
- spoolBs id fd
-
--- TODO: what to do with encoding?
-hFileResourceFilter :: (String -> String) -> ResourceHandler ()
-hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter
- let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path)
- safeIO (openBinaryFile file ReadMode)
- $ \fd -> do
- enterM response $ do
- setM contentType (m, Just "utf-8")
- setM status OK
- spool fFilter fd
-
diff --git a/src/Network/Salvia/Handlers/FileSystem.hs b/src/Network/Salvia/Handlers/FileSystem.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/FileSystem.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module Network.Salvia.Handlers.FileSystem (
- hFileSystem
- , hFileSystemNoIndexes
- , hFileTypeDispatcher
- ) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Misc.Misc (bool)
-import Network.Protocol.Http
-import Network.Protocol.Uri (jail, path)
-import Network.Salvia.Handlers.Directory
-import Network.Salvia.Handlers.Error
-import Network.Salvia.Handlers.File
-import Network.Salvia.Httpd
-import System.Directory (doesDirectoryExist)
-
--- Show file contents and show directory indexes.
-hFileSystem :: ResourceHandler ()
-hFileSystem dir = hFileTypeDispatcher dir hDirectoryResource hFileResource
-
--- Show file contents, do not show directory indexes.
-hFileSystemNoIndexes :: ResourceHandler ()
-hFileSystemNoIndexes dir = hFileTypeDispatcher dir (const $ hError Forbidden) hFileResource
-
--- Dispatch based on file type, regular files or directories.
-hFileTypeDispatcher :: FilePath -> ResourceHandler () -> ResourceHandler () -> Handler ()
-hFileTypeDispatcher dir hdir hfile =
- getM (path % uri % request) >>=
- hJailedDispatch dir hdir hfile . (dir ++)
-
-hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler ()
-hJailedDispatch dir hdir hfile file = do
- case jail dir file of
- Nothing -> hError Forbidden
- Just f -> bool (hdir file) (hfile file)
- =<< lift (doesDirectoryExist f)
-
diff --git a/src/Network/Salvia/Handlers/Head.hs b/src/Network/Salvia/Handlers/Head.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Head.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Network.Salvia.Handlers.Head (hHead) where
-
-import Control.Applicative
-import Control.Monad.State (put)
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-
-{- |
-The 'hHead' handler makes sure no response body is sent to the client when the
-request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the
-specified sub handler will be executed under the assumption that the request
-was a 'GET' request, otherwise this handler will act as the identify function.
--}
-
-hHead :: Handler a -> Handler a
-hHead handler = do
- m <- getM (method % request)
- case m of
- HEAD -> withM (method % request) (put GET) $
- handler <* emptyQueue
- _ -> handler
-
diff --git a/src/Network/Salvia/Handlers/Log.hs b/src/Network/Salvia/Handlers/Log.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Log.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module Network.Salvia.Handlers.Log (hLog) where
-
-import Control.Concurrent.STM
-import Control.Monad.State
-import Data.Record.Label
-import Misc.Terminal (red, green, reset)
-import Network.Protocol.Http
-import Network.Salvia.Httpd (Handler, request, response, address)
-import System.IO
-
--- TODO: handle should be tvar as well
-hLog :: TVar Int -> Handle -> Handler Handle
-hLog count handle = do
- c <- lift $ atomically $ readTVar count
- mt <- getM (method % request)
- ur <- getM (uri % request)
- st <- getM (status % response)
- addr <- getM address
- let code = codeFromStatus st
- clr = if code >= 400 then red else green
- lift $ hPutStrLn handle $ concat [
- concat ["[", show addr, "] ", show c, "\t"]
- , show mt, "\t"
- , show ur, " -> "
- , clr
- , show code, " "
- , show st
- , reset
- ]
- return handle
-
diff --git a/src/Network/Salvia/Handlers/Login.hs b/src/Network/Salvia/Handlers/Login.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Login.hs
+++ /dev/null
@@ -1,272 +0,0 @@
-module Network.Salvia.Handlers.Login (
-
- -- * Basic types.
- Username
- , Password
- , Action
- , Actions
- , User (..)
- , Users
- , UserDatabase
- , TUserDatabase
-
- -- * User Sessions.
- , UserPayload (..)
- , UserSession
- , TUserSession
- , UserSessionHandler
-
- -- * Handlers.
- , hSignup
- , hLogin
- , hLogout
- , hLoginfo
-
- , hAuthorized
- , hAuthorizedUser
-
- -- * Helper functions.
- , readUserDatabase
-
- ) where
-
-import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar)
-import Control.Monad.State (lift, liftM)
-import Data.Digest.OpenSSL.MD5 (md5sum)
-import Data.List (intercalate)
-import Data.Maybe (catMaybes)
-import Data.Record.Label
-import Misc.Misc (atomModTVar, safeHead)
-import Network.Protocol.Http (Status (Unauthorized, OK), status)
-import Network.Salvia.Handlers.Error (hCustomError, hError)
-import Network.Salvia.Handlers.Session
-import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response)
-import Network.Protocol.Uri
-import Data.ByteString.UTF8 (fromString)
-
--------------------------------------------------------------------------------
-
-type Username = String
-type Password = String
-type Action = String
-type Actions = [Action]
-
-{- |
-User containg a username, password and a list of actions this user is allowed
-to perform within the system.
--}
-
-data User = User {
- username :: Username
- , password :: Password
- , email :: String
- , actions :: Actions
- } deriving (Eq, Show)
-
-type Users = [User]
-
-{- |
-A user database containing a list of users, a list of default actions the guest
-or `no-user' user is allowed to perform and a polymorphic reference to the
-place the database originates from. This source field cab be used by update
-functions synchronizing changes back to the database.
--}
-
-data UserDatabase src =
- UserDatabase {
- dbUsers :: Users
- , dbGuest :: Actions
- , dbSource :: src
- } deriving Show
-
-type TUserDatabase src = TVar (UserDatabase src)
-
-{- |
-A user payload instance contains user related session information and can be
-used as the payload for regular sessions. It contains a reference to the user
-it is bound to, a flag to indicate whether the user is logged in or not and a
-possible user specific session payload.
--}
-
-data UserPayload a = UserPayload {
- upUser :: User
- , upLoggedIn :: Bool
- , upPayload :: Maybe a
- } deriving (Eq, Show)
-
-type UserSession a = Session (UserPayload a)
-type TUserSession a = TSession (UserPayload a)
-
--- A handler that requires a session with a user specific payload.
-type UserSessionHandler a b = SessionHandler (UserPayload a) b
-
--------------------------------------------------------------------------------
-
--- Read user data file.
--- Format: username password action*
-
-readUserDatabase :: FilePath -> IO (TUserDatabase FilePath)
-readUserDatabase file = do
-
- -- First line contains the default `guest` actions, tail lines contain users.
- gst:ls <- lines `liftM` readFile file
-
- atomically $ newTVar $ UserDatabase
- (catMaybes $ map parseUserLine ls)
- (words gst)
- file
- where
- parseUserLine line =
- case words line of
- user:pass:mail:acts -> Just (User user pass mail acts)
- _ -> Nothing
-
-printUserLine :: User -> String
-printUserLine u = intercalate " " ([
- username u
- , password u
- , email u
- ] ++ actions u)
-
-{- |
-The signup handler is used to create a new entry in the user database. It reads
-a new username and password from the HTTP POST parameters and adds a new entry
-in the database when no user with such name exists. The user gets the specified
-initial set of actions assigned. On failure an `Unauthorized' error will be
-produced.
--}
-
-hSignup :: TUserDatabase FilePath -> Actions -> Handler ()
-hSignup tdb acts = do
- db <- lift . atomically $ readTVar tdb
- params <- uriEncodedPostParamsUTF8
- case freshUserInfo params (dbUsers db) acts of
- Nothing -> hCustomError Unauthorized "signup failed"
- Just u -> do
- lift $ do
- atomically
- $ writeTVar tdb
- $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db)
- appendFile (dbSource db) (printUserLine u)
-
-freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User
-freshUserInfo params us acts = do
- p <- params
- user <- "username" `lookup` p >>= id
- pass <- "password" `lookup` p >>= id
- mail <- "email" `lookup` p >>= id
- case safeHead $ filter ((==user).username) us of
- Nothing -> return $ User user (md5sum $ fromString pass) mail acts
- Just _ -> Nothing
-
--------------------------------------------------------------------------------
-
-{- |
-The login handler. Read the username and password values from the post data and
-use that to authenticate the user. When the user can be found in the database
-the user is logged in and stored in the session payload. Otherwise a
-`Unauthorized' response will be sent and the user has not logged in.
--}
-
-hLogin :: UserDatabase b -> UserSessionHandler a ()
-hLogin db session = do
- params <- uriEncodedPostParamsUTF8
- maybe
- (hCustomError Unauthorized "login failed")
- (loginSuccessful session)
- (authenticate params db)
-
-authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User
-authenticate params db = do
- p <- params
- user <- "username" `lookup` p >>= id
- pass <- "password" `lookup` p >>= id
- case safeHead $ filter ((==user).username) (dbUsers db) of
- Nothing -> Nothing
- Just u ->
- if password u == md5sum (fromString pass)
- then return u
- else Nothing
-
--- Login user and create `Ok' response on successful user.
-loginSuccessful :: TUserSession a -> User -> Handler ()
-loginSuccessful session user = do
- lift $ atomModTVar (\s -> s {payload = Just (UserPayload user True Nothing)}) session
- setM (status % response) OK
- sendStrLn "login successful"
-
--------------------------------------------------------------------------------
-
-hLogout :: TUserSession a -> Handler ()
-hLogout session = do
- lift $ atomModTVar (\s -> s {payload = Nothing}) session
- return ()
-
--------------------------------------------------------------------------------
-
-{- |
-The `loginfo' handler exposes the current user session to the world using a
-simple text based file. The file contains information about the current session
-identifier, session start and expiration date and the possible user payload
-that is included.
--}
-
-hLoginfo :: UserSessionHandler a ()
-hLoginfo session = do
- s' <- lift $ atomically $ readTVar session
-
- sendStrLn $ "sID=" ++ show (sID s')
- sendStrLn $ "start=" ++ show (start s')
- sendStrLn $ "expire=" ++ show (expire s')
-
- case payload s' of
- Nothing -> return ()
- Just (UserPayload (User uname _ mail acts) _ _) -> do
- sendStrLn $ "username=" ++ uname
- sendStrLn $ "email=" ++ mail
- sendStrLn $ "actions=" ++ intercalate " " acts
-
--------------------------------------------------------------------------------
-
-{- |
-Execute a handler only when the user for the current session is authorized to
-do so. The user must have the specified action contained in its actions list in
-order to be authorized. Otherwise an `Unauthorized' error will be produced.
-When no user can be found in the current session or this user is not logged in
-the guest account from the user database is used for authorization.
--}
-
-hAuthorized ::
- UserDatabase b -- ^ The user database to read guest account from.
- -> Action -- ^ The actions that should be authorized.
- -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized.
- -> UserSessionHandler a () -- ^ This handler requires a user session.
-
-hAuthorized db action handler session = do
- load <- liftM payload (lift $ atomically $ readTVar session)
- case load of
- Just (UserPayload user _ _)
- | action `elem` actions user -> handler (Just user)
- Nothing
- | action `elem` dbGuest db -> handler Nothing
- _ -> hError Unauthorized
-
-{- |
-Execute a handler only when the user for the current session is authorized to
-do so. The user must have the specified action contained in its actions list in
-order to be authorized. Otherwise an `Unauthorized' error will be produced. The
-guest user will not be used in any case.
--}
-
-hAuthorizedUser ::
- Action -- ^ The actions that should be authorized.
- -> (User -> Handler ()) -- ^ The handler to perform when authorized.
- -> UserSessionHandler a () -- ^ This handler requires a user session.
-
-hAuthorizedUser action handler session = do
- load <- liftM payload (lift $ atomically $ readTVar session)
- case load of
- Just (UserPayload user _ _)
- | action `elem` actions user -> handler user
- _ -> hError Unauthorized
-
diff --git a/src/Network/Salvia/Handlers/MethodRouter.hs b/src/Network/Salvia/Handlers/MethodRouter.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/MethodRouter.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module Network.Salvia.Handlers.MethodRouter (
- hMethod
- , hMethodRouter
-
- , hOPTIONS
- , hGET
- , hHEAD
- , hPOST
- , hPUT
- , hDELETE
- , hTRACE
- , hCONNECT
- ) where
-
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Handlers.Dispatching
-import Network.Salvia.Handlers.Error
-import Network.Salvia.Httpd
-
-hMethod' :: Dispatcher Method a
-hMethod' = hDispatch (method % request) (==)
-
-hMethodRouter :: ListDispatcher Method a
-hMethodRouter = hListDispatch hMethod'
-
-hMethod :: Method -> Handler () -> Handler ()
-hMethod m k = hMethod' m k (hError NotFound)
-
--- Shortcut handlers that only work for specific method types or fail.
-hOPTIONS, hGET, hHEAD, hPOST, hPUT, hDELETE, hTRACE, hCONNECT
- :: Handler () -> Handler ()
-
-hOPTIONS = hMethod OPTIONS
-hGET = hMethod GET
-hHEAD = hMethod HEAD
-hPOST = hMethod POST
-hPUT = hMethod PUT
-hDELETE = hMethod DELETE
-hTRACE = hMethod TRACE
-hCONNECT = hMethod CONNECT
-
diff --git a/src/Network/Salvia/Handlers/Parser.hs b/src/Network/Salvia/Handlers/Parser.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Parser.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-module Network.Salvia.Handlers.Parser (hParser) where
-
-import Control.Monad.State
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Salvia.Httpd
-import System.IO
-import Text.ParserCombinators.Parsec (parse)
-
-{- |
-The 'hParser' handler is used to parse the raw request message into the
-'Message' data type. This handler is generally used as (one of) the first
-handlers in a configuration. The first handler argument is executed when the
-request is invalid, possibly due to parser errors. The second handler argument
-is executed when the request is valid.
--}
-
-hParser ::
- (String -> Handler a) -- ^ The fail handler.
- -> Handler a -- ^ The succeed handler.
- -> Handler a
-
-hParser onfail onsuccess = do
- h <- getM sock
- -- TODO use try and fail with bad request or reject silently.
- msg <- lift $ readHeader h `catch` error "AAAAp"
- case parse pRequest "" (msg "") of
- Left err -> onfail (show err)
- Right x -> do
- setM request x
- onsuccess
-
--- Read all lines until the first empty line.
-readHeader :: Handle -> IO (String -> String)
-readHeader h = do
- l <- hGetLine h
- let lf = showChar '\n'
- if l `elem` ["", "\r"]
- then return lf
- else liftM ((showString l . lf) .) (readHeader h)
-
diff --git a/src/Network/Salvia/Handlers/PathRouter.hs b/src/Network/Salvia/Handlers/PathRouter.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/PathRouter.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module Network.Salvia.Handlers.PathRouter (
- hPath
- , hPathRouter
- , hPrefix
- , hPrefixRouter
-
- , hParameters
- ) where
-
-import Control.Monad.State
-import Data.List (isPrefixOf)
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Protocol.Uri (path, queryParams, Parameters)
-import Network.Salvia.Handlers.Dispatching
-import Network.Salvia.Httpd
-
-chop :: String -> Handler a -> Handler a
-chop a = withM (path % uri % request) (modify (drop $ length a))
-
-hPath :: Dispatcher String a
-hPath p h = hDispatch (path % uri % request) (==) p (chop p h)
-
-hPathRouter :: ListDispatcher String b
-hPathRouter = hListDispatch hPath
-
-hPrefix :: Dispatcher String a
-hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h)
-
-hPrefixRouter :: ListDispatcher String b
-hPrefixRouter = hListDispatch hPrefix
-
--- Path related utilities.
-
-hParameters :: Handler Parameters
-hParameters = getM (uri % request) >>= return . queryParams
-
diff --git a/src/Network/Salvia/Handlers/Printer.hs b/src/Network/Salvia/Handlers/Printer.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Printer.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Network.Salvia.Handlers.Printer (hPrinter) where
-
-import Control.Monad.State
-import Data.Record.Label (getM)
-import Network.Salvia.Httpd
-
-{- |
-The 'hPrinter' handler print the entire response including the headers to the
-client. This handler is generally used as (one of) the last handler in a
-configuration.
--}
-
-hPrinter :: Handler ()
-hPrinter = do
-
- -- Send the entire HTTP response header.
- sendHeaders
-
- -- Process all send actions in queue.
- s <- getM sock
- q <- getM queue
- lift $ mapM_ ($ s) q
-
diff --git a/src/Network/Salvia/Handlers/Put.hs b/src/Network/Salvia/Handlers/Put.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Put.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module Network.Salvia.Handlers.Put (hPut) where
-
-import Control.Monad.State
-import Network.Protocol.Http
-import Network.Salvia.Handlers.Error
-import Network.Salvia.Httpd
-import System.IO
-import qualified Data.ByteString.Lazy as B
-
-{- |
-First naive handler for the PUT request. This probably does not handle all the
-quirks that the HTTP protocol specifies, but it does the job for now. When a
-'ContentLength' header field is available only this fixed number of bytes will
-be spooled from socket to the resource. When both the KeepAlive' and
-'ContentLength' header fields are not available the entire payload of the
-request is spooled to the resource.
---}
-
-hPut :: ResourceHandler ()
-hPut name =
- safeIO (openBinaryFile name WriteMode)
- $ (contents >>=) . maybe putError . putOk
- where
- putError = hError NotImplemented
- putOk fd c = lift (B.hPut fd c >> hClose fd)
-
diff --git a/src/Network/Salvia/Handlers/Redirect.hs b/src/Network/Salvia/Handlers/Redirect.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Redirect.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Network.Salvia.Handlers.Redirect (hRedirect) where
-
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Protocol.Uri (URI)
-import Network.Salvia.Httpd
-
-hRedirect :: URI -> Handler ()
-hRedirect u =
- enterM response $ do
- setM location (Just u)
- setM status MovedPermanently
-
diff --git a/src/Network/Salvia/Handlers/Rewrite.hs b/src/Network/Salvia/Handlers/Rewrite.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Rewrite.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module Network.Salvia.Handlers.Rewrite (
- hRewrite
- , hRewritePath
- , hRewriteHost
- , hRewriteExt
- , hWithDir
- , hWithoutDir
- ) where
-
-import Control.Monad.State
-import Data.List (isPrefixOf)
-import Data.Record.Label
-import Network.Protocol.Http
-import Network.Protocol.Uri (URI, host, path, extension)
-import Network.Salvia.Httpd
-
-hRewrite :: (URI -> URI) -> Handler a -> Handler a
-hRewrite f = withM (uri % request) (modify f)
-
--- express these below in terms of the above?
-
-hRewriteHost :: (String -> String) -> Handler a -> Handler a
-hRewriteHost f = withM (host % uri % request) (modify f)
-
-hRewritePath :: (String -> String) -> Handler a -> Handler a
-hRewritePath f = withM (path % uri % request) (modify f)
-
-hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a
-hRewriteExt f = withM (extension % path % uri % request) (modify f)
-
-hWithDir :: String -> Handler a -> Handler a
-hWithDir d = hRewritePath (d++)
-
-hWithoutDir :: String -> Handler a -> Handler a
-hWithoutDir d h = do
- p <- getM (path % uri % request)
- (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h
-
diff --git a/src/Network/Salvia/Handlers/Session.hs b/src/Network/Salvia/Handlers/Session.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/Session.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-module Network.Salvia.Handlers.Session (
- hSession
-
- , SessionID
- , Session (..)
- , TSession
- , SessionHandler
- , Sessions
-
- , mkSessions
- ) where
-
-import Control.Applicative hiding (empty)
-import Control.Concurrent.STM
-import Control.Monad.State
-import Data.Time.LocalTime
-import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)
-import Network.Protocol.Cookie hiding (empty)
-import Network.Salvia.Handlers.Cookie
-import Network.Salvia.Httpd hiding (start)
-import Prelude hiding (lookup)
-import System.Random
-import qualified Data.Map as M
-
--------------------------------------------------------------------------------
-
--- A session identifier. Should be unique for every session.
-newtype SessionID = SID Integer
- deriving (Eq, Ord)
-
--- The session data type with polymorph payload.
-data Session a = Session {
- sID :: SessionID
- , start :: LocalTime
- , expire :: LocalTime
- , payload :: Maybe a
- } deriving Show
-
--- A shared session.
-type TSession a = TVar (Session a)
-
--- A handler that expects a session.
-type SessionHandler a b = TSession a -> Handler b
-
--- Create a new, empty, shared session.
-mkSession :: SessionID -> LocalTime -> IO (TSession a)
-mkSession sid e = do
- s <- now
- atomically $ newTVar $ Session sid s e Nothing
-
--------------------------------------------------------------------------------
-
-type Sessions a = TVar (M.Map SessionID (TSession a))
-
-instance Show SessionID where
- show (SID sid) = show sid
-
-mkSessions :: IO (Sessions a)
-mkSessions = atomically $ newTVar M.empty
-
--------------------------------------------------------------------------------
-
-{-
-The session handler. This handler will try to return an existing session from
-the sessions map based on a session identifier found in the HTTP cookie. When
-such a session can be found the expiration date will be updated to a number of
-seconds in the future. When no session can be found a new one will be created.
-A cookie will be set that informs the client of the current session.
--}
-
-hSession :: Sessions a -> Integer -> Handler (TSession a)
-hSession smap expiration = do
-
- -- Get the session identifier from an existing cookie or create a new one.
- prev <- getSessionID <$> hGetCookies
-
- -- Compute current time and expiration time.
- (n, ex) <- lift $ liftM2 (,) now (later expiration)
-
- -- Either create a new session or try to reuse current one.
- tsession <-
- maybe
- (newSession smap ex)
- (existingSession smap ex n)
- prev
-
- setSessionCookie tsession ex
- return tsession
-
--------------------------------------------------------------------------------
-
-{-
-Given the (possible wrong) request cookie, try to recover the existing --
-session identifier.
--}
-
-getSessionID :: Maybe Cookies -> Maybe SessionID
-getSessionID prev = do
- ck <- prev
- sid <- cookie "sid" ck
- sid' <- safeRead $ value sid
- return (SID sid')
-
-{-
-Generate a fresh, random session identifier using the default system random
-generator.
--}
-
-genSessionID :: IO SessionID
-genSessionID = do
- g <- getStdGen
- let (sid, g') = random g
- setStdGen g'
- return (SID (abs sid))
-
-
-{-
-This handler sets the HTTP cookie for the specified session. It will use a
-default cookie with an additional `sid' attribute with the session identifier
-as value. The session expiration date will be used as the cookie expire field.
--}
-
-setSessionCookie :: TSession a -> LocalTime -> Handler ()
-setSessionCookie tsession ex = do
- ck <- newCookie ex
- sid <- lift $ liftM sID $ atomReadTVar tsession
- hSetCookies $
- cookies [ck {
- name = "sid"
- , value = show sid
- }]
-
-{-
-Handler when no (valid) session is available. Create a new session with a
-specified expiration date. The session will be stored in the session map.
--}
-
-newSession :: Sessions a -> LocalTime -> Handler (TSession a)
-newSession sessions ex = lift $ do
-
- -- Fresh session identifier.
- sid <- genSessionID
-
- -- Fresh session.
- session <- mkSession sid ex
-
- -- Place in session mapping usinf session identifier as key.
- atomModTVar (M.insert sid session) sessions
- return session
-
-{-
-Handler for existing sessions. Given an existing session identifier lookup a
-session from the session map. When no session is available, or the session is
-expired, create a new one using the `newSession' function. Otherwise the
-expiration date of the existing session is updated.
--}
-
-existingSession ::
- Sessions a -> LocalTime -> LocalTime
- -> SessionID -> Handler (TSession a)
-existingSession sessions ex n sid = do
-
- -- Lookup the session in the session map given the session identifier.
- mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)
- case mtsession of
-
- -- Unrecognized session identifiers are penalised by a fresh session.
- Nothing -> newSession sessions ex
- Just tsession -> do
- expd <- lift $ liftM expire (atomReadTVar tsession)
- if expd < n
-
- -- Session is expired, create a new one.
- then newSession sessions ex
-
- -- Existing session, update expiration date.
- else lift $ do
- atomModTVar (\s -> s {expire = ex}) tsession
- return tsession
-
diff --git a/src/Network/Salvia/Handlers/VirtualHosting.hs b/src/Network/Salvia/Handlers/VirtualHosting.hs
deleted file mode 100644
--- a/src/Network/Salvia/Handlers/VirtualHosting.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Network.Salvia.Handlers.VirtualHosting (hVirtualHosting) where
-
-import Data.List (isPrefixOf)
-import Data.Record.Label
-import Network.Protocol.Http (hostname)
-import Network.Salvia.Handlers.Dispatching (Dispatcher, ListDispatcher, hListDispatch, hDispatch)
-import Network.Salvia.Httpd (request)
-
--- isSuffixOf?
-
-hVirtualHosting1 :: Dispatcher String a
-hVirtualHosting1 = hDispatch (hostname % request) isPrefixOf
-
-hVirtualHosting :: ListDispatcher String a
-hVirtualHosting = hListDispatch hVirtualHosting1
-
diff --git a/src/Network/Salvia/Httpd.hs b/src/Network/Salvia/Httpd.hs
--- a/src/Network/Salvia/Httpd.hs
+++ b/src/Network/Salvia/Httpd.hs
@@ -5,7 +5,7 @@
, defaultConfig
-- Httpd.Core.Handler
- , Context (..)
+ , Context
, config
, request
, response
@@ -20,15 +20,17 @@
, UriHandler
-- Httpd.Core.IO
- , sendHeaders
, send
, sendStr
, sendStrLn
, sendBs
+
, spool
, spoolBs
- , spoolAll
- , spoolN
+
+ , flushHeaders
+ , flushQueue
+
, emptyQueue
, reset
@@ -42,6 +44,7 @@
) where
import Network.Salvia.Core.Config
+import Network.Salvia.Core.Context
import Network.Salvia.Core.Handler
import Network.Salvia.Core.IO
import Network.Salvia.Core.Main