6 files changed, 222 insertions(+), 8 deletions(-)

A src/Text/HTML/Form/Query.hs
M src/Text/HTML/Form/WebApp.hs
A src/Text/HTML/Form/WebApp/Ginger.hs
A tpl/base.html
A tpl/checkbox.html
A tpl/radio.html

@@ 0,0 1,19 @@
+module Text.HTML.Form.Query(
+    renderQueryString, renderQueryString', renderQuery') where
+
+import Text.HTML.Form (Form(..), Input(..))
+import Network.URI (escapeURIString, isUnescapedInURIComponent)
+import Data.List (intercalate)
+import Data.Text (unpack)
+
+renderQueryString :: Form -> String
+renderQueryString = renderQueryString' . renderQuery'
+renderQueryString' query = intercalate "&" [
+    escape key ++ '=':escape value | (key, value) <- query
+  ]
+
+renderQuery' :: Form -> [(String, String)]
+renderQuery' form = [(unpack $ inputName input, unpack $ value input)
+    | input <- inputs form, checked input]
+
+escape = escapeURIString isUnescapedInURIComponent

@@ 13,24 13,26 @@ import Text.HTML.Form.Query (renderQueryString)
 renderPage :: Form -> [Text] -> [(ByteString, Maybe ByteString)] -> IO (Maybe Text)
 renderPage form (n:path) query
     | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) =
-        renderInput form (inputs form !! ix) path query
+        renderInput form ix (inputs form !! ix) path query
 renderPage form [] _ = return $ Just $ Txt.concat [
     "<a href='/0?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
 renderPage _ _ _ = return Nothing
 
-renderInput :: Form -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
+renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
     IO (Maybe Text)
-renderInput form input@Input {inputType = "checkbox", inputName = k', value = v'}
-        [] qs
+renderInput form ix input@Input {inputType="checkbox", inputName=k', value=v'} [] qs
     | (utf8 k', Just $ utf8 v') `Prelude.elem` qs =
-        template "checkbox.html" form input qs [
+        template "checkbox.html" form ix input [
             q | q@(k, v) <- qs, k /= utf8 k', v /= Just (utf8 v')]
     | v' == "", (utf8 k', Nothing) `Prelude.elem` qs =
-        template "checkbox.html" form input qs [
+        template "checkbox.html" form ix input [
             q | q@(k, v) <- qs, k /= utf8 k', v /= Nothing]
     | otherwise =
-        template "checkbox.html" form input qs ((utf8 k', Just $ utf8 v'):qs)
-renderInput _ _ _ _ = return Nothing
+        template "checkbox.html" form ix input $ (utf8 k', Just $ utf8 v'):qs
+renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] qs =
+    template "checkbox.html" form ix input $
+        (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
+renderInput _ _ _ _ _ = return Nothing
 
 utf8 :: Text -> ByteString
 utf8 = Txt.encodeUtf8

@@ 0,0 1,149 @@
+{-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
+module Text.HTML.Form.WebApp.Ginger(template) where
+
+import Text.HTML.Form
+import Text.HTML.Form.Query (renderQueryString')
+
+import FileEmbedLzma
+import Data.FileEmbed
+import System.FilePath
+
+import Text.Ginger.Parse (parseGingerFile, SourcePos)
+import Text.Ginger.Run (runGinger, makeContextHtml, Run)
+import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>))
+import Text.Ginger.Html (Html, htmlSource, unsafeRawHtml)
+import Control.Monad.Writer.Lazy (Writer)
+
+import Data.Text as Txt
+import Data.Text.Encoding as Txt
+import Data.Text.Lazy as Txt (toStrict)
+import Data.ByteString.Char8 as B8
+import Network.URI (uriToString)
+import Text.XML (Document(..), Element(..), Prologue(..), Node, def, renderText)
+
+import Data.List (nub)
+import Data.Maybe (fromMaybe, isJust)
+import qualified Data.Map as M
+
+type Query = [(ByteString, Maybe ByteString)]
+template :: Monad m => String -> Form -> Int -> Input -> Query -> m (Maybe Text)
+template name form ix input query
+    | Just (Right tpl) <- parseGingerFile resolveSource name =
+        return $ Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt
+    | Just (Left err) <- parseGingerFile resolveSource name =
+        return $ Just $ Txt.pack $ show err
+    | otherwise = return $ Just "Unexpected error!"
+  where
+    ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html)
+    ctxt "Q" = query2gval query
+    ctxt "form" = form2gval form
+    ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $
+        Prelude.zip [0..] $ inputs form
+    ctxt "input" = input2gval (ix, input) query
+    ctxt _ = toGVal ()
+
+resolveSource :: FilePath -> Maybe (Maybe [Char])
+resolveSource = Just . fmap B8.unpack .
+    flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) .
+    ('/':) . normalise
+
+query2gval :: Query -> GVal m
+query2gval qs =
+    (orderedDict [(Txt.decodeUtf8 k, list1 vs) | (k, vs) <- groupSort qs]) {
+        asText = Txt.pack q,
+        asHtml = unsafeRawHtml $ Txt.pack q
+    }
+  where
+    q = '?':renderQueryString' [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs]
+    utf8 = Txt.unpack . Txt.decodeUtf8
+
+form2gval :: Form -> GVal m
+form2gval form = orderedDict [
+    "action"   ~> uriToString id (action form) "",
+    "enctype"  ~> enctype form,
+    "method"   ~> method form,
+    "validate" ~> validate form,
+    "target"   ~> target form,
+    "charset"  ~> acceptCharset form,
+    "autocomplete"~>autocomplete form,
+    "name"     ~> formName form,
+    "rel"      ~> rel form
+  ]
+
+input2gval :: (Int, Input) -> Query -> GVal m
+input2gval (ix, input) query = orderedDict [
+    "index"       ~> ix,
+    "label"       ~> label input,
+    "description" ~> html (description input),
+    "inputType"   ~> inputType input,
+    "dirName"     ~> dirname input,
+    "name"        ~> inputName input,
+    "value"       ~> value input,
+    "autocomplete"~> inputAutocomplete input,
+    "autofocus"   ~> autofocus input,
+    "checked"     ~> if value input == ""
+        then isJust $ Prelude.lookup (Txt.encodeUtf8 $ inputName input) query
+        else (Txt.encodeUtf8 $ inputName input,
+            Just $ Txt.encodeUtf8 $ value input) `Prelude.elem` query,
+    "disabled"    ~> disabled input,
+    "readonly"    ~> readonly input,
+    "multiple"    ~> multiple input,
+    ("form", orderedDict [
+        "action"  ~> (flip (uriToString id) "" <$> formAction input),
+        "enctype" ~> formEnctype input,
+        "method"  ~> formMethod input,
+        "validate"~> formValidate input,
+        "target"  ~> formTarget input
+    ]),
+    "inputmode"   ~> inputMode input,
+    ("list", list' $ Prelude.map optgroup2gval $ list input),
+    "min"         ~> fst (range input),
+    "max"         ~> snd (range input),
+    "step"        ~> step input,
+    "minlength"   ~> fst (lengthRange input),
+    "maxLength"   ~> snd (lengthRange input),
+    "required"    ~> required input,
+    "placeholder" ~> placeholder input,
+    "title"       ~> title input,
+    "size"        ~> size input,
+    "accept"      ~> fileAccept (fileData input),
+    "capture"     ~> fileCapture (fileData input),
+    "alt"         ~> imgAlt (imageData input),
+    "width"       ~> fst (imgSize $ imageData input),
+    "height"      ~> snd (imgSize $ imageData input),
+    "src"         ~> imgSrc (imageData input),
+    "autocorrect" ~> autocorrect (textArea input),
+    "cols"        ~> size input,
+    "rows"        ~> rows (textArea input),
+    "spellcheck"  ~> spellcheck (textArea input),
+    "textwrap"    ~> textwrap (textArea input)
+  ]
+html :: Node -> Html
+html node = unsafeRawHtml $ Txt.toStrict $ renderText def (
+    Document (Prologue [] Nothing []) (Element "div" M.empty [node]) []
+  )
+optgroup2gval :: OptionGroup -> GVal m
+optgroup2gval optgroup = orderedDict [
+    "label"    ~> optsLabel optgroup,
+    "disabled" ~> optsDisabled optgroup,
+    ("opts", list' $ Prelude.map opt2gval $ subopts optgroup)
+  ]
+opt2gval :: Option -> GVal m
+opt2gval opt = orderedDict [
+    "label"    ~> optLabel opt,
+    "value"    ~> optValue opt,
+    "selected" ~> optSelected opt,
+    "disabled" ~> optDisabled opt
+  ]
+
+list1 :: ToGVal m a => [a] -> GVal m
+list1 vs@(v:_) = (toGVal v) {
+    asList = Just $ Prelude.map toGVal vs,
+    V.length = Just $ Prelude.length vs
+  }
+list1 [] = (toGVal True) { asList = Just [], V.length = Just 0 }
+list' :: [GVal m] -> GVal m
+list' = toGVal
+
+groupSort :: Eq k => [(k, Maybe v)] -> [(k, [v])]
+groupSort q = [(k, [v | (k', Just v) <- q, k == k']) | k <- nub $ Prelude.map fst q]

@@ 0,0 1,42 @@
+<!DOCTYPE html>
+<html>
+<head>
+  <title>{{form.method}} {{form.action}}</title>
+  <style>
+    body { background: black; color: #eee; font: medium sans-serif; }
+    h1 { text-align: center }
+    aside { width: 20%; border-right: thin solid #eee; }
+    dt { font-weight: bold }
+    dt a { color: inherit }
+    .checked { color: lightgreen }
+    .readonly { font-style: italic }
+    .disabled { text-decoration: line-through }
+    .selected { border-right: thick solid green }
+
+    input, select, textarea { display: none; }
+
+    main { display: flex; flex-direction: row; }
+    section { padding: 20px }
+  </style>
+</head>
+<body>
+  <h1><strong>{{form.method}}</strong> <em>{{form.action}}</em></h1>
+  <main>
+  {% set selected=input.index %}
+  <aside><dl>{% for input in inputs %}
+    <dt class="{% if input.checked %}checked{% endif %} {% if input.index == selected %}selected{% endif %}">
+      {% if input.checked %}&check;{% endif %}
+      {% if input.disabled %}{{ input.label }}
+      {% else %}<a href="/{{input.index}}{{Q}}" title="{{input.title}}">{{ input.label }}</a>
+      {% endif %}</dt>
+    <dd class="{% if input.readonly %}readonly{% endif %}">{{ input.value }}</dd>
+  {% endfor %}</dl></aside>
+
+  {% block main %}
+    <section>
+      {{ input.description }}
+    </section>
+  {% endblock %}
+  </main>
+</body>
+</html>

@@ 0,0 1,1 @@
+{% extends "base.html" %}

@@ 0,0 1,1 @@
+{% extends "base.html" %}