From 9dfdd80313442ee12864e72a46a86e165642d944 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Wed, 17 Mar 2021 18:19:52 -0400
Subject: Restful analysis endpoint

---
 Biz/Devalloc.hs | 56 +++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 37 insertions(+), 19 deletions(-)

(limited to 'Biz')

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 1b76cc6..bc1b83f 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -706,14 +706,13 @@ data Paths path = Paths
         :> "analysis"
         :> Capture "analysisId" (Id.Id Analysis)
         :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay),
-    githubAnalysis ::
+    postAnalysis ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "analysis"
-        :> "github"
-        :> Capture "user" Text
-        :> Capture "repo" Text
-        :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay),
+        :> QueryParam "user" Text
+        :> QueryParam "repo" Text
+        :> Post '[Lucid.HTML] (HtmlApp AnalysisDisplay),
     css ::
       path
         :- "css"
@@ -751,6 +750,11 @@ 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 ->
@@ -835,9 +839,12 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               +> \case
                 Nothing -> throwError err404
                 Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis,
-      githubAnalysis = \a owner repo ->
+      postAnalysis = \a mOwner mRepo ->
         guardAuth a
-          +> \user@User {..} ->
+          +> \user@User {..} -> do
+            owner <- requireParam "owner" mOwner
+            repo <- requireParam "repo" mRepo
+            -- we just assume github for now
             analyzeGitHub
               kp
               userId
@@ -909,6 +916,13 @@ htmlApp cooks kp cfg jwk oAuthArgs =
             Clay.borderColor yellow
             Clay.borderStyle Clay.solid
 
+          -- for making POST requests with a form disguised as a link
+          "input.link" ? do
+            Clay.borderWidth 0
+            Clay.fontSize (rem 1)
+            Biz.Look.marginAll (px 0)
+            Biz.Look.paddingAll (px 0)
+
           "label" ? do
             Clay.display Clay.inlineBlock
             Clay.width (px 100)
@@ -1018,6 +1032,8 @@ htmlApp cooks kp cfg jwk oAuthArgs =
                 Clay.borderBottomColor "#999"
                 Clay.borderBottomStyle Clay.solid
                 Clay.padding (em 1.5) 0 (em 1.5) 0
+                ".link" ? do
+                  Clay.fontSize (em 1.17)
     }
 
 -- | The front page pitch. Eventually I'd like to load the content from markdown
@@ -1214,18 +1230,20 @@ instance Lucid.ToHtml SelectRepo where
       displayRepo :: GitHub.Repo -> Lucid.Html ()
       displayRepo repo =
         Lucid.li_ <| do
-          Lucid.a_
-            [ Lucid.linkHref_ "/"
-                <| fieldLink
-                  githubAnalysis
-                  (GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo)
-                  (GitHub.untagName <| GitHub.repoName repo)
-            ]
-            <. Lucid.h3_
-            <. Lucid.toHtml
-            <. GitHub.untagName
-            <| GitHub.repoName repo
-          maybe mempty (Lucid.p_ <. Lucid.toHtml) (GitHub.repoDescription repo)
+          let action =
+                linkAction_ "/"
+                  <| fieldLink
+                    postAnalysis
+                    (Just <| GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo)
+                    (Just <| GitHub.untagName <| GitHub.repoName repo)
+          Lucid.form_ [action, Lucid.method_ "post"] <| do
+            Lucid.input_
+              [ Lucid.type_ "submit",
+                Lucid.class_ "link",
+                Lucid.value_ <| GitHub.untagName
+                  <| GitHub.repoName repo
+              ]
+            maybe mempty (Lucid.p_ <. Lucid.toHtml) (GitHub.repoDescription repo)
 
 -- * parts
 
-- 
cgit v1.2.3