module Snap.Dialogues (
DlgManager,
makeDlgManager,
HasDlgManager(..),
Dlg,
Page,
showPage,
dialogue
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import qualified Snap.Snaplet.TypedSession.SessionMap as SM
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.TypedSession
import Text.Regex.Posix
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
popPathTo :: MonadSnap m => (ByteString -> m a) -> m a
popPathTo handler = do
req <- getRequest
let (x,y) = B.break (== '/') (rqPathInfo req)
if B.null x
then pass
else localRequest (\r -> r {rqPathInfo = B.drop 1 y}) (handler x)
newtype DlgManager b v = DlgManager {
unDlgManager :: SM.SessionMap (Dlg (Handler b v) ())
}
makeDlgManager :: Int -> IO (DlgManager b v)
makeDlgManager timeout = DlgManager <$> SM.new timeout
class HasDlgManager b v a | a -> b v where
getDlgManager :: a -> DlgManager b v
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 (liftM Done r))
dlgToken :: ByteString -> (ByteString -> Handler b v a) -> Handler b v a
dlgToken tname action = popPathTo $ \token ->
case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of
[[_, name, tok]] | name == tname -> action $ read $ B.unpack tok
_ -> pass
findDlg :: (HasTypedSession v t, HasDlgManager b v t)
=> ByteString -> Handler b v (Dlg (Handler b v) ())
findDlg tok = do
dmap <- fmap (unDlgManager . getDlgManager) getSession
maybe mzero return =<< liftIO (SM.lookup dmap tok)
handle :: (HasTypedSession v t, HasDlgManager b v t)
=> ByteString -> Dlg (Handler b v) () -> Handler b v ()
handle _ (Done _) = pass
handle name (Action a) = a >>= handle name
handle name (Step p f) = do
dmap <- fmap (unDlgManager . getDlgManager) getSession
k <- liftIO (SM.insert dmap f)
p (name `B.append` "-" `B.append` B.pack (show k))
dialogue :: (HasTypedSession v t, HasDlgManager b v t)
=> ByteString -> Dlg (Handler b v) () -> Handler b v ()
dialogue name dlg = new <|> continue
where
new = dir name $ ifTop $ handle name dlg
continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name