diff options
| -rw-r--r-- | Biz/Devalloc.hs | 48 |
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 |