From 9014ee29b761a6991879b5740e1ba1cdc23dd997 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 30 Oct 2023 13:50:16 +1300
Subject: [PATCH] Add file-input support, upload missing files.

---
 form.html                           |  1 +
 src/Text/HTML/Form/Query.hs         |  2 +-
 src/Text/HTML/Form/WebApp.hs        | 39 ++++++++++++++++++++++++++---
 src/Text/HTML/Form/WebApp/Ginger.hs | 11 +++++---
 tpl/base.html                       |  1 +
 tpl/files.html                      | 15 +++++++++++
 tpl/image-button.html               | 15 +++++++++++
 tpl/reset.html                      |  8 ++++++
 tpl/submit.html                     | 10 ++++++++
 9 files changed, 95 insertions(+), 7 deletions(-)
 create mode 100644 tpl/files.html
 create mode 100644 tpl/image-button.html
 create mode 100644 tpl/reset.html
 create mode 100644 tpl/submit.html

diff --git a/form.html b/form.html
index d992a0b..077cd9c 100644
--- a/form.html
+++ b/form.html
@@ -11,6 +11,7 @@
     <label><input type="radio" name="char" value="horatio" />Prof Graw Horatio</label>
     <label><input type="radio" name="char" value="udo" />Udo Malaaki</label>
     <label><input type="radio" name="char" value="elgar" />Magus Elgar</label>
+    <label><input type="file" name="file" />Upload a file!</label>
   </form>
 </body>
 </html>
diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs
index 2dbf4ae..2a235f2 100644
--- a/src/Text/HTML/Form/Query.hs
+++ b/src/Text/HTML/Form/Query.hs
@@ -18,7 +18,7 @@ renderQuery' :: Form -> [(String, String)]
 renderQuery' form = concatMap renderInput' $ inputs form
 renderInput' :: Input -> [(String, String)]
 renderInput' Input { inputType = inputType' }
-    | inputType' `elem` ["submit", "reset", "button"] = []
+    | inputType' `elem` ["submit", "reset", "button", "file"] = []
 renderInput' Input { checked = False, inputType = inputType' }
     | inputType' `elem` ["radio", "checkbox"] = []
 renderInput' Input { inputType = "<select>",
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index d09a826..6dd79a8 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -4,16 +4,21 @@ 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 ((</>))
-import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist)
+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, resolveSource)
+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
@@ -78,6 +83,27 @@ renderInput form ix input@Input { inputType="reset" } [] 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 [keyboard] qs =
     renderInput form ix input [keyboard, ""] qs
 renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path =
@@ -124,3 +150,10 @@ 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)
diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs
index c8e2962..db8f873 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, resolveSource) where
+module Text.HTML.Form.WebApp.Ginger(template, template', resolveSource, list') where
 
 import Text.HTML.Form
 import Text.HTML.Form.Query (renderQueryString')
@@ -29,7 +29,12 @@ import qualified Data.Map as M
 type Query = [(ByteString, Maybe ByteString)]
 template :: Monad m => String -> Form -> Int -> Input -> Query ->
         m (Maybe (Either Query Text))
-template name form ix input query
+template name form ix input query =
+    template' name form ix input query $ const $ toGVal ()
+template' :: Monad m => String -> Form -> Int -> Input -> Query ->
+        (Text -> GVal (Run SourcePos (Writer Html) Html)) ->
+        m (Maybe (Either Query Text))
+template' name form ix input query ctxt'
     | Just (Right tpl) <- parseGingerFile resolveSource name =
         return $ Just $ Right $ htmlSource $
             flip runGinger tpl $ makeContextHtml ctxt
@@ -44,7 +49,7 @@ template name form ix input query
         Prelude.zip [0..] $ inputs form
     ctxt "input" = input2gval (ix, input) query
     ctxt "xURI" = fromFunction xURI
-    ctxt _ = toGVal ()
+    ctxt x = ctxt' x
     xURI [(_, uri)] = let uri' = Txt.unpack $ asText uri in
         return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri'
     xURI _ = return $ toGVal ()
diff --git a/tpl/base.html b/tpl/base.html
index df6f8f8..d4f476b 100644
--- a/tpl/base.html
+++ b/tpl/base.html
@@ -13,6 +13,7 @@
     .readonly { font-style: italic }
     .disabled { text-decoration: line-through }
     .selected { border-right: thick solid green }
+    :link { color: white }
 
     input, select, textarea { display: none; }
 
diff --git a/tpl/files.html b/tpl/files.html
new file mode 100644
index 0000000..59b9fc1
--- /dev/null
+++ b/tpl/files.html
@@ -0,0 +1,15 @@
+{% extends "base.html" %}
+
+{%- block main -%}
+  <ul>{% for ancestor in path %}{% if ancestor %}
+    <li><a href="{{ ancestor.link }}">{{ ancestor.name }}</a></li>
+  {% endif %}{% endfor %}</ul>
+  <ul>{% for dir in dirs %}
+    <li><a href="{{ dir }}/">{{ dir }}</a></li>
+  {% endfor %}</ul>
+  <ul>{% for file in files %}
+    <li><a href="/{{ input.index }}/={{ path|xURI }}{{ '/'|xURI }}{{ file|xURI }}">
+      {{ file }}
+    </a></li>
+  {% endfor %}</ul>
+{%- endblock -%}
diff --git a/tpl/image-button.html b/tpl/image-button.html
new file mode 100644
index 0000000..c7162c2
--- /dev/null
+++ b/tpl/image-button.html
@@ -0,0 +1,15 @@
+{% extends "base.html" %}
+
+{# NOTE: This is pretty much a legacy input type now.
+   We should be sending x/y coordinates to the server,
+   but that'd be frustrating to operate using e.g. a TV remote. #}
+
+{%- block main -%}<section>
+  <img src="{{ input.src }}" alt="{{ input.alt }}" title="{{ input.alt }}" />
+  <div>{{ input.description }}</div>
+  <hr />
+  <!-- TODO: Internationalize! -->
+  <p><a href="_{{Q}}">Upload</a> to
+    <code>{{ input.form.action|default(form.action) }}
+        ({{ input.form.method|default(form.method) }})</code></p>
+</section>{%- endblock -%}
diff --git a/tpl/reset.html b/tpl/reset.html
new file mode 100644
index 0000000..b050979
--- /dev/null
+++ b/tpl/reset.html
@@ -0,0 +1,8 @@
+{% extends "base.html" %}
+
+{%- block main -%}<section>
+  <div>{{ input.description }}</div>
+  <hr />
+  <!-- TODO: Internationalize! -->
+  <p>Restore <a href="_">defaults</a>!</p>
+</section>{%- endblock -%}
diff --git a/tpl/submit.html b/tpl/submit.html
new file mode 100644
index 0000000..cc64171
--- /dev/null
+++ b/tpl/submit.html
@@ -0,0 +1,10 @@
+{% extends "base.html" %}
+
+{%- block main -%}<section>
+  <div>{{ input.description }}</div>
+  <hr />
+  <!-- TODO: Internationalize! -->
+  <p><a href="_{{Q}}">Upload</a> to
+    <code>{{ input.form.action|default(form.action) }}
+        ({{ input.form.method|default(form.method) }})</code></p>
+</section>{%- endblock -%}
-- 
2.30.2