diff options
| -rw-r--r-- | Biz/Devalloc.hs | 85 |
1 files changed, 44 insertions, 41 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index c6a86b4..bdb958f 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -78,6 +78,7 @@ import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet, (&&&), (@=)) import qualified Data.IxSet as IxSet import qualified Data.List as List import Data.SafeCopy (base, deriveSafeCopy) +import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding @@ -622,6 +623,19 @@ guardAuth = \case Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} Auth.Authenticated user -> pure user +requiredScopes :: Set Text +requiredScopes = Set.fromList ["repo"] + +guardScope :: Text -> Handler () +guardScope = + Text.split (== ',') + .> Set.fromList + .> Set.isSubsetOf requiredScopes + .> ( \ok -> + unless ok + <| throwError err503 {errBody = "Scopes are not correct"} + ) + -- | Main HTML handlers for all paths. htmlApp :: Auth.CookieSettings -> @@ -639,7 +653,9 @@ htmlApp cooks kp cfg jwk oAuthArgs = githubAuth = \case Nothing -> throwError err503 {errBody = "Bad response from GitHub API"} Just code -> do - token <- getAccessToken oAuthArgs code |> liftIO + OAuthResponse {..} <- githubOauth oAuthArgs code |> liftIO + guardScope scope + let token = Encoding.encodeUtf8 access_token user <- GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR |> liftIO @@ -818,7 +834,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = Clay.padding (px 0) 0 0 0 "li" ? do Clay.borderBottomWidth (px 1) - Clay.borderBottomColor "#999" -- TODO: more subtle gradient? + Clay.borderBottomColor "#999" Clay.borderBottomStyle Clay.solid Clay.padding (em 1.5) 0 (em 1.5) 0 } @@ -938,7 +954,7 @@ instance Lucid.ToHtml UserAccount where style :: Clay.Css -> Lucid.Attribute style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] --- | A type for parsing JSON auth responses, used in 'getAccessToken' below. +-- | A type for parsing JSON auth responses, used in 'githubOauth' below. -- Should be moved to Biz.Auth with others. data OAuthResponse = OAuthResponse { access_token :: Text, @@ -947,20 +963,16 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) --- | POST to GitHub's oAuth service and pure the user's oAuth token. --- TODO: I can also get access scope etc from this response -getAccessToken :: +-- | POST to GitHub's OAuth service and get the user's oAuth token. +githubOauth :: OAuthArgs -> Text -> -- | This should be GitHub.Token but GitHub.Auth doesn't export Token. - IO ByteString -getAccessToken OAuthArgs {..} code = - Req.runReq Req.defaultHttpConfig <| do - x <- accessTokenRequest - Req.responseBody x - |> access_token - |> Encoding.encodeUtf8 - |> pure + IO OAuthResponse +githubOauth OAuthArgs {..} code = + accessTokenRequest + /> Req.responseBody + |> Req.runReq Req.defaultHttpConfig where accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) accessTokenRequest = @@ -974,12 +986,15 @@ getAccessToken OAuthArgs {..} code = <> "code" =: code <> "state" =: githubState +-- GitHub OAuth endpoint. For what the parameters mean, see: +-- https://docs.github.com/en/developers/apps/authorizing-oauth-apps githubLoginUrl :: OAuthArgs -> Text githubLoginUrl OAuthArgs {..} = "https://github.com/login/oauth/authorize?" <> encodeParams [ ("client_id", githubClientId), - ("state", githubState) + ("state", githubState), + ("scope", Text.intercalate " " <| Set.toList requiredScopes) ] -- | This view presents a list of repos to select for analysis. @@ -1076,6 +1091,9 @@ instance Lucid.ToHtml Analysis where Lucid.h1_ "Analysis Results" Lucid.h3_ "Total score:" Lucid.p_ <| Lucid.toHtml <| Text.pack <| show score + Lucid.h3_ "Active authors:" + Lucid.p_ <| forM_ activeAuthors <| \author -> do + Lucid.toHtml author Lucid.h3_ <| Lucid.toHtml <| "Total files: " <> tshow totalFiles Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen blackholes <> " blackholes:" Lucid.ul_ <| do @@ -1089,8 +1107,7 @@ instance Lucid.ToHtml Analysis where Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)" slen = tshow <. length --- | Takes a list of active authors and a path to a bare git repo and runs a --- regular analysis +-- | Run a full analysis on a git repo analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> IO Analysis analyze keep askedBy activeAuthors url bareRepo = do commit <- Sha </ Text.strip </ Text.pack </ git ["log", "-n1", "--format=%H"] @@ -1241,30 +1258,16 @@ analyzeGitHub :: IO Analysis analyzeGitHub keep User {..} cfg o r = do let githubAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken - -- I currently have no way of getting active users... getting a list of - -- collaborators on a repo requires authentication for some reason. - -- - -- If the owner is an organization, then we can just use org members, which is - -- public too. And if the auth'ed user is a member of the org, then it pures - -- all of the members, not just public ones, so that will work just fine. - -- - -- In the meantime, what do? Maybe get the number of commits, and consider - -- "active users" as the top 10% in terms of number of commits? Or ask for a - -- list explicitly? If it is a personal repo, then I can assume that the owner - -- is the only regular contributor, at least for now. - -- - -- Right activeUsers <- GitHub.github () (GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll) - Right ghuser <- - GitHub.github - githubAuth - ( GitHub.userInfoForR - <| GitHub.mkName (Proxy :: Proxy GitHub.User) o - ) - -- assume the only active author is the owner, for now - -- TODO: should be userEmail but that requires authentication? - let activeAuthors = [require "user email" <| GitHub.userName ghuser] - eRepo <- GitHub.github githubAuth (GitHub.repositoryR ghOwner ghRepo) - case eRepo of + activeAuthors <- + GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll + |> GitHub.github githubAuth + /> either (panic <. tshow) identity + /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR) + +> Vector.mapM (GitHub.github githubAuth) + /> Vector.map (either (panic <. tshow) GitHub.userEmail) + /> Vector.toList + /> catMaybes + GitHub.github githubAuth (GitHub.repositoryR ghOwner ghRepo) +> \case Left err -> throwIO <| toException err Right repo -> do let GitHub.URL url = GitHub.repoHtmlUrl repo |