summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2021-03-25 22:06:46 -0400
committerBen Sima <ben@bsima.me>2021-03-25 22:06:46 -0400
commit3c6a5cbe147233934d6b5e2a6359b7d479a1e97d (patch)
tree14a0dcd9ac7c558b2b37baf2d73d12bfeecf2d83 /Biz
parent82e8dc3d0f747a5737359228eebb02f7a5ab7912 (diff)
Add manual submission form
Diffstat (limited to 'Biz')
-rw-r--r--Biz/Devalloc.hs48
1 files 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