diff options
| -rw-r--r-- | Biz/Devalloc.hs | 56 |
1 files changed, 37 insertions, 19 deletions
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 |