Set and guard GitHub API access scope

I need 'repo' scope in order to see private repos. I can't clone and analyze
private repos yet, for that I need to handle ssh keys and such, but at least I
can ensure that requests are being made with the correct scope.

Another addition I should do: check the X-OAuth-Scopes header on every request
to ensure the user does not downgrade my scope after registering the app.

https://docs.github.com/en/developers/apps/scopes-for-oauth-apps#available-scopes

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