From 3c6a5cbe147233934d6b5e2a6359b7d479a1e97d Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Thu, 25 Mar 2021 22:06:46 -0400
Subject: Add manual submission form

---
 Biz/Devalloc.hs | 48 ++++++++++++++++++++++++++++++++----------------
 1 file changed, 32 insertions(+), 16 deletions(-)

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 3f7afe5..b58068c 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -763,8 +763,7 @@ data Paths path = Paths
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "analysis"
-        :> QueryParam "user" Text
-        :> QueryParam "repo" Text
+        :> ReqBody '[FormUrlEncoded] SubmitAnalysis
         :> Post '[Lucid.HTML] (App.Html AnalysisDisplay),
     admin ::
       path
@@ -815,11 +814,6 @@ guardScope =
              <| throwError err503 {errBody = "Scopes are not correct"}
        )
 
-requireParam :: MonadError ServerError m => LBS.ByteString -> Maybe b -> m b
-requireParam _ (Just b) = pure b
-requireParam a Nothing =
-  throwError err406 {errBody = "Required param not found: " <> a}
-
 -- | Main HTML handlers for all paths.
 htmlApp ::
   Auth.CookieSettings ->
@@ -904,11 +898,9 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               +> \case
                 Nothing -> throwError err404
                 Just analysis -> pure <| App.Html <| AnalysisDisplay user analysis,
-      postAnalysis = \a mOwner mRepo ->
+      postAnalysis = \a SubmitAnalysis {..} ->
         guardAuth a
           +> \user@User {..} -> do
-            owner <- requireParam "owner" mOwner
-            repo <- requireParam "repo" mRepo
             -- we just assume github for now
             analyzeGitHub
               kp
@@ -1052,6 +1044,17 @@ instance Lucid.ToHtml AdminDashboard where
     Lucid.main_ <| do
       Lucid.section_ <| do
         Lucid.h2_ <| Lucid.toHtml <| "Total Analyses: " <> tshow totalAnalyses
+      Lucid.section_ <| do
+        Lucid.h2_ "Post analysis"
+        let action = linkAction_ "/" <| fieldLink postAnalysis
+        Lucid.form_ [action, Lucid.method_ "post"] <| do
+          Lucid.input_ [Lucid.type_ "text", Lucid.name_ "owner"]
+          Lucid.input_ [Lucid.type_ "text", Lucid.name_ "repo"]
+          Lucid.input_
+            [ Lucid.type_ "submit"
+            ]
+
+      Lucid.section_ <| do
         Lucid.h2_ "All Users"
         Lucid.ul_
           <| forM_ allUsers
@@ -1317,12 +1320,7 @@ instance Lucid.ToHtml SelectRepo where
       displayRepo :: GitHub.Repo -> Lucid.Html ()
       displayRepo repo =
         Lucid.li_ <| do
-          let action =
-                linkAction_ "/"
-                  <| fieldLink
-                    postAnalysis
-                    (Just <| GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo)
-                    (Just <| GitHub.untagName <| GitHub.repoName repo)
+          let action = linkAction_ "/" <| fieldLink postAnalysis
           Lucid.form_ [action, Lucid.method_ "post"] <| do
             Lucid.input_
               [ Lucid.type_ "submit",
@@ -1330,6 +1328,16 @@ instance Lucid.ToHtml SelectRepo where
                 Lucid.value_ <| GitHub.untagName
                   <| GitHub.repoName repo
               ]
+            Lucid.input_
+              [ Lucid.type_ "hidden",
+                Lucid.name_ "owner",
+                Lucid.value_ <| GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo
+              ]
+            Lucid.input_
+              [ Lucid.type_ "hidden",
+                Lucid.name_ "repo",
+                Lucid.value_ <| GitHub.untagName <| GitHub.repoName repo
+              ]
             when (GitHub.repoPrivate repo) <| privateBadge
             maybe mempty (Lucid.p_ <. Lucid.toHtml) (GitHub.repoDescription repo)
       privateBadge = Lucid.span_ [Lucid.class_ "badge"] "Private"
@@ -1379,6 +1387,14 @@ footer =
 
 -- * analysis
 
+data SubmitAnalysis = SubmitAnalysis
+  { owner :: Text,
+    repo :: Text
+  }
+  deriving (Eq, Show, Generic)
+
+instance Web.FromForm SubmitAnalysis
+
 -- | I need more information than just 'Analysis' has to render a full, useful
 -- web page, hence this type.
 data AnalysisDisplay = AnalysisDisplay User Analysis
-- 
cgit v1.2.3