diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 261 |
1 files changed, 203 insertions, 58 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index d7a43ea..04ee90e 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -11,6 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -109,7 +110,6 @@ 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 @@ -219,6 +219,10 @@ $(deriveSafeCopy 0 'base ''Commit) newtype URL = URL Text deriving (Eq, Data, Typeable, Ord, Generic, Show) +instance Envy.Var URL where + toVar (URL txt) = str txt + fromVar = Just <. URL <. str + instance Lucid.ToHtml URL where toHtmlRaw = Lucid.toHtml toHtml (URL txt) = Lucid.toHtml txt @@ -295,7 +299,8 @@ instance Indexable Analysis where [ ixFun <| \Analysis {..} -> [analysisId], ixFun <| \Analysis {..} -> [askedBy], ixFun <| \Analysis {..} -> [url], - ixFun <| \Analysis {..} -> [commit] + ixFun <| \Analysis {..} -> [commit], + ixFun <| \Analysis {..} -> [repoVisibility] ] -- | The database. @@ -367,6 +372,11 @@ getAnalysesByAsker user = do Keep {..} <- ask pure <| IxSet.toList <| analyses @= userId user +getAnalysesByUrl :: URL -> Acid.Query Keep [Analysis] +getAnalysesByUrl url = do + Keep {..} <- ask + pure <| IxSet.toList <| analyses @= url + getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis) getAnalysisByUrlAndCommit url sha = do Keep {..} <- ask @@ -383,6 +393,7 @@ $( makeAcidic 'getAnalysisById, 'getAllAnalyses, 'getAnalysesByAsker, + 'getAnalysesByUrl, 'getAnalysisByUrlAndCommit ] ) @@ -490,18 +501,21 @@ startup quiet = do oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep) jwk <- Auth.generateKey + let URL url = homeExample cfg unless quiet <| do - Log.info ["@", "devalloc"] >> Log.br - Log.info ["area", show <| area cfg] >> Log.br - Log.info ["port", show <| port cfg] >> Log.br - Log.info ["depo", Text.pack <| depo cfg] >> Log.br - Log.info ["keep", Text.pack <| keep cfg] >> Log.br + Log.info ["boot", "devalloc"] >> Log.br + Log.info ["boot", "area", show <| area cfg] >> Log.br + Log.info ["boot", "port", show <| port cfg] >> Log.br + Log.info ["boot", "depo", Text.pack <| depo cfg] >> Log.br + Log.info ["boot", "keep", Text.pack <| keep cfg] >> Log.br + Log.info ["boot", "home", "example", url] >> Log.br let jwtCfg = Auth.defaultJWTSettings jwk let cooks = case area cfg of Test -> testCookieSettings Live -> liveCookieSettings let ctx = cooks :. jwtCfg :. EmptyContext let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) + unless quiet <| do Log.info ["boot", "ready"] >> Log.br pure (cfg, app, kp) shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () @@ -570,7 +584,13 @@ data Config = Config -- | The repo depo! Depository of repositories! depo :: FilePath, keep :: FilePath, - area :: Area + area :: Area, + -- | A user token for the GitHub API to be used in testing and when getting + -- the homepage/example analyses. 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 + tokn :: Text, + homeExample :: URL } deriving (Generic, Show) @@ -580,7 +600,9 @@ instance Envy.DefConfig Config where { port = 8005, depo = "_/var/devalloc/depo", keep = "_/var/devalloc/keep", - area = Test + area = Test, + tokn = mempty, + homeExample = URL "https://github.com/github/training-kit" } instance Envy.FromEnv Config @@ -740,7 +762,12 @@ htmlApp :: htmlApp cooks kp cfg jwk oAuthArgs = Paths { home = - pure <. HtmlApp <| Home oAuthArgs, + homeExample cfg + |> GetAnalysesByUrl + |> Acid.query' kp + /> head + /> Home oAuthArgs + /> HtmlApp, login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, githubAuth = \case @@ -748,7 +775,6 @@ htmlApp cooks kp cfg jwk oAuthArgs = Just code -> do OAuthResponse {..} <- githubOauth oAuthArgs code |> liftIO guardScope scope - let token = Encoding.encodeUtf8 access_token let warn :: Text -> Handler a warn msg = Log.warn [msg] @@ -757,10 +783,10 @@ htmlApp cooks kp cfg jwk oAuthArgs = >> throwError err502 {errBody = str msg} user <- GitHub.userInfoCurrentR - |> GitHub.github (GitHub.OAuth token) + |> GitHub.github (userGitHubAuth access_token) |> liftIO +> either (show .> warn) pure - +> upsertGitHubUser kp token + +> upsertGitHubUser kp (Encoding.encodeUtf8 access_token) .> liftIO +> either warn pure Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user @@ -787,7 +813,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = guardAuth >=> \user@User {..} -> GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) + (userGitHubAuth userGitHubToken) (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) |> liftIO +> \case @@ -811,8 +837,14 @@ htmlApp cooks kp cfg jwk oAuthArgs = Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, githubAnalysis = \a owner repo -> guardAuth a - +> \user -> - analyzeGitHub kp user (depo cfg) owner repo + +> \user@User {..} -> + analyzeGitHub + kp + userId + (userGitHubAuth userGitHubToken) + (depo cfg) + owner + repo |> liftIO +> AnalysisDisplay user .> HtmlApp @@ -895,12 +927,25 @@ htmlApp cooks kp cfg jwk oAuthArgs = "li" ? do Clay.padding 0 (px 5) 0 (px 5) + "details" ? do + Clay.display Clay.inline + "summary" ? do + Clay.color "#6c757d" + Clay.display Clay.listItem + Clay.cursor Clay.pointer "#home" ? do - Clay.textAlign Clay.center + "p" ? Clay.textAlign Clay.center "h1" ? do Clay.fontSize (Clay.rem 3) "h1" <> "h2" ? do Clay.textAlign Clay.center + ".example" ? do + Clay.borderStyle Clay.solid + Clay.borderWidth (px 2) + Clay.borderColor "#aaa" + Biz.Look.borderRadiusAll (px 10) + Biz.Look.paddingX (em 2) + Biz.Look.paddingY (em 1) "section" ? do Clay.padding (rem 3) 0 (rem 3) 0 "a#try-button" <> "a#try-button:visited" ? do @@ -928,6 +973,41 @@ htmlApp cooks kp cfg jwk oAuthArgs = Clay.color yellow Clay.backgroundColor black + "#analysis" ? do + Clay.display Clay.grid + Clay.justifyContent Clay.spaceAround + Biz.Look.rowGap (rem 2) + Biz.Look.marginY (rem 1) + Biz.Look.gridTemplateAreas + [ "analysisFor", + "metrics" + ] + + ".metrics" ? do + Clay.gridTemplateColumns [pct 50, pct 50] + Clay.display Clay.grid + Biz.Look.columnGap (em 2) + Biz.Look.rowGap (em 2) + ".score" ? do + Clay.display Clay.flex + Clay.flexDirection Clay.column + ".title" ? do + Clay.fontSize (rem 1.4) + Clay.lineHeight (rem 2.4) + ".percentage" ? do + Clay.display Clay.flex + Clay.alignItems Clay.baseline + ".centum" ? do + Clay.fontSize (rem 1.2) + Clay.lineHeight (rem 1.2) + ".quantity" ? do + Clay.fontSize (rem 3) + Clay.lineHeight (rem 3) + "details" ? do + Biz.Look.gridArea "details-collapsed" + "details[open]" ? do + Biz.Look.gridArea "details" + "#selectRepo" ? do "ul" ? do Clay.listStyleType Clay.none @@ -942,11 +1022,11 @@ htmlApp cooks kp cfg jwk oAuthArgs = -- | The front page pitch. Eventually I'd like to load the content from markdown -- files or some other store of data so I can A/B test. -newtype Home = Home OAuthArgs +data Home = Home OAuthArgs (Maybe Analysis) instance Lucid.ToHtml Home where toHtmlRaw = Lucid.toHtml - toHtml (Home oAuthArgs) = do + toHtml (Home oAuthArgs analysis) = do header Nothing Lucid.main_ [Lucid.id_ "home"] <| do section <| do @@ -954,7 +1034,7 @@ instance Lucid.ToHtml Home where h1 "Know your team." p "Devalloc analyzes your codebase trends, finds patterns in how your developers work, and protects against tech debt." p "Just hook it up to your CI system - Devalloc warns you when it finds a problem." - Lucid.toHtml <| tryButton oAuthArgs + Lucid.toHtml <| tryButton oAuthArgs "Give it a try with GitHub" mempty section <| do h2 "Identify blackholes in your codebase" p @@ -967,6 +1047,14 @@ instance Lucid.ToHtml Home where "Which pieces of code get continually rewritten, taking up valuable dev time? \ \ Find these module hot spots before they become a costly time-sink." section <| do + h2 "See an example analysis" + maybe + ( Lucid.toHtml + <| tryButton oAuthArgs "Run a free complimentary analysis" mempty + ) + (exampleWrapper <. Lucid.toHtml) + analysis + section <| do h2 "Protect against lost knowledge" p "Not everyone can know every part of a codebase. By finding pieces of code that only 1 or 2 people have touched, devalloc identifes siloed knowledge. This allows you to protect against the risk of this knowledge leaving the company if an employee leaves." section <| do @@ -978,7 +1066,11 @@ instance Lucid.ToHtml Home where p "Does your team feel splintered or not cohesive? Which developers work best together? Devalloc analyzes the collaboration patterns between devs and helps you form optimal pairings and teams based on shared code and mindspace." section <| do h1 <| "Ready to get going?" - Lucid.toHtml <| tryButton oAuthArgs + Lucid.toHtml + <| tryButton + oAuthArgs + "Give it a try with GitHub" + "It's free for a limited time!" footer where section = Lucid.section_ @@ -986,6 +1078,7 @@ instance Lucid.ToHtml Home where p = Lucid.p_ <. markdown h1 = Lucid.h1_ h2 = Lucid.h2_ <. markdown + exampleWrapper = Lucid.div_ [Lucid.class_ "example"] data Analyses = Analyses User [Analysis] @@ -1066,6 +1159,12 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) +userGitHubAuth :: + -- | Token from `User.userGitHubToken` or `Config.tokn` + Text -> + GitHub.Auth +userGitHubAuth = GitHub.OAuth <. Encoding.encodeUtf8 + -- | POST to GitHub's OAuth service and get the user's oAuth token. githubOauth :: OAuthArgs -> @@ -1138,13 +1237,13 @@ encodeParams = <. Web.urlEncodeParams -- | Login button for GitHub. -tryButton :: OAuthArgs -> Lucid.Html () -tryButton oAuthArgs = +tryButton :: OAuthArgs -> Text -> Text -> Lucid.Html () +tryButton oAuthArgs title subtitle = Lucid.a_ [Lucid.id_ "try-button", Lucid.href_ <| githubLoginUrl oAuthArgs] <| do - "Give it a try with GitHub" - Lucid.small_ "Free for a limited time, then $99 per month" + Lucid.toHtml title + Lucid.small_ <| Lucid.toHtml subtitle -- | Universal header header :: Monad m => Maybe User -> Lucid.HtmlT m () @@ -1181,33 +1280,71 @@ instance Lucid.ToHtml AnalysisDisplay where toHtmlRaw = Lucid.toHtml toHtml (AnalysisDisplay user anal) = do header <| Just user - Lucid.main_ <| Lucid.toHtml anal + Lucid.main_ <| do + Lucid.h1_ "Analysis Results" + Lucid.toHtml anal footer instance Lucid.ToHtml Analysis where toHtmlRaw = Lucid.toHtml - toHtml = render .> Lucid.toHtml + toHtml Analysis {..} = + Lucid.div_ [Lucid.id_ "analysis"] <| do + Lucid.p_ [Lucid.class_ ".analysisFor"] <| do + "Analysis for " + Lucid.a_ [Lucid.href_ <| (\(URL txt) -> txt) <| url] <| do + Lucid.toHtml url + + Lucid.div_ [Lucid.class_ "metrics"] <| do + score_ <| do + title_ "Total Score" + percentage_ <| do + quantity_ <| Lucid.toHtml <| tshow score + centum_ "/100" + + score_ <| do + title_ "Total Files" + quantity_ <| Lucid.toHtml <| tshow totalFiles + + score_ <| do + title_ "Active authors" + quantity_ <| Lucid.toHtml <| slen activeAuthors + Lucid.details_ <| do + Lucid.summary_ "Details" + Lucid.ul_ <| forM_ activeAuthors <| \author -> do + Lucid.li_ <| Lucid.toHtml author + + score_ <| do + title_ "Blackholes" + quantity_ <| Lucid.toHtml <| slen blackholes + Lucid.details_ <| do + Lucid.summary_ "Details" + Lucid.ul_ <| do + traverse_ (Lucid.toHtml .> Lucid.li_) blackholes + + score_ <| do + title_ "Liabilities" + quantity_ <| Lucid.toHtml <| slen liabilities + Lucid.details_ <| do + Lucid.summary_ "Details" + Lucid.ul_ <| do + traverse_ (Lucid.toHtml .> Lucid.li_) liabilities + + score_ <| do + title_ "Stale files" + quantity_ <| Lucid.toHtml <| slen stale + Lucid.details_ <| do + Lucid.summary_ "Details" + Lucid.ul_ <| do + forM_ stale <| \(path, days) -> + Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)" where - render :: Analysis -> Lucid.Html () - render Analysis {..} = do - Lucid.h1_ "Analysis Results" - Lucid.h3_ "Total score:" - Lucid.p_ <| Lucid.toHtml <| Text.pack <| show score - Lucid.h3_ "Active authors:" - Lucid.ul_ <| forM_ activeAuthors <| \author -> do - Lucid.li_ <| Lucid.toHtml author - Lucid.h3_ <| Lucid.toHtml <| "Total files: " <> tshow totalFiles - Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen blackholes <> " blackholes:" - Lucid.ul_ <| do - traverse_ (Lucid.toHtml .> Lucid.li_) blackholes - Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen liabilities <> " liabilities:" - Lucid.ul_ <| do - traverse_ (Lucid.toHtml .> Lucid.li_) liabilities - Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen stale <> " stale files:" - Lucid.ul_ <| do - forM_ stale <| \(path, days) -> - Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)" slen = tshow <. length + div_ c = Lucid.with Lucid.div_ [Lucid.class_ c] + score_ = div_ "score" + title_ = div_ "title" + quantity_ = div_ "quantity" + centum_ = div_ "centum" + percentage_ = div_ "percentage" -- | Run a full analysis on a git repo analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> Bool -> IO Analysis @@ -1350,9 +1487,12 @@ authorsFor gitDir path = -- | Clones a repo from GitHub and does the analysis. analyzeGitHub :: + GitHub.AuthMethod ghAuth => Acid.AcidState Keep -> -- | The User asking for the analysis, we auth as them - User -> + Id.Id User -> + -- | How to auth with GitHub API + ghAuth -> -- | The repo depo FilePath -> -- | GitHub owner @@ -1360,7 +1500,7 @@ analyzeGitHub :: -- | GitHub repo Text -> IO Analysis -analyzeGitHub keep User {..} depo o r = do +analyzeGitHub keep userId ghAuth depo o r = do activeAuthors <- getPeople /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR) @@ -1375,7 +1515,6 @@ analyzeGitHub keep User {..} depo o r = do bareRepo <- fetchBareRepo depo <. GitHub.getUrl <| GitHub.repoHtmlUrl repo analyze keep userId activeAuthors (URL url) bareRepo (GitHub.repoPrivate repo) where - ghAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r @@ -1412,20 +1551,22 @@ test_analyzeGitHub load = "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 <| Just "user@example.com", userGitHubId = GitHubId 0, - userGitHubToken = tok, + userGitHubToken = tokn c, userSubscription = Free, userId = mempty } - Analysis {..} <- analyzeGitHub k user (depo c) "octocat" "hello-world" + Analysis {..} <- + analyzeGitHub + k + (userId user) + (userGitHubAuth <| userGitHubToken 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 @@ -1447,9 +1588,13 @@ fetchBareRepo depo url = >> pure worktree where fetchOrClone True = - Process.callProcess "git" ["--git-dir", worktree, "fetch", "--quiet", "origin"] + Log.info ["git", "fetch", url] + >> Log.br + >> Process.callProcess "git" ["--git-dir", worktree, "fetch", "--quiet", "origin"] fetchOrClone False = - Process.callProcess "git" ["clone", "--quiet", "--bare", "--", Text.unpack url, worktree] + Log.info ["git", "clone", url] + >> Log.br + >> Process.callProcess "git" ["clone", "--bare", "--quiet", "--", Text.unpack url, worktree] removeScheme :: Text -> FilePath removeScheme u = Text.unpack <. Text.dropWhile (== '/') <. snd <| Text.breakOn "//" u worktree = depo </> removeScheme url <.> "git" |