{-# 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