src/Happstack/Server/Dialogues/Scaffold.hs

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