{-# LANGUAGE ScopedTypeVariables #-}
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

{-|
    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 (ServerPartT 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        = String -> ServerPartT m Response

{-
    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)

instance MonadTrans Dlg where
    lift = Action . lift . (>>= return . Done)

instance MonadIO m => MonadIO (Dlg m) where
    liftIO = lift . liftIO

{-
    Converts a 'ServerPartT' into a Dlg.  This is essentially a mechanism for
    escaping the confines of the dialogue mechanism and performing your own
    processing with the request.
-}
perform :: Monad m => ServerPartT m a -> Dlg m a
perform x = Action (x >>= return . Done)

{-|
    Converts methods for rendering and parsing the result of a page into a
    'Dlg' step.
-}
showPage :: Monad m => Page m -> ServerPartT m a -> Dlg m a 
showPage p r = Step p (Action (fmap Done r))

{-|
    A 'DialogueSession' represents a single user's active dialogs, which are
    retained for an entire session.  A reaper thread clears up sessions that
    have not been touched for some session timeout, so each session also
    stores the last time it was touched.  In addition, each session is
    associated with a fixed client address and cannot be used from a different
    client, which avoids hijacking.
-}
data DialogueSession m = DialogueSession {
    client      :: String,
    lastTouched :: MVar UTCTime,
    dialogues   :: MVar (Map Int (Dlg m ()))
    }

{-|
    A 'DialogueManager' is responsible for maintaining the state for 'Dlg'
    sequences for all users.  To do this, it keeps for each user a session
    object encapsulating their dialogues, and associates each user with their
    session using cookies.
-}
data DialogueManager m = DialogueManager {
    sessions    :: MVar (Map Int (DialogueSession m)),
    open        :: MVar Bool
    }

{-|
    Determine whether a session is still valid or not.
-}
goodSession :: NominalDiffTime -> (Int, DialogueSession m) -> IO Bool
goodSession timeout (_, DialogueSession _ tref _) = do
    st <- readMVar tref
    ct <- getCurrentTime 
    return (diffUTCTime ct st <= timeout)

{-|
    Monadic while statement, for convenience.
-}
whileM :: Monad m => m Bool -> m a -> m ()
whileM cond action = do
    b <- cond
    if b then action >> whileM cond action else return ()

{-|
    Create a new 'DialogueManager' to manage a set of dialogues in the web
    application.  This also spawns the session reaper, which cleans up sessions
    that haven't been touched for a given time period.
-}
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 })

{-|
    Closes a DialogueManager, which will cause it to cease accepting any
    incoming requests, and also to terminate the session reaper thread.
-}
closeDialogueManager :: DialogueManager m -> IO ()
closeDialogueManager (DialogueManager _ oref) = do swapMVar oref False
                                                   return ()

{-|
    Given a 'Map' with a key type that can be randomly chosen, returns a key
    that is not currently in the map.
-}
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

{-|
    Adds a 'DialogueSession' and associated cookie.  This always sets a new
    blank session, so should only be used when there is no session already.
-}
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

{-|
    Ensures that there is a 'DialogueSession' for the current user, and returns
    it.  Adds a blank one if necessary.  This also updates the last touched
    time for the session, preventing it from being removed by the reaper
    thread for a while.
-}
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

{-|
    A simple response that adds trailing slashes to a path when they don't exist.
    Trailing slashes are required for dialogue paths, since a path component is used
    to distinguish the dialogue ID.
-}
addTrailingSlash :: Monad m => ServerPartT m Response
addTrailingSlash = do
    rq <- askRq
    tempRedirect (rqUri rq ++ "/") (toResponse "Please use a trailing slash")

{-|
    Inverts a guard condition. 
-}
notGuard :: (ServerMonad m, MonadPlus m) => m () -> m ()
notGuard g = (g >> return mzero) `mplus` return (return ()) >>= id

{-|
    The 'dialogue' function builds a 'ServerPartT' that handles a given
    dialogue.  In general, it can be combined in normal ways with guards and
    such, so long as changes in the request parameters won't cause it to be
    missed when future requests are made in the same dialogue.
-}
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