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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
{-# 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 Network.URI (unEscapeString)
import System.IO (readFile')
import System.FilePath ((</>))
import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist)
import Text.HTML.Form (Form(..), Input(..))
import Text.HTML.Form.WebApp.Ginger (template, resolveSource)
import Text.HTML.Form.Query (renderQueryString, renderQuery')
type Query = [(ByteString, Maybe ByteString)]
renderPage :: Form -> [Text] -> Query -> IO (Maybe (Either Query 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 $ Right $ Txt.concat [
"<a href='/0/?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
renderPage _ _ _ = return Nothing
renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
IO (Maybe (Either Query Text))
renderInput form ix input [""] qs = renderInput form ix input [] qs
renderInput form ix input@Input { multiple = True } [p] qs
| '=':v' <- Txt.unpack p,
(utf8 $ inputName input, Just $ utf8' v') `Prelude.elem` qs =
renderInput form ix input [] $
unset (inputName input) (Txt.pack $ unEscapeString v') qs
| '=':v' <- Txt.unpack p = renderInput form ix input [] $
(utf8 $ inputName input, Just $ utf8' $ unEscapeString v'):qs
renderInput form ix input [p] qs
| '=':v' <- Txt.unpack p = renderInput form ix input [] $
set (inputName input) (Txt.pack $ unEscapeString v') qs
| ':':v' <- Txt.unpack p = renderInput form ix input [] $
set (inputName input)
(Txt.pack (get (inputName input) qs ++ v')) qs
| "-" <- Txt.unpack p, v'@(_:_) <- get (inputName input) qs =
renderInput form ix input [] $ set (inputName input)
(Txt.pack $ Prelude.init v') qs
| "-" <- Txt.unpack p = renderInput form ix input [] qs
renderInput form ix input [x, p] qs
| '=':v' <- Txt.unpack p = renderInput form ix input [x] $
set (inputName input) (Txt.pack $ unEscapeString v') qs
| ':':v' <- Txt.unpack p = renderInput form ix input [x] $
set (inputName input)
(Txt.pack (get (inputName input) qs ++ v')) qs
| "-" <- Txt.unpack p, v'@(_:_) <- get (inputName input) qs =
renderInput form ix input [x] $ set (inputName input)
(Txt.pack $ Prelude.init v') qs
| "-" <- Txt.unpack p = renderInput form ix input [x] 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 ix input $ unset k' v' qs
| v' == "", (utf8 k', Nothing) `Prelude.elem` qs =
template "checkbox.html" form ix input [
q | q@(k, v) <- qs, not (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 $ set k' v' qs
renderInput form ix input@Input { inputType="<select>" } [] qs =
template "select.html" form ix input qs
renderInput form ix input@Input { inputType="submit" } [] qs =
template "submit.html" form ix input qs
renderInput _ _ input@Input { inputType="submit" } ["_"] qs =
return $ Just $ Left $ set (inputName input) (value input) qs
renderInput form ix input@Input { inputType="image" } [] qs =
template "image-button.html" form ix input qs
renderInput _ _ input@Input { inputType="image" } ["_"] qs =
return $ Just $ Left $ set (inputName input) (value input) qs
renderInput form ix input@Input { inputType="reset" } [] qs =
template "reset.html" form ix input qs
renderInput form ix input@Input { inputType="reset" } ["_"] _ =
template "reset.html" form ix input
[(utf8' k, Just $ utf8' v) | (k, v) <- renderQuery' form]
renderInput form ix input [keyboard] qs =
renderInput form ix input [keyboard, ""] qs
renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path =
template path form ix input qs
where path = "keyboards/" ++ Txt.unpack keyboard ++ ".html"
renderInput form ix input [keyboard, ""] qs = do
configpath <- getXdgDirectory XdgConfig "bureaucromancy"
exists <- doesFileExist $ configpath </> "keyboard"
namespace <- if exists then readFile' $ configpath </> "keyboard"
else return "latin1"
let path = "keyboards/" ++ namespace ++ "/" ++ Txt.unpack keyboard ++ ".html"
let path2 = "keyboards/" ++ namespace ++ ".html"
let keyboard'
| Just (Just _) <- resolveSource path = path
| Just (Just _) <- resolveSource path2 = path2
| otherwise = "keyboards/latin1.html"
template keyboard' form ix input qs
renderInput form ix input [] qs = do
path <- getXdgDirectory XdgConfig "bureaucromancy"
exists <- doesFileExist $ path </> "keyboard"
keyboard <- if exists then readFile' $ path </> "keyboard"
else return "latin1"
let keyboard'
| Just (Just _) <- resolveSource ("keyboards/" ++ keyboard ++ ".html")
= keyboard
| otherwise = "latin1"
template ("keyboards/" ++ keyboard' ++ ".html") form ix input qs
renderInput _ _ input _ _ =
return $ Just $ Right $ Txt.concat ["Unknown input type: ", inputType input]
utf8 :: Text -> ByteString
utf8 = Txt.encodeUtf8
utf8' :: String -> ByteString
utf8' = utf8 . Txt.pack
set :: Text -> Text -> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
set "" _ qs = qs -- Mostly for buttons!
set k' v' qs = (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
unset :: Text -> Text -> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
unset k' v' qs = [q | q@(k, v) <- qs, not (k == utf8 k' && v == Just (utf8 v'))]
get :: Text -> [(ByteString, Maybe ByteString)] -> String
get k' qs
| Just (Just ret) <- utf8 k' `lookup` qs =
Txt.unpack $ Txt.decodeUtf8 ret
| otherwise = ""