diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/happstack-dlg.cabal b/happstack-dlg.cabal new file mode 100644 --- /dev/null +++ b/happstack-dlg.cabal @@ -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 +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 diff --git a/src/Happstack/Server/Dialogs.hs b/src/Happstack/Server/Dialogs.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Dialogs.hs @@ -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 + diff --git a/src/Happstack/Server/Dialogs/Scaffold.hs b/src/Happstack/Server/Dialogs/Scaffold.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Dialogs/Scaffold.hs @@ -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 $ + "" + ++ escapeHtml s ++ "
" + ++ "
" + ++ render "dlg-vals" v + ++ "" + ++ "" + ++ "" + ++ "
" + ++ "" + 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 = "" + parse pfx = fmap (fromMaybe "") $ getDataFn (look pfx) + +instance Scaffolded Bool where + render pfx v = "" + 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 + ++ "
" + ++ 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 + ++ "
" + ++ render (pfx ++ "_2") y + ++ "
" + ++ 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)) [] +-}