happstack-dlg (empty) → 0.1
raw patch · 5 files changed
+364/−0 lines, 5 filesdep +basedep +containersdep +happstacksetup-changed
Dependencies added: base, containers, happstack, happstack-server, mtl, random, template-haskell, time
Files
- LICENSE +27/−0
- Setup.lhs +4/−0
- happstack-dlg.cabal +23/−0
- src/Happstack/Server/Dialogs.hs +212/−0
- src/Happstack/Server/Dialogs/Scaffold.hs +98/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ happstack-dlg.cabal view
@@ -0,0 +1,23 @@+Name: happstack-dlg+Version: 0.1+Cabal-Version: >= 1.2+Synopsis: Cross-request user interactions for Happstack+Description: A mechanism for user interactions that extend through+ multiple request/response cycles on the Happstack+ server, inspired by Chris Eidhof.+Category: Web+Stability: Experimental+License: BSD3+License-File: LICENSE+Author: Chris Smith+Maintainer: Chris Smith <cdsmith@gmail.com>+Homepage: http://patch-tag.com/r/cdsmith/happstack-dlg+Build-Type: Simple++Library+ Build-Depends: base <5, containers, mtl, happstack,+ happstack-server, time, random,+ template-haskell+ Exposed-Modules: Happstack.Server.Dialogs,+ Happstack.Server.Dialogs.Scaffold+ Hs-Source-Dirs: src
+ src/Happstack/Server/Dialogs.hs view
@@ -0,0 +1,212 @@+module Happstack.Server.Dialogs (+ Dlg,+ Page,+ perform,+ showPage,+ DialogManager,+ makeDialogManager,+ closeDialogManager,+ dialog+ )+ 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 System.Random++import Data.Map (Map)+import qualified Data.Map as M++{-|+ A value of a 'Dlg' type represents a dialog 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 unique ID+ that should be included in responses in order to reassociate the response with the+ current dialog.+-}+type Page m = Int -> ServerPartT m Response++{-+ Dlg is a monad in the obvious way: return represents a dialog that has no+ steps; and (>>=) combines dialogs by doing the first part of the first+ dialog, 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 dialog 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 'DialogSession' 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 avoid hijacking.+-}+data DialogSession m = DialogSession {+ client :: String,+ lastTouched :: MVar UTCTime,+ dialogs :: MVar (Map Int (Dlg m ()))+ }++{-|+ A 'DialogManager' 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 dialogs, and associates each user with a dialog using cookies.+-}+data DialogManager m = DialogManager {+ sessions :: MVar (Map Int (DialogSession m)),+ open :: MVar Bool+ }++{-|+ Determine whether a session is still valid or not.+-}+goodSession :: NominalDiffTime -> (Int, DialogSession m) -> IO Bool+goodSession timeout (_, DialogSession _ 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 'DialogManager' to manage a set of dialogs in the web application.+ This also spawns the session reaper, which cleans up sessions that haven't been+ touched for a given time period.+-}+makeDialogManager :: NominalDiffTime -> IO (DialogManager m)+makeDialogManager 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 (DialogManager { sessions = sref, open = oref })++{-|+ Closes a DialogManager, which will cause it to cease accepting any incoming+ requests, and also to terminate the session reaper thread.+-}+closeDialogManager :: DialogManager m -> IO ()+closeDialogManager (DialogManager _ oref) = 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 'DialogSession' and associated cookie. This always sets a new blank+ session, so should only be used when there is no session already.+-}+addDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m)+addDialogSession (DialogManager 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 = DialogSession 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 'DialogSession' 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.+-}+getDialogSession :: MonadIO m => DialogManager m -> ServerPartT m (DialogSession m)+getDialogSession dmgr@(DialogManager sref oref) = do+ open <- liftIO $ readMVar oref+ unless open mzero+ rq <- askRq+ msid <- getDataFn (lookCookieValue "dlg-sid")+ case msid of+ Nothing -> addDialogSession dmgr+ Just sid -> do smap <- liftIO $ readMVar sref+ case M.lookup (read sid) smap of+ Nothing -> addDialogSession dmgr+ Just s@(DialogSession { lastTouched = tref }) ->+ if fst (rqPeer rq) /= client s+ then addDialogSession dmgr+ else liftIO $ do ct <- getCurrentTime+ swapMVar tref ct+ return s++{-|+ The 'dialog' function builds a 'ServerPartT' that handles a given dialog. 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 dialog.+-}+dialog :: MonadIO m => DialogManager m -> Dlg m () -> ServerPartT m Response+dialog dmgr@(DialogManager sref oref) dlg = do+ (DialogSession _ _ dref) <- getDialogSession dmgr+ cont dref `mplus` this dref dlg+ where cont dref = withDataFn (lookRead "dlg-dlgid") $ \dlgid -> do+ dlgs <- liftIO $ readMVar dref+ rq <- askRq+ case M.lookup dlgid dlgs of+ Nothing -> mzero+ Just d -> this dref d+ this dref (Done _) = mzero+ this dref (Action a) = a >>= this dref+ this dref (Step p f) = do+ dlgs <- liftIO $ takeMVar dref+ k <- liftIO $ uniqueKey dlgs+ liftIO $ putMVar dref (M.insert k f dlgs)+ p k+
+ src/Happstack/Server/Dialogs/Scaffold.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Happstack.Server.Dialogs.Scaffold where++import Happstack.Server+import Happstack.Server.Dialogs+import Language.Haskell.TH++import Data.Char (ord)+import Data.Maybe (fromMaybe)++escapeHtml :: String -> String+escapeHtml "" = ""+escapeHtml ('\"':cs) = """ ++ escapeHtml cs+escapeHtml ('\'':cs) = "'" ++ escapeHtml cs+escapeHtml ('&' :cs) = "&" ++ escapeHtml cs+escapeHtml ('<' :cs) = "<" ++ escapeHtml cs+escapeHtml ('>' :cs) = ">" ++ escapeHtml cs+escapeHtml (c :cs) | ord c >= 160 = "&#" ++ show (ord c) ++ ";" ++ escapeHtml cs+ | otherwise = c : escapeHtml cs++{-|+ The 'scaffold' function builds a user interaction to display and collect information.+ In a finished web application, this should generally be replaced with a better+ mechanism for rendering pages, such as a templating engine, XSLT, or something+ of the sort.+-}+scaffold :: (Scaffolded a, Monad m) => String -> a -> Dlg m a+scaffold s v = showPage out inp+ where out n = return $ setHeader "Content-type" "text/html" $ toResponse $+ "<html><body>"+ ++ escapeHtml s ++ "<br><hr>"+ ++ "<form>"+ ++ render "dlg-vals" v+ ++ "<input type=\"hidden\""+ ++ " name=\"dlg-dlgid\""+ ++ " value=\"" ++ show n ++ "\">"+ ++ "<input type=\"submit\" value=\"Submit\">"+ ++ "<script type=\"text/javascript\">"+ ++ " document.forms[0].elements[0].focus();"+ ++ "</script>"+ ++ "</form>"+ ++ "</html></body>"+ inp = parse "dlg-vals"++{-|+ The 'Scaffolded' type class represents data that can be included in a form.+ To make it easy to compose several of these in a page, rendering and parsing+ are parameterized with prefix strings so that they may be made unique across+ a page.+-}+class Scaffolded a where+ render :: String -> a -> String+ parse :: Monad m => String -> ServerPartT m a++instance Scaffolded () where+ render _ () = ""+ parse _ = return ()++instance Scaffolded String where+ render pfx s = "<input type=\"text\" name=\"" ++ pfx ++ "\" value=\"" ++ {- escapeHtml -} s ++ "\">"+ parse pfx = fmap (fromMaybe "") $ getDataFn (look pfx)++instance Scaffolded Bool where+ render pfx v = "<input type=\"checkbox\" name=\"" ++ pfx ++ "\" value=\"True\" "+ ++ if v then "checked" else "" ++ ">"+ parse pfx = fmap (maybe False (const True)) $ getDataFn (look pfx)++instance Scaffolded Int where+ render pfx s = render pfx (show s)+ parse pfx = fmap read $ parse pfx++instance (Scaffolded a, Scaffolded b) => Scaffolded (a, b) where+ render pfx (x,y) = render (pfx ++ "_1") x+ ++ "<br>"+ ++ render (pfx ++ "_2") y+ parse pfx = do x <- parse (pfx ++ "_1")+ y <- parse (pfx ++ "_2")+ return (x,y)++instance (Scaffolded a, Scaffolded b, Scaffolded c)+ => Scaffolded (a, b, c) where+ render pfx (x,y,z) = render (pfx ++ "_1") x+ ++ "<br>"+ ++ render (pfx ++ "_2") y+ ++ "<br>"+ ++ render (pfx ++ "_3") z+ parse pfx = do x <- parse (pfx ++ "_1")+ y <- parse (pfx ++ "_2")+ z <- parse (pfx ++ "_3")+ return (x,y,z)++{-+deriveScaffolded :: [Name] -> Q [Dec]+deriveScaffolded = mapM $ \n -> return $+ InstanceD [] (AppT (ConT (mkName "Scaffolded")) (ConT n)) []+-}