module Snap.Dialogues (
DlgManager,
makeDlgManager,
HasDlgManager(..),
Dlg,
Page,
showPage,
dialogue
)
where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Snap.Extension.Session
import Snap.SessionUtil
import Snap.Types
import Text.Regex.Posix
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Map (Map)
import qualified Data.Map as M
newtype DlgManager m = DlgManager {
unDlgManager :: MVar (Map SessionKey (Dlg m ()))
}
makeDlgManager :: IO (DlgManager m)
makeDlgManager = fmap DlgManager (newMVar M.empty)
class HasDlgManager m a | a -> m where
getDlgManager :: a -> DlgManager m
data Dlg m a = Done a
| Action (m (Dlg m a))
| Step (Page m) (Dlg m a)
type Page m = ByteString -> m ()
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 x = Action (x >>= return . Done)
instance MonadIO m => MonadIO (Dlg m) where
liftIO = lift . liftIO
showPage :: Monad m => Page m -> m a -> Dlg m a
showPage p r = Step p (Action (r >>= return . Done))
dlgToken :: MonadSnap m => ByteString -> (SessionKey -> m a) -> m a
dlgToken tname action = popPathTo $ \token ->
case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of
[[_, name, tok]] | name == tname -> action $ read $ B.unpack tok
_ -> pass
findDlg :: (MonadSession m, HasDlgManager m t, t ~ Session m)
=> SessionKey
-> m (Dlg m ())
findDlg tok = do
dref <- fmap (unDlgManager . getDlgManager) getSession
dlgs <- liftIO $ readMVar dref
maybe mzero return $ M.lookup tok dlgs
handle :: (MonadSession m, HasDlgManager m t, t ~ Session m)
=> ByteString -> Dlg m () -> m ()
handle _ (Done _) = pass
handle name (Action a) = a >>= handle name
handle name (Step p f) = do
dref <- fmap (unDlgManager . getDlgManager) getSession
dlgs <- liftIO $ takeMVar dref
k <- liftIO $ uniqueKey dlgs
liftIO $ putMVar dref (M.insert k f dlgs)
p (name `B.append` "-" `B.append` B.pack (show k))
dialogue :: (MonadSession m, HasDlgManager m t, t ~ Session m)
=> ByteString
-> Dlg m ()
-> m ()
dialogue name dlg = new <|> continue
where
new = dir name $ ifTop $ handle name dlg
continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name