{-# LANGUAGE ScopedTypeVariables #-}moduleHappstack.Server.Dialogues(Dlg,Page,perform,showPage,DialogueManager,makeDialogueManager,closeDialogueManager,dialogue)whereimportHappstack.ServerimportControl.Monad.TransimportControl.Monad.ReaderimportControl.ConcurrentimportControl.Concurrent.MVarimportData.MaybeimportData.CharimportData.TimeimportData.ListimportSystem.RandomimportData.Map(Map)importqualifiedData.MapasM{-|
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.
-}dataDlgma=Donea|Action(ServerPartTm(Dlgma))|Step(Pagem)(Dlgma){-|
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.
-}typePagem=String->ServerPartTmResponse{-
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.
-}instanceMonadm=>Monad(Dlgm)wherereturn=DoneDonex>>=y=yxActionx>>=y=Action(x>>=return.(>>=y))Steppf>>=y=Stepp(f>>=y)instanceMonadTransDlgwherelift=Action.lift.(>>=return.Done)instanceMonadIOm=>MonadIO(Dlgm)whereliftIO=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::Monadm=>ServerPartTma->Dlgmaperformx=Action(x>>=return.Done){-|
Converts methods for rendering and parsing the result of a page into a
'Dlg' step.
-}showPage::Monadm=>Pagem->ServerPartTma->DlgmashowPagepr=Stepp(Action(fmapDoner)){-|
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.
-}dataDialogueSessionm=DialogueSession{client::String,lastTouched::MVarUTCTime,dialogues::MVar(MapInt(Dlgm()))}{-|
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.
-}dataDialogueManagerm=DialogueManager{sessions::MVar(MapInt(DialogueSessionm)),open::MVarBool}{-|
Determine whether a session is still valid or not.
-}goodSession::NominalDiffTime->(Int,DialogueSessionm)->IOBoolgoodSessiontimeout(_,DialogueSession_tref_)=dost<-readMVartrefct<-getCurrentTimereturn(diffUTCTimectst<=timeout){-|
Monadic while statement, for convenience.
-}whileM::Monadm=>mBool->ma->m()whileMcondaction=dob<-condifbthenaction>>whileMcondactionelsereturn(){-|
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(DialogueManagerm)makeDialogueManagertimeout=dooref<-newMVarTruesref<-newMVarM.emptyforkIO$whileM(readMVaroref)$dothreadDelay5000sessionMap<-takeMVarsrefgoodSessions<-filterM(goodSessiontimeout)(M.assocssessionMap)putMVarsref(M.fromListgoodSessions)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::DialogueManagerm->IO()closeDialogueManager(DialogueManager_oref)=doswapMVarorefFalsereturn(){-|
Given a 'Map' with a key type that can be randomly chosen, returns a key
that is not currently in the map.
-}uniqueKey::(Randomk,Ordk)=>Mapka->IOkuniqueKeym=dok<-randomIOifM.memberkmthenuniqueKeymelsereturnk{-|
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::MonadIOm=>DialogueManagerm->ServerPartTm(DialogueSessionm)addDialogueSession(DialogueManagersref_)=dorq<-askRq(k,session)<-liftIO$dosmap<-takeMVarsrefk<-uniqueKeysmaplet(c,_)=rqPeerrqct<-getCurrentTimetref<-newMVarctdref<-newMVarM.emptyletsession=DialogueSessionctrefdrefputMVarsref(M.insertksessionsmap)return(k,session)addCookie(-1)(mkCookie"dlg-sid"(showk))returnsession{-|
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::MonadIOm=>DialogueManagerm->ServerPartTm(DialogueSessionm)getDialogueSessiondmgr@(DialogueManagersreforef)=doopen<-liftIO$readMVarorefunlessopenmzerorq<-askRqmsid<-getDataFn(lookCookieValue"dlg-sid")casemsidofNothing->addDialogueSessiondmgrJustsid->dosmap<-liftIO$readMVarsrefcaseM.lookup(readsid)smapofNothing->addDialogueSessiondmgrJusts@(DialogueSession{lastTouched=tref})->iffst(rqPeerrq)/=clientsthenaddDialogueSessiondmgrelseliftIO$doct<-getCurrentTimeswapMVartrefctreturns{-|
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::Monadm=>ServerPartTmResponseaddTrailingSlash=dorq<-askRqtempRedirect(rqUrirq++"/")(toResponse"Please use a trailing slash"){-|
Inverts a guard condition.
-}notGuard::(ServerMonadm,MonadPlusm)=>m()->m()notGuardg=(g>>returnmzero)`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::MonadIOm=>DialogueManagerm->Dlgm()->ServerPartTmResponsedialoguedmgrdlg=do(DialogueSession__dref)<-getDialogueSessiondmgrcheckForm`mplus`continuedref`mplus`(nullDir>>handledref(foreverdlg))wherecheckForm=nullDir>>notGuardtrailingSlash>>addTrailingSlashcontinuedref=path$\(dlgid::Int)->nullDir>>dodlgs<-liftIO$readMVardrefrq<-askRqcaseM.lookupdlgiddlgsofNothing->handledrefdlgJustd->handledrefdhandledref(Done_)=mzerohandledref(Actiona)=a>>=handledrefhandledref(Steppf)=dodlgs<-liftIO$takeMVardrefrq<-askRqk<-liftIO$uniqueKeydlgsliftIO$putMVardref(M.insertkfdlgs)p(rqUrirq</>showk)(</>)::String->String->Stringa</>b=letis=elemIndices'/'ainifnullisthena++"/"++belsetake(lastis)a++"/"++b