From c1e09d4ada65150d6bd9c391dd1aa4a1bf20b539 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 19 Sep 2023 11:12:36 +1200
Subject: [PATCH] Render onscreen keyboards (not interactive yet).

---
 bureaucromancy.cabal                |  2 +-
 src/Text/HTML/Form/WebApp.hs        | 19 +++++++++++++++++--
 src/Text/HTML/Form/WebApp/Ginger.hs |  8 +++++---
 tpl/base.html                       |  4 ++++
 4 files changed, 27 insertions(+), 6 deletions(-)

diff --git a/bureaucromancy.cabal b/bureaucromancy.cabal
index 82121a4..1fddcb0 100644
--- a/bureaucromancy.cabal
+++ b/bureaucromancy.cabal
@@ -74,7 +74,7 @@ library
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.16.4.0, ginger, file-embed-lzma, file-embed, mtl,
             bytestring, text, xml-conduit, network-uri, regex-tdfa, containers,
-            filepath
+            filepath, directory
 
     -- Directories containing source files.
     hs-source-dirs:   src
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index 687facd..a984614 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -6,9 +6,12 @@ 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)
+import Text.HTML.Form.WebApp.Ginger (template, resolveSource)
 import Text.HTML.Form.Query (renderQueryString)
 
 renderPage :: Form -> [Text] -> [(ByteString, Maybe ByteString)] -> IO (Maybe Text)
@@ -16,7 +19,7 @@ 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>"]
+    "<a href='/0/?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
 renderPage _ _ _ = return Nothing
 
 renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
@@ -44,6 +47,18 @@ renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] q
     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 [keyboard] qs =
+    template (Txt.unpack keyboard ++ ".html") form ix input qs
+renderInput form ix input [keyboard, ""] qs =
+    template (Txt.unpack keyboard ++ ".html") 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 (keyboard ++ ".html") = keyboard
+            | otherwise = "latin1"
+    template (keyboard' ++ ".html") form ix input qs
 renderInput _ _ input _ _ =
     return $ Just $ Txt.concat ["Unknown input type: ", inputType input]
 
diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs
index 88e8d40..f2ed50f 100644
--- a/src/Text/HTML/Form/WebApp/Ginger.hs
+++ b/src/Text/HTML/Form/WebApp/Ginger.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
-module Text.HTML.Form.WebApp.Ginger(template) where
+module Text.HTML.Form.WebApp.Ginger(template, resolveSource) where
 
 import Text.HTML.Form
 import Text.HTML.Form.Query (renderQueryString')
@@ -48,7 +48,7 @@ template name form ix input query
     xURI _ = return $ toGVal ()
 
 resolveSource :: FilePath -> Maybe (Maybe [Char])
-resolveSource = Just . fmap B8.unpack .
+resolveSource = Just . fmap utf8 .
     flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) .
     ('/':) . normalise
 
@@ -61,7 +61,6 @@ query2gval qs =
     }
   where
     q = '?':renderQueryString' [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs]
-    utf8 = Txt.unpack . Txt.decodeUtf8
     gElem :: Monad m => [ByteString] -> Function m
     gElem xs [(_, x)] | Just x' <- asBytes x = return$toGVal$Prelude.elem x' xs
     gElem _ _ = return $ toGVal ()
@@ -162,3 +161,6 @@ 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]
+
+utf8 :: ByteString -> String
+utf8 = Txt.unpack . Txt.decodeUtf8
diff --git a/tpl/base.html b/tpl/base.html
index 495deda..c859e9f 100644
--- a/tpl/base.html
+++ b/tpl/base.html
@@ -2,6 +2,7 @@
 <html>
 <head>
   <title>{{form.method}} {{form.action}}</title>
+  <meta charset=utf-8 />
   <style>
     body { background: black; color: #eee; font: medium sans-serif; }
     h1 { text-align: center }
@@ -21,6 +22,9 @@
     nav { column-count: 4 } /* FIXME: Screen width issues? */
     nav dl { margin: 0 }
     dt, dd { break-inside: avoid }
+
+    table td:not([colspan]) { width: 25% }
+    table td { text-align: center }
   </style>
 </head>
 <body>
-- 
2.30.2