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
data Dlg m a = Done a
| Action (ServerPartT m (Dlg m a))
| Step (Page m) (Dlg m a)
type Page m = Int -> ServerPartT m Response
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
perform :: Monad m => ServerPartT m a -> Dlg m a
perform x = Action (x >>= return . Done)
showPage :: Monad m => Page m -> ServerPartT m a -> Dlg m a
showPage p r = Step p (Action (fmap Done r))
data DialogSession m = DialogSession {
client :: String,
lastTouched :: MVar UTCTime,
dialogs :: MVar (Map Int (Dlg m ()))
}
data DialogManager m = DialogManager {
sessions :: MVar (Map Int (DialogSession m)),
open :: MVar Bool
}
goodSession :: NominalDiffTime -> (Int, DialogSession m) -> IO Bool
goodSession timeout (_, DialogSession _ tref _) = do
st <- readMVar tref
ct <- getCurrentTime
return (diffUTCTime ct st <= timeout)
whileM :: Monad m => m Bool -> m a -> m ()
whileM cond action = do
b <- cond
if b then action >> whileM cond action else return ()
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 })
closeDialogManager :: DialogManager m -> IO ()
closeDialogManager (DialogManager _ oref) = swapMVar oref False >> return ()
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
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
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
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