From eaf2f30c93080ad9a00246885c3321baa815f780 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 5 Feb 2021 22:08:51 -0500 Subject: Test analyzing a public repo --- Biz/Devalloc.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 76 insertions(+), 15 deletions(-) (limited to 'Biz') diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index cad343b..93af04f 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -46,6 +46,7 @@ -- : dep tasty-quickcheck -- : dep uuid -- : dep vector +-- : dep vector-algorithms -- : dep warp module Biz.Devalloc ( main, @@ -59,7 +60,7 @@ import qualified Biz.Cli as Cli import qualified Biz.Id as Id import qualified Biz.Log as Log import qualified Biz.Look -import Biz.Test ((@=?), (@?!=)) +import Biz.Test ((@=?), (@?!=), (@?=)) import qualified Biz.Test as Test import qualified CMark as Cmark import qualified CMark.Lucid as Cmark @@ -67,6 +68,7 @@ import Clay (em, pct, px, rem, sec, (?)) import qualified Clay import qualified Clay.Font import qualified Clay.Render as Clay +import qualified Control.Concurrent.Async as Async import qualified Control.Exception as Exception import Control.Monad ((>=>)) import Crypto.JOSE.JWK (JWK) @@ -89,6 +91,7 @@ import qualified Data.Time.Clock as Time import qualified Data.Time.Format as Time import Data.Vector (Vector) import qualified Data.Vector as Vector +-- import qualified Data.Vector.Algorithms.Intro as Vector import qualified GitHub import qualified Lucid import qualified Lucid.Base as Lucid @@ -105,6 +108,7 @@ import qualified Servant.Auth.Server as Auth import qualified Servant.HTML.Lucid as Lucid import Servant.Server.Generic (AsServer) import qualified System.Directory as Directory +import qualified System.Environment as Env import qualified System.Envy as Envy import System.FilePath ((<.>), ()) import qualified System.Process as Process @@ -462,7 +466,8 @@ test = Test.group "Biz.Devalloc" [ test_calculateScore, - Test.with startup shutdown test_upsertGitHubUser + Test.with startup (\t@(c, _, _) -> shutdown t >> tidy c) test_upsertGitHubUser, + Test.with startup (\t@(c, _, _) -> shutdown t >> tidy c) test_analyzeGitHub ] -- * app configurations @@ -715,7 +720,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = githubAnalysis = \a owner repo -> guardAuth a +> \user -> - analyzeGitHub kp user cfg owner repo + analyzeGitHub kp user (depo cfg) owner repo |> liftIO +> AnalysisDisplay user .> HtmlApp @@ -1222,7 +1227,7 @@ lastTouched bareRepo path = do authorsFor :: FilePath -> FilePath -> - -- | pures (number of commits, author name, author email) + -- | returns (number of commits, author name, author email) IO [(Text, Text, Text)] authorsFor gitDir path = Process.readProcess @@ -1253,38 +1258,94 @@ authorsFor gitDir path = -- TODO: break this up into fetchGitHub and analyze functions. analyzeGitHub :: Acid.AcidState Keep -> + -- | The User asking for the analysis, we auth as them User -> - Config -> + -- | The repo depo + FilePath -> -- | GitHub owner Text -> -- | GitHub repo Text -> IO Analysis -analyzeGitHub keep User {..} cfg o r = do - let githubAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken +analyzeGitHub keep User {..} depo o r = do activeAuthors <- GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll - |> GitHub.github githubAuth - /> either (panic <. tshow) identity + |> GitHub.github ghAuth + +> either getTopContributors (identity .> pure) /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR) - +> Vector.mapM (GitHub.github githubAuth) - /> Vector.map (either (panic <. tshow) GitHub.userEmail) /> Vector.toList + +> Async.mapConcurrently (GitHub.github ghAuth) + /> map (either (panic <. tshow) GitHub.userEmail) /> catMaybes - GitHub.github githubAuth (GitHub.repositoryR ghOwner ghRepo) +> \case + GitHub.github ghAuth (GitHub.repositoryR ghOwner ghRepo) +> \case Left err -> throwIO <| toException err Right repo -> do let GitHub.URL url = GitHub.repoHtmlUrl repo - bareRepo <- fetchBareRepo cfg <. GitHub.getUrl <| GitHub.repoHtmlUrl repo + bareRepo <- fetchBareRepo depo <. GitHub.getUrl <| GitHub.repoHtmlUrl repo analyze keep userId activeAuthors (URL url) bareRepo where + ghAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r + getTopContributors :: GitHub.Error -> IO (Vector GitHub.SimpleUser) + getTopContributors = \case + GitHub.ParseError err -> panic err + GitHub.JsonError err -> panic err + GitHub.UserError err -> panic err + GitHub.HTTPError ex -> do + Log.warn ["getTopContributors", tshow ex] + -- TODO: match 'ex' on specific 403 error? + -- TODO: get contributors, return top 10% + -- 'False' means don't include anonymous contributors + GitHub.contributorsR ghOwner ghRepo False GitHub.FetchAll + |> GitHub.github ghAuth + /> either (panic <. tshow) identity + -- TODO: I can't figure out how to use this + -- /> Vector.sortBy + -- ( \case + -- GitHub.KnownContributor n _ _ _ _ _ -> n + -- GitHub.AnonymousContributor n _ -> n + -- ) + /> Vector.take 10 + /> Vector.mapMaybe GitHub.contributorToSimpleUser + +test_analyzeGitHub :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree +test_analyzeGitHub load = + Test.group + "analyzeGitHub" + [ Test.unit "can analyze a public repo (octocat/hello-world)" <| do + (c, _, k) <- load + -- get a token with 'repo' scope from GitHub and set in .envrc.local + -- https://docs.github.com/en/github/authenticating-to-github/creating-a-personal-access-token + tok <- + Env.lookupEnv "GITHUB_USER_TOKEN" + /> maybe (panic "need GITHUB_USER_TOKEN") Text.pack + let user = + User + { userEmail = UserEmail "user@example.com", + userGitHubId = GitHubId 0, + userGitHubToken = tok, + userSubscription = Free, + userId = mempty + } + Analysis {..} <- analyzeGitHub k user (depo c) "octocat" "hello-world" + url @?= URL "https://github.com/octocat/Hello-World" + bareRepo @?= depo c <> "/github.com/octocat/Hello-World.git" + length activeAuthors @?= 2 + activeAuthors @?= ["hire@spacegho.st", "octocat@github.com"] + blackholes @?= ["README"] + liabilities @?= ["README"] + fst /@. If repo already exists, just do a -- @git fetch@. pures the full path to the local repo. -fetchBareRepo :: Config -> Text -> IO FilePath -fetchBareRepo Config {depo} url = +fetchBareRepo :: FilePath -> Text -> IO FilePath +fetchBareRepo depo url = Directory.doesPathExist worktree +> fetchOrClone >> pure worktree -- cgit v1.2.3