~alcinnz/bureaucromancy

ref: 703b307333f90115a7512efcd660615a64a75700 bureaucromancy/src/Text/HTML/Form/WebApp.hs -rw-r--r-- 1.6 KiB
703b3073 — Adrian Cochrane Implement radio inputs, upload missing files, make space for descriptions & richer form controls to use. 1 year, 3 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
{-# LANGUAGE OverloadedStrings #-}
module Text.HTML.Form.WebApp (renderPage, Form(..)) where

import Data.ByteString as BS
import Data.Text as Txt
import Data.Text.Encoding as Txt
import Text.Read (readMaybe)

import Text.HTML.Form (Form(..), Input(..))
import Text.HTML.Form.WebApp.Ginger (template)
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 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 -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
    IO (Maybe Text)
renderInput form ix input@Input {inputType="checkbox", inputName=k', value=v'} [] qs
    | (utf8 k', Just $ utf8 v') `Prelude.elem` 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 ix input [
            q | q@(k, v) <- qs, k /= utf8 k', v /= Nothing]
    | otherwise =
        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