Dialogs.hs

module Happstack.Server.Dialogs (
    Dlg,
    Page,
    perform,
    showPage,
    DialogManager,
    makeDialogManager,
    closeDialogManager,
    dialog
    )
    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 System.Random

import Data.Map (Map)
import qualified Data.Map as M

{-|
    A value of a 'Dlg' type represents a dialog 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 unique ID
    that should be included in responses in order to reassociate the response with the
    current dialog.
-}
type Page m        = Int -> ServerPartT m Response

{-
    Dlg is a monad in the obvious way: return represents a dialog that has no
    steps; and (>>=) combines dialogs by doing the first part of the first
    dialog, 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 dialog 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 'DialogSession' 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 avoid hijacking.
-}
data DialogSession m = DialogSession {
    client      :: String,
    lastTouched :: MVar UTCTime,
    dialogs     :: MVar (Map Int (Dlg m ()))
    }

{-|
    A 'DialogManager' 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 dialogs, and associates each user with a dialog using cookies.
-}
data DialogManager m = DialogManager {
    sessions    :: MVar (Map Int (DialogSession m)),
    open        :: MVar Bool
    }

{-|
    Determine whether a session is still valid or not.
-}
goodSession :: NominalDiffTime -> (Int, DialogSession m) -> IO Bool
goodSession timeout (_, DialogSession _ 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 'DialogManager' to manage a set of dialogs in the web application.
    This also spawns the session reaper, which cleans up sessions that haven't been
    touched for a given time period.
-}
makeDialogManager :: NominalDiffTime -> IO (DialogManager m)
makeDialogManager 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 (DialogManager { sessions = sref, open = oref })

{-|
    Closes a DialogManager, which will cause it to cease accepting any incoming
    requests, and also to terminate the session reaper thread.
-}
closeDialogManager :: DialogManager m -> IO ()
closeDialogManager (DialogManager _ oref) = 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 'DialogSession' and associated cookie.  This always sets a new blank
    session, so should only be used when there is no session already.
-}
addDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m)
addDialogSession (DialogManager 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 = DialogSession 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 'DialogSession' 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.
-}
getDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m)
getDialogSession dmgr@(DialogManager sref oref) = do
    open    <- liftIO $ readMVar oref
    unless open mzero
    rq      <- askRq
    msid    <- getDataFn (lookCookieValue "dlg-sid")
    case msid of
        Nothing  -> addDialogSession dmgr
        Just sid -> do smap <- liftIO $ readMVar sref
                       case M.lookup (read sid) smap of
                            Nothing -> addDialogSession dmgr
                            Just s@(DialogSession { lastTouched = tref }) ->
                                if fst (rqPeer rq) /= client s
                                    then addDialogSession dmgr
                                    else liftIO $ do ct <- getCurrentTime
                                                     swapMVar tref ct
                                                     return s

{-|
    The 'dialog' function builds a 'ServerPartT' that handles a given dialog.  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 dialog.
-}
dialog :: MonadIO m => DialogManager m -> Dlg m () -> ServerPartT m Response
dialog dmgr@(DialogManager sref oref) dlg = do
        (DialogSession _ _ dref) <- getDialogSession dmgr
        cont dref `mplus` this dref dlg
    where cont dref = withDataFn (lookRead "dlg-dlgid") $ \dlgid -> do
            dlgs <- liftIO $ readMVar dref
            rq   <- askRq
            case M.lookup dlgid dlgs of
                Nothing -> mzero
                Just d  -> this dref d
          this dref (Done _)   = mzero
          this dref (Action a) = a >>= this dref
          this dref (Step p f) = do
            dlgs <- liftIO $ takeMVar dref
            k    <- liftIO $ uniqueKey dlgs
            liftIO $ putMVar dref (M.insert k f dlgs)
            p k