Dialogues.hs

{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE OverloadedStrings          #-}

module Snap.Extension.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.Extension.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

{-|
    A value of a 'Dlg' type represents a dialogue 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 (m (Dlg m a))
             | Step (Page m) (Dlg m a)

{-|
    A value of 'Page' type represents a way of rendering a page, given a request URI
    that should be used for subsequent requests in order to reassociate them with the
    current dialogue.
-}
type Page m = ByteString -> m ()

{-
    Dlg is a monad in the obvious way: return represents a dialogue that has no
    steps; and (>>=) combines dialogues by doing the first part of the first
    dialogue, 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)

{-
    Converts an action in the underlying Monad into a Dlg.  This is essentially
    a mechanism for escaping the confines of the dialogue mechanism and
    performing your own processing with the request.
-}
instance MonadTrans Dlg where
    lift x = Action (x >>= return . Done)

{-
    Dlg is an instance of MonadIO by passing it through to the underlying monad. 
-}
instance MonadIO m => MonadIO (Dlg m) where
    liftIO = lift . liftIO

{-|
    Converts methods for rendering and parsing the result of a page into a
    'Dlg' step.
-}
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 ~ SessionValue m)
        => SessionKey
        -> m (Dlg m ())
findDlg tok = do
    dref <- fmap (unDlgManager . getDlgManager) getSessionObject
    dlgs <- liftIO $ readMVar dref
    maybe mzero return $ M.lookup tok dlgs

handle :: (MonadSession m, HasDlgManager m t, t ~ SessionValue 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) getSessionObject
    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))

{-|
    The 'dialogue' function builds a 'Snap ()' that handles a given dialogue.
    The URLs of the dialog are of the form "/.../dlg-55555", where "dlg" is
    the prefix (passed as a parameter) and 55555 is the (numeric) dialogue ID.
    Requests to "/.../dlg" create a new dialogue.

    In general, this can be combined in normal ways with other routing constructs,
    so long as request URIs of the above forms reach this handler.  When pages are
    served as part of a dialog, their relative paths are passed on to later handlers,
-}
dialogue :: (MonadSession m, HasDlgManager m t, t ~ SessionValue 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