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
data Dlg m a = Done a
| Action (ServerPartT m (Dlg m a))
| Step (Page m) (Dlg m a)
type Page m = String -> 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 DialogueSession m = DialogueSession {
client :: String,
lastTouched :: MVar UTCTime,
dialogues :: MVar (Map Int (Dlg m ()))
}
data DialogueManager m = DialogueManager {
sessions :: MVar (Map Int (DialogueSession m)),
open :: MVar Bool
}
goodSession :: NominalDiffTime -> (Int, DialogueSession m) -> IO Bool
goodSession timeout (_, DialogueSession _ 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 ()
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 })
closeDialogueManager :: DialogueManager m -> IO ()
closeDialogueManager (DialogueManager _ oref) = do 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
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
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
addTrailingSlash :: Monad m => ServerPartT m Response
addTrailingSlash = do
rq <- askRq
tempRedirect (rqUri rq ++ "/") (toResponse "Please use a trailing slash")
notGuard :: (ServerMonad m, MonadPlus m) => m () -> m ()
notGuard g = (g >> return mzero) `mplus` return (return ()) >>= id
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