happstack-dlg-0.1.2: src/Happstack/Server/Dialogues.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Happstack.Server.Dialogues (
Dlg,
Page,
perform,
showPage,
DialogueManager,
makeDialogueManager,
closeDialogueManager,
dialogue
)
where
import Happstack.Server
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Maybe
import Data.Char
import Data.Time
import Data.List
import System.Random
import Data.Map (Map)
import qualified Data.Map as M
{-|
A value of a 'Dlg' type represents a dialogue between the user and the
application, after which the application builds a value of type 'a'. The
trivial case is that the value is already known. Alternatively, it may be
that there is some action to be performed, or else that the user needs to
be asked or told something.
-}
data Dlg m a = Done a
| Action (ServerPartT m (Dlg m a))
| Step (Page m) (Dlg m a)
{-|
A value of 'Page' type represents a way of rendering a page, given a request URI
that should be used for subsequent requests in order to reassociate them with the
current dialogue.
-}
type Page m = String -> ServerPartT m Response
{-
Dlg is a monad in the obvious way: return represents a dialogue that has no
steps; and (>>=) combines dialogues by doing the first part of the first
dialogue, and then continuing with the rest.
-}
instance Monad m => Monad (Dlg m) where
return = Done
Done x >>= y = y x
Action x >>= y = Action (x >>= return . (>>= y))
Step p f >>= y = Step p (f >>= y)
instance MonadTrans Dlg where
lift = Action . lift . (>>= return . Done)
instance MonadIO m => MonadIO (Dlg m) where
liftIO = lift . liftIO
{-
Converts a 'ServerPartT' into a Dlg. This is essentially a mechanism for
escaping the confines of the dialogue mechanism and performing your own
processing with the request.
-}
perform :: Monad m => ServerPartT m a -> Dlg m a
perform x = Action (x >>= return . Done)
{-|
Converts methods for rendering and parsing the result of a page into a
'Dlg' step.
-}
showPage :: Monad m => Page m -> ServerPartT m a -> Dlg m a
showPage p r = Step p (Action (fmap Done r))
{-|
A 'DialogueSession' represents a single user's active dialogs, which are
retained for an entire session. A reaper thread clears up sessions that
have not been touched for some session timeout, so each session also
stores the last time it was touched. In addition, each session is
associated with a fixed client address and cannot be used from a different
client, which avoids hijacking.
-}
data DialogueSession m = DialogueSession {
client :: String,
lastTouched :: MVar UTCTime,
dialogues :: MVar (Map Int (Dlg m ()))
}
{-|
A 'DialogueManager' is responsible for maintaining the state for 'Dlg'
sequences for all users. To do this, it keeps for each user a session
object encapsulating their dialogues, and associates each user with their
session using cookies.
-}
data DialogueManager m = DialogueManager {
sessions :: MVar (Map Int (DialogueSession m)),
open :: MVar Bool
}
{-|
Determine whether a session is still valid or not.
-}
goodSession :: NominalDiffTime -> (Int, DialogueSession m) -> IO Bool
goodSession timeout (_, DialogueSession _ tref _) = do
st <- readMVar tref
ct <- getCurrentTime
return (diffUTCTime ct st <= timeout)
{-|
Monadic while statement, for convenience.
-}
whileM :: Monad m => m Bool -> m a -> m ()
whileM cond action = do
b <- cond
if b then action >> whileM cond action else return ()
{-|
Create a new 'DialogueManager' to manage a set of dialogues in the web
application. This also spawns the session reaper, which cleans up sessions
that haven't been touched for a given time period.
-}
makeDialogueManager :: NominalDiffTime -> IO (DialogueManager m)
makeDialogueManager timeout = do
oref <- newMVar True
sref <- newMVar M.empty
forkIO $ whileM (readMVar oref) $ do
threadDelay 5000
sessionMap <- takeMVar sref
goodSessions <- filterM (goodSession timeout) (M.assocs sessionMap)
putMVar sref (M.fromList goodSessions)
return (DialogueManager { sessions = sref, open = oref })
{-|
Closes a DialogueManager, which will cause it to cease accepting any
incoming requests, and also to terminate the session reaper thread.
-}
closeDialogueManager :: DialogueManager m -> IO ()
closeDialogueManager (DialogueManager _ oref) = do swapMVar oref False
return ()
{-|
Given a 'Map' with a key type that can be randomly chosen, returns a key
that is not currently in the map.
-}
uniqueKey :: (Random k, Ord k) => Map k a -> IO k
uniqueKey m = do k <- randomIO
if M.member k m then uniqueKey m else return k
{-|
Adds a 'DialogueSession' and associated cookie. This always sets a new
blank session, so should only be used when there is no session already.
-}
addDialogueSession :: MonadIO m => DialogueManager m ->
ServerPartT m (DialogueSession m)
addDialogueSession (DialogueManager sref _) = do
rq <- askRq
(k, session) <- liftIO $ do
smap <- takeMVar sref
k <- uniqueKey smap
let (c, _) = rqPeer rq
ct <- getCurrentTime
tref <- newMVar ct
dref <- newMVar M.empty
let session = DialogueSession c tref dref
putMVar sref (M.insert k session smap)
return (k, session)
addCookie (-1) (mkCookie "dlg-sid" (show k))
return session
{-|
Ensures that there is a 'DialogueSession' for the current user, and returns
it. Adds a blank one if necessary. This also updates the last touched
time for the session, preventing it from being removed by the reaper
thread for a while.
-}
getDialogueSession :: MonadIO m => DialogueManager m ->
ServerPartT m (DialogueSession m)
getDialogueSession dmgr@(DialogueManager sref oref) = do
open <- liftIO $ readMVar oref
unless open mzero
rq <- askRq
msid <- getDataFn (lookCookieValue "dlg-sid")
case msid of
Nothing -> addDialogueSession dmgr
Just sid -> do smap <- liftIO $ readMVar sref
case M.lookup (read sid) smap of
Nothing -> addDialogueSession dmgr
Just s@(DialogueSession { lastTouched = tref }) ->
if fst (rqPeer rq) /= client s
then addDialogueSession dmgr
else liftIO $ do ct <- getCurrentTime
swapMVar tref ct
return s
{-|
A simple response that adds trailing slashes to a path when they don't exist.
Trailing slashes are required for dialogue paths, since a path component is used
to distinguish the dialogue ID.
-}
addTrailingSlash :: Monad m => ServerPartT m Response
addTrailingSlash = do
rq <- askRq
tempRedirect (rqUri rq ++ "/") (toResponse "Please use a trailing slash")
{-|
Inverts a guard condition.
-}
notGuard :: (ServerMonad m, MonadPlus m) => m () -> m ()
notGuard g = (g >> return mzero) `mplus` return (return ()) >>= id
{-|
The 'dialogue' function builds a 'ServerPartT' that handles a given
dialogue. In general, it can be combined in normal ways with guards and
such, so long as changes in the request parameters won't cause it to be
missed when future requests are made in the same dialogue.
-}
dialogue :: MonadIO m => DialogueManager m -> Dlg m ()
-> ServerPartT m Response
dialogue dmgr dlg = do (DialogueSession _ _ dref) <- getDialogueSession dmgr
checkForm `mplus` continue dref
`mplus` (nullDir >> handle dref (forever dlg))
where checkForm = nullDir >> notGuard trailingSlash >> addTrailingSlash
continue dref = path $ \ (dlgid :: Int) -> nullDir >> do
dlgs <- liftIO $ readMVar dref
rq <- askRq
case M.lookup dlgid dlgs of
Nothing -> handle dref dlg
Just d -> handle dref d
handle dref (Done _) = mzero
handle dref (Action a) = a >>= handle dref
handle dref (Step p f) = do
dlgs <- liftIO $ takeMVar dref
rq <- askRq
k <- liftIO $ uniqueKey dlgs
liftIO $ putMVar dref (M.insert k f dlgs)
p (rqUri rq </> show k)
(</>) :: String -> String -> String
a </> b = let is = elemIndices '/' a
in if null is then a ++ "/" ++ b
else take (last is) a ++ "/" ++ b