~alcinnz/bureaucromancy

ref: 043b1cdefa6d82a3a31f1d22f37f56f9b36feea7 bureaucromancy/src/Text/HTML/Form/WebApp.hs -rw-r--r-- 7.6 KiB
043b1cde — Adrian Cochrane Implement tel input type 1 year, 2 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
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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
{-# 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 Data.List as L
import Text.Read (readMaybe)
import Network.URI (unEscapeString)
import System.IO (readFile')
import System.FilePath ((</>), normalise)
import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist,
        doesDirectoryExist, listDirectory, getHomeDirectory)

import Text.HTML.Form (Form(..), Input(..))
import Text.HTML.Form.WebApp.Ginger (template, template', resolveSource, list')
import Text.HTML.Form.Query (renderQueryString, renderQuery')

import Text.Ginger.GVal as V (GVal(..), toGVal, orderedDict, (~>))
import Text.Ginger.Html (html)

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@Input { inputType="file" } path qs = do
    home <- getHomeDirectory
    let filepath = normalise $ L.foldl (</>) home $ L.map Txt.unpack path
    subfiles <- listDirectory filepath
    (dirs, files) <- partitionM (doesDirectoryExist' filepath) subfiles
    template' "files.html" form ix input qs $ \x -> case x of
        "path" -> (list'$L.map buildBreadcrumb$L.inits$L.map Txt.unpack path) {
            asText = Txt.pack filepath,
            asHtml = html $ Txt.pack filepath
          }
        "files" -> toGVal files
        "dirs" -> toGVal dirs
        _ -> toGVal ()
  where
    buildBreadcrumb :: [String] -> GVal m
    buildBreadcrumb [] = toGVal False
    buildBreadcrumb path' = orderedDict [
        "name" ~> L.last path',
        "link" ~> ('/':show ix ++ '/':L.intercalate "/" path')
      ]
    doesDirectoryExist' parent file = doesDirectoryExist $ parent </> file
renderInput form ix input@Input { inputType = "tel" } [] qs =
    template "number.html" form ix input qs
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 = ""

partitionM :: Monad f => (a -> f Bool) -> [a] -> f ([a], [a])
partitionM _ [] = pure ([], [])
partitionM f (x:xs) = do
    res <- f x
    (as,bs) <- partitionM f xs
    pure ([x | res]++as, [x | not res]++bs)