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

{-|
    This module provides an easy to use continuation-backed programming
    model for interactive web applications, called Snap Dialogues.  A
    dialogue is a procedural description of an interaction with the
    user, which generally spans across many requests.  Dialogues are
    specified in a monadic embedded domain-specific language.
-}
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


{-|
    A utility function to pop the next path component off the request
    URI and pass it as a parameter to the handler.
-}
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)


{-|
    A 'DlgManager' is user to keep track of ongoing dialogues with a
    given user.  One of them should be stored in the user's session.
    The manager is parameterized on the base and value types for the
    underlying request handling monad.
-}
newtype DlgManager b v = DlgManager {
    unDlgManager :: SM.SessionMap (Dlg (Handler b v) ())
    }


{-|
    Creates a new 'DlgManager' with the given timeout in seconds for
    abandoned dialogues.
-}
makeDlgManager :: Int -> IO (DlgManager b v)
makeDlgManager timeout = DlgManager <$> SM.new timeout


{-|
    This type class identifies the location of the 'DlgManager' in the
    session object.  In order to use dialogues, your session type must
    be an instance of 'HasDlgManager'.
-}
class HasDlgManager b v a | a -> b v where
    {-|
        Extracts the 'DlgManager' from a session object.
    -}
    getDlgManager :: a -> DlgManager b v


{-|
    A value of a 'Dlg' type represents a (possibly partial) dialogue
    between the user and the application, producing a result of type
    @a@.  Dialogues can be composed using the monadic interface to
    describe complex interactions.
-}
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
    the request URI for continuing the dialogue in the future.
    Typically you will build pages using some kind of templating system
    such as Heist.
-}
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


{-|
    Converts the combination of rendering and parsing a page into a
    step of a 'Dlg'.
-}
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))


{-|
    The 'dialogue' function builds a 'Handler' 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, so images, stylesheets, etc.
    can be served using 'serveDirectory' just as you normally would.
-}
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