happstack-dlg 0.1.1 → 0.1.2

raw patch · 6 files changed

+405/−311 lines, 6 filesdep +applicative-extrasdep +bytestringdep +formletsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: applicative-extras, bytestring, formlets, xhtml

API changes (from Hackage documentation)

Files

• happstack-dlg.cabal +6/−4
• src/Happstack/Server/Dialogs.hs +0/−212
• src/Happstack/Server/Dialogs/Scaffold.hs +0/−95
• src/Happstack/Server/Dialogues.hs +248/−0
• src/Happstack/Server/Dialogues/Formlets.hs +24/−0
• src/Happstack/Server/Dialogues/Scaffold.hs +127/−0

@@ -1,5 +1,5 @@ Name:                happstack-dlg-Version:             0.1.1+Version:             0.1.2 Cabal-Version:       >= 1.2 Synopsis:            Cross-request user interactions for Happstack Description:         A mechanism for user interactions that extend through@@ -17,7 +17,9 @@ Library     Build-Depends:   base <5, containers, mtl,                      happstack-server, time, random,-                     template-haskell-    Exposed-Modules: Happstack.Server.Dialogs,-                     Happstack.Server.Dialogs.Scaffold+                     template-haskell, formlets, xhtml,+                     applicative-extras, bytestring+    Exposed-Modules: Happstack.Server.Dialogues,+                     Happstack.Server.Dialogues.Scaffold,+                     Happstack.Server.Dialogues.Formlets     Hs-Source-Dirs:  src

@@ -1,212 +0,0 @@-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-

@@ -1,95 +0,0 @@-{-# 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)                = "&#34;" ++ escapeHtml cs-escapeHtml ('\'':cs)                = "&#39;" ++ escapeHtml cs-escapeHtml ('&' :cs)                = "&#38;" ++ escapeHtml cs-escapeHtml ('<' :cs)                = "&#60;" ++ escapeHtml cs-escapeHtml ('>' :cs)                = "&#62;" ++ 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 ++ "<br>"-    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 ++ "<br>"-    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)) []--}

@@ -0,0 +1,248 @@+{-# 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+

@@ -0,0 +1,24 @@+module Happstack.Server.Dialogues.Formlets where++import Happstack.Server.Dialogues++import Text.XHtml.Strict+import Text.XHtml.Strict.Formlets hiding (hidden)+import Control.Applicative.Error (Failing (..))++import Happstack.Server.SimpleHTTP hiding (method)++import Control.Monad.Identity++showForm :: Monad m => XHtmlForm Identity a -> Dlg m (Maybe a)+showForm f = showPage render parse+    where render uri = let (_, Identity html, _) = runFormState [] f+                       in  return $ toResponse $+                              form ! [method "POST", action uri] << (html+                                  +++ submit "submit" "submit"+                                  )+          parse    = withDataFn lookPairs $ \env -> do+                        let (Identity x, _, _) = runFormState (map (fmap Left) env) f+                        case x of Success a -> return (Just a)+                                  Failure _ -> return Nothing+

@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Happstack.Server.Dialogues.Scaffold where++import Happstack.Server+import Happstack.Server.Dialogues+import Language.Haskell.TH++import qualified Data.ByteString.Lazy.Char8 as B++import Data.Char  (ord)+import Data.Maybe (fromMaybe)++import Data.List++escapeHtml :: String -> String+escapeHtml ""                       = ""+escapeHtml ('\"':cs)                = "&#34;" ++ escapeHtml cs+escapeHtml ('\'':cs)                = "&#39;" ++ escapeHtml cs+escapeHtml ('&' :cs)                = "&#38;" ++ escapeHtml cs+escapeHtml ('<' :cs)                = "&#60;" ++ escapeHtml cs+escapeHtml ('>' :cs)                = "&#62;" ++ 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 uri = return $ setHeader "Content-type" "text/html" $ toResponse $+            "<html><body>"+            ++ escapeHtml s ++ "<br><hr>"+            ++ "<form action=\"" ++ uri ++ "\">"+            ++ render "dlg-vals" v+            ++ "<input type=\"submit\" value=\"Submit\">"+            ++ "<script type=\"text/javascript\">"+            ++ "    document.forms[0].elements[0].focus();"+            ++ "</script>"+            ++ "</form>"+            ++ "</html></body>"+          inp = parse "dlg-vals" v++{-|+    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 -> a -> 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 B.ByteString where+    render pfx s = "<textarea name=\"" ++ pfx ++ "\">" ++ escapeHtml (B.unpack s) ++ "</textarea><br>"+    parse  pfx _ = do x <- getDataFn (lookInput pfx)+                      case x of Just inp -> return (inputValue inp)+                                Nothing  -> return B.empty++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 v = fmap read $ parse pfx undefined++instance (Scaffolded a, Scaffolded b) => Scaffolded (a, b) where+    render pfx (x,y) = render (pfx ++ "_1") x ++ "<br>"+                    ++ render (pfx ++ "_2") y ++ "<br>"+    parse  pfx (x,y) = do x <- parse (pfx ++ "_1") x+                          y <- parse (pfx ++ "_2") y+                          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 ++ "<br>"+    parse  pfx (x,y,z) = do x <- parse (pfx ++ "_1") x+                            y <- parse (pfx ++ "_2") y+                            z <- parse (pfx ++ "_3") z+                            return (x,y,z)++{-|+    Wrapper type to present a list of options.+-}+data Choice a = Choice [a] Int deriving Show++toChoice :: (Bounded a, Enum a, Eq a) => a -> Choice a+toChoice x = let choices = [minBound .. maxBound]+             in  Choice choices (fromMaybe minBound $ elemIndex x choices)++fromChoice :: Choice a -> a+fromChoice (Choice cs i) = cs !! i++chooseFrom :: [a] -> Choice a+chooseFrom xs = Choice xs 0++instance (Eq a, Show a) => Scaffolded (Choice a) where+    render pfx (Choice cs i) = concat+        [ "<input type=\"radio\" name=\"" ++ escapeHtml pfx ++ "\""+          ++ " value=\"" ++ show i' ++ "\""+          ++ if i == i' then " selected>" else ">"+          ++ "<br>"+          | (c,i') <- zip cs [0..] ]+    parse  pfx (Choice cs _) = fmap (Choice cs . read) $ parse pfx undefined++{-+deriveScaffolded :: [Name] -> Q [Dec]+deriveScaffolded = mapM $ \n -> return $+    InstanceD [] (AppT (ConT (mkName "Scaffolded")) (ConT n)) []+-}+