src/Happstack/Server/Dialogs/Scaffold.hs

{-# 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
    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)) []
-}