From e682e5ce2a9e5da5e3c70617fbfeb0c7ad091547 Mon Sep 17 00:00:00 2001
From: Profpatsch <mail@profpatsch.de>
Date: Mon, 29 Jul 2024 11:48:56 +0200
Subject: fix(users/Profpatsch/whatcd-resolver): make getTorrent no js

Start of an effort to make the app work without javascript
enabled (graceful degradation yay).

We use a trick where buttons are nested into a form element, passing
their value as input; this should be better than depending on
`hx-vals`. If htmx is disabled, just redirect and reload the full page
instead of sending back the snippet. Probably depends on the use-case
of each snippet though.

Change-Id: I6c73e624c4bd29b1cbd5492b2f84f48102edc68b
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12056
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
---
 .../whatcd-resolver/src/WhatcdResolver.hs          | 37 +++++++++++++++++++---
 1 file changed, 32 insertions(+), 5 deletions(-)

(limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')

diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index a3fa07c181a3..bfbb49684ce1 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -135,7 +135,7 @@ htmlUi = do
                     Html.mkVal <$> (runTransaction $ getTorrentById dat)
                 ),
                 ( "snips/redacted/getTorrentFile",
-                  respond.html $ \span -> do
+                  respond.htmlOrReferer $ \span -> do
                     dat <- torrentIdMp span
                     runTransaction $ do
                       inserted <- redactedGetTorrentFileAndInsert dat
@@ -292,6 +292,17 @@ htmlUi = do
             />
         |]
 
+-- | Reload the current page (via the Referer header) if the browser has Javascript disabled (and thus htmx does not work). This should make post requests work out of the box.
+htmxOrReferer :: Wai.Request -> Wai.Response -> Wai.Response
+htmxOrReferer req act = do
+  let fnd h = req & Wai.requestHeaders & List.find (\(hdr, _) -> hdr == h)
+  let referer = fnd "Referer"
+  if
+    | Just _ <- fnd "Hx-Request" -> act
+    | Nothing <- referer -> act
+    | Just (_, rfr) <- referer -> do
+        Wai.responseLBS seeOther303 [("Location", rfr)] ""
+
 htmlPageChrome :: (ToHtml a) => Text -> a -> Html
 htmlPageChrome title body =
   Html.docTypeHtml $
@@ -350,6 +361,8 @@ data HandlerResponses m = HandlerResponses
     html :: (Otel.Span -> m Html) -> m ResponseReceived,
     -- | render html after parsing some query arguments
     htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived),
+    -- | render html or reload the page via the Referer header if no htmx
+    htmlOrReferer :: (Otel.Span -> m Html) -> m ResponseReceived,
     -- | render a plain wai response
     plain :: (m Wai.Response -> m ResponseReceived)
   }
@@ -363,7 +376,7 @@ runHandlers ::
   m ResponseReceived
 runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
   let path = req & Wai.pathInfo & Text.intercalate "/"
-  let html act =
+  let html' resp act =
         Otel.inSpan'
           [fmt|Route /{path}|]
           ( Otel.defaultSpanArguments
@@ -376,8 +389,11 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
           )
           ( \span -> do
               res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" []))
-              liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html
+              liftIO $ respond (resp res)
           )
+  let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html
+  let html = html' htmlResp
+  let htmlOrReferer = html' $ \res -> htmxOrReferer req (htmlResp res)
 
   let handlerResponses =
         ( HandlerResponses
@@ -401,7 +417,8 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
                               <h1>Error:</h1>
                               <pre>{err & prettyErrorTree}</pre>
                             |]
-                      )
+                      ),
+              htmlOrReferer
             }
         )
   let handler =
@@ -542,7 +559,17 @@ getBestTorrentsData artistFilter = do
 mkBestTorrentsTable :: [TorrentData (Label "percentDone" Percentage)] -> Html
 mkBestTorrentsTable fresh = do
   let localTorrent b = case b.torrentStatus of
-        NoTorrentFileYet -> [hsx|<button hx-post="snips/redacted/getTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button>|]
+        NoTorrentFileYet ->
+          [hsx|
+        <form method="post">
+          <input type="hidden" name="torrent-id" value={b.torrentId & show} />
+          <button
+            formaction="snips/redacted/getTorrentFile"
+            hx-post="snips/redacted/getTorrentFile"
+            hx-swap="outerHTML"
+            hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button>
+        </form>
+        |]
         InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|]
         NotInTransmissionYet -> [hsx|<button hx-post="snips/redacted/startTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Start Torrent</button>|]
   let bestRows =
-- 
cgit 1.4.1