diff options
Diffstat (limited to 'Biz/Dragons.hs')
| -rw-r--r-- | Biz/Dragons.hs | 1666 |
1 files changed, 1666 insertions, 0 deletions
diff --git a/Biz/Dragons.hs b/Biz/Dragons.hs new file mode 100644 index 0000000..6cb5fed --- /dev/null +++ b/Biz/Dragons.hs @@ -0,0 +1,1666 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- Developer allocation +-- +-- : out dragons +-- : sys cmark +module Biz.Dragons + ( main, + test, + ) +where + +import Alpha hiding (rem, (<.>)) +import qualified Biz.App as App +import qualified Biz.Auth as Auth +import qualified Biz.Cli as Cli +import Biz.Dragons.Analysis (Analysis (..), Commit (..)) +import qualified Biz.Dragons.Analysis as Analysis +import qualified Biz.Id as Id +import qualified Biz.Log as Log +import qualified Biz.Look +import Biz.Test ((@=?), (@?!=), (@?=)) +import qualified Biz.Test as Test +import qualified CMark as Cmark +import qualified CMark.Lucid as Cmark +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 Crypto.JOSE.JWK (JWK) +import Data.Acid (makeAcidic) +import qualified Data.Acid as Acid +import qualified Data.Acid.Advanced as Acid +import qualified Data.Acid.Local as Acid +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Data (Data) +import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet, (&&&), (@=)) +import qualified Data.IxSet as IxSet +import qualified Data.List as List +import qualified Data.Map as Map +import Data.SafeCopy (base, deriveSafeCopy, extension) +import qualified Data.SafeCopy as SafeCopy +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified Data.Time.Calendar as Time +import qualified Data.Time.Clock 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 +import qualified Lucid.Servant as Lucid +import NeatInterpolation +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Servant +import Servant.API.Generic (ToServantApi, genericApi, toServant, (:-)) +import qualified Servant.Auth as Auth +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.Envy as Envy +import System.FilePath ((<.>), (</>)) +import qualified System.Process as Process +import qualified Web.FormUrlEncoded as Web + +-- * persistent data + +-- This must go first because of template haskell splicing. +-- +-- When changing a persisted type `T`, first copy the type `T == T0`, then make +-- the `SafeCopy.Migrate T` class compile, then make changes to `T`. If you +-- don't, there will be a runtime exception when you try to start the new +-- service. I'm not sure how to guard against this, except maybe run a test +-- deployment by copying a database backup locally, or something: +-- rm -rf _/var/dragons +-- rsync -avz /var/dragons/ _/var + +newtype UserEmail = UserEmail {unUserEmail :: Maybe Text} + deriving (Eq, Ord, Data, Typeable, Generic, Show) + +instance Aeson.ToJSON UserEmail + +instance Aeson.FromJSON UserEmail + +instance Auth.ToJWT UserEmail + +instance Auth.FromJWT UserEmail + +instance Lucid.ToHtml UserEmail where + toHtmlRaw = Lucid.toHtml + toHtml (UserEmail (Just email)) = Lucid.toHtml email + toHtml (UserEmail Nothing) = mempty + +$(deriveSafeCopy 0 'base ''UserEmail) + +-- | In 'GitHub.Data.Definitions' this is '(Id User)', but I don't want the +-- extra complexity of 'Id', so just store the underlying Int +newtype GitHubId = GitHubId {unGitHubId :: Int} + deriving (Eq, Ord, Data, Typeable, Generic, Show) + +instance Aeson.ToJSON GitHubId + +instance Aeson.FromJSON GitHubId + +instance Auth.ToJWT GitHubId + +instance Auth.FromJWT GitHubId + +$(deriveSafeCopy 0 'base ''GitHubId) + +newtype GitHubHandle = GitHubHandle {unGitHubHandle :: Text} + deriving (Eq, Ord, Data, Typeable, Generic, Show) + +instance Aeson.ToJSON GitHubHandle + +instance Aeson.FromJSON GitHubHandle + +$(deriveSafeCopy 0 'base ''GitHubHandle) + +data Subscription = Free | Invoice + deriving (Eq, Data, Typeable, Ord, Generic, Show) + +instance Web.FromForm Subscription where + fromForm f = case Web.parseUnique "user-subscription" f of + Right "Free" -> Right Free + Right "Invoice" -> Right Invoice + Right x -> Left <| "could not parse form value: " <> x + Left x -> Left <| "could not parse form value: " <> x + +instance Aeson.ToJSON Subscription + +instance Aeson.FromJSON Subscription + +instance Auth.ToJWT Subscription + +instance Auth.FromJWT Subscription + +$(deriveSafeCopy 0 'base ''Subscription) + +data User0 = User0 + { userEmail :: UserEmail, + userGitHubId :: GitHubId, + -- | So we can make GitHub API calls on their behalf. + userGitHubToken :: Text, + userSubscription :: Subscription, + userId :: Id.Id User0 + } + deriving (Eq, Data, Typeable, Ord, Generic, Show) + +$(deriveSafeCopy 0 'base ''Id.Id) +$(deriveSafeCopy 0 'base ''User0) + +-- | The main representation of a user. +data User = User + { userEmail :: UserEmail, + userGitHubId :: GitHubId, + userGitHubHandle :: GitHubHandle, + -- | So we can make GitHub API calls on their behalf. + userGitHubToken :: Text, + userSubscription :: Subscription, + userId :: Id.Id User + } + deriving (Eq, Data, Typeable, Ord, Generic, Show) + +instance Aeson.ToJSON User + +instance Aeson.FromJSON User + +instance Auth.ToJWT User + +instance Auth.FromJWT User + +instance SafeCopy.Migrate User where + type MigrateFrom User = User0 + migrate User0 {..} = + User + { userId = Id.mk (Proxy :: Proxy User) <| Id.untag userId, + userGitHubHandle = GitHubHandle "unknown", + .. + } + +$(deriveSafeCopy 1 'extension ''User) + +instance Indexable User where + empty = + ixSet + [ ixFun <| \User {..} -> [userEmail], + ixFun <| \User {..} -> [userGitHubId], + ixFun <| \User {..} -> [userSubscription] + ] + +instance Lucid.ToHtml Commit where + toHtmlRaw = Lucid.toHtml + toHtml (Sha txt) = Lucid.toHtml txt + +$(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 + +$(deriveSafeCopy 0 'base ''URL) + +data Visibility = Public | Private + deriving (Eq, Ord, Generic, Show, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Visibility) + +instance Indexable Analysis where + empty = + ixSet + [ ixFun <| \Analysis {..} -> [commit] + ] + +instance App.HasCss AnalysisAction where + cssFor _ = do + "#analysis > *" ? do + Biz.Look.marginAll (rem 2) + ".score" ? do + Clay.display Clay.grid + Biz.Look.gridTemplateAreas + [ "title quantity details-collapsed", + "preview-chart preview-chart preview-chart", + "details details details" + ] + Clay.alignItems Clay.baseline + Clay.gridTemplateColumns [pct 30, 40, 30] + Biz.Look.gridTemplateRows ["auto"] + ".title" ? do + Biz.Look.gridArea "title" + Clay.fontSize (rem 1.4) + Clay.lineHeight (rem 2.4) + ".percentage" ? do + Biz.Look.gridArea "quantity" + Clay.display Clay.flex + Clay.alignItems Clay.baseline + ".centum" ? do + Clay.fontSize (rem 1.2) + Clay.lineHeight (rem 1.2) + ".quantity" ? do + Biz.Look.gridArea "quantity" + Clay.fontSize (rem 3) + Clay.lineHeight (rem 3) + ".preview-chart" ? do + Biz.Look.gridArea "preview-chart" + "details" ? do + Biz.Look.gridArea "details-collapsed" + Biz.Look.justifySelf <| Clay.JustifyContentValue "self-end" + "details[open]" ? do + Biz.Look.gridArea "details" + Biz.Look.justifySelf <| Clay.JustifyContentValue "auto" + ".preview-chart" ? do + Clay.height (px 2) + Clay.maxWidth (pct 100) + "table" ? do + Biz.Look.marginAll (px 0) + Clay.maxWidth (pct 100) + "#hotspots" ? do + ".preview-chart" ? do + Clay.height (rem 1) + "table" ? do + Clay.height (rem 4) + Clay.marginTop (rem (-3)) + Clay.zIndex (-1) + ".bar" ? do + Clay.height (px 800) + +instance Lucid.ToHtml AnalysisAction where + toHtmlRaw = Lucid.toHtml + toHtml AnalysisAction {..} = + Lucid.div_ [Lucid.id_ "analysis"] <| do + let Analysis {..} = analysis + Lucid.p_ [Lucid.class_ "analysisFor"] <| do + "Analysis for " <> Lucid.toHtml gitDir + + score_ <| do + title_ "Total Score" + percentage_ <| do + quantity_ <| Lucid.toHtml <| tshow score + centum_ "/100" + previewChart <| simpleBar score 100 + Lucid.details_ <| do + Lucid.summary_ "Details" + desc + [text| + Your score is a weighted composite of the below metrics. + What your score means: + - 0-30: very high risk, most of your codebase is unknown or ephemeral + - 30-60: medium-high risk, tasks that involve working on this + codebase will take longer than they should, and we should expect + a few unforeseen bugs + - 60-80: medium-low risk, tasks in this codebase can be expected to + complete in the estimated time, and it probably doesn't have many bugs + - 80+: low risk, your codebase is super clean, give your devs a raise + |] + + 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 + previewChart <| simpleBar (len blackholes) totalFiles + Lucid.details_ <| do + Lucid.summary_ "Details" + desc + [text| + A blackhole has zero active contributors, so none of your current team + members have touched this code. These are very high risk. If there is + a problem with this area of the codebase, it will take longer for your + team to diagnose and fix the root cause; new features that interact + with a blackhole will take longer to deploy. + + **What you can do:** Start a project to ensure these blackholes are + well-defined and documented. If anything is completely unknown, write + tests against that part of the code as it currently stands, then decide + if a rewrite is necessary. + |] + Lucid.ul_ <| do + traverse_ (Lucid.toHtml .> Lucid.li_) blackholes + + score_ <| do + title_ "Liabilities" + quantity_ <| Lucid.toHtml <| slen liabilities + previewChart <| simpleBar (len liabilities) totalFiles + Lucid.details_ <| do + Lucid.summary_ "Details" + desc + [text| + Files with < 3 active contributors. These are at risk of becoming + blackholes if contributors change teams or leave the company. + + **What you can do:** Next time a task involves one of these files, + pull in some team members that haven't worked on this area of the + codebase. + + In general, when assigning tasks, ensure developers are occasionally + working on areas of the codebase that are new to them. Not only will + this decrease your liability, it will also improve your developers + by helping them learn new areas of the code and share techniques. + |] + Lucid.ul_ <| do + traverse_ (Lucid.toHtml .> Lucid.li_) liabilities + + score_ <| do + title_ "Stale files" + quantity_ <| Lucid.toHtml <| tshow <| Map.size stale + previewChart <| simpleBar (Map.size stale) totalFiles + Lucid.details_ <| do + Lucid.summary_ "Details" + desc + [text| + Files that haven't been touched in 6 months. These aren't necessarily + a risk: unchanging files could just be really well-defined and stable. + On the other hand, they could also be places that nobody wants to go + because nobody knows how they work. + + **What you can do:** Run this list by your team and find out who has + knowledge of this area. If nobody does, start a project to + investigate and re-define this part of the codebase, ensuring good + documentation practices along the way. + |] + Lucid.ul_ <| do + -- probably Map.mapWithKey is better? + forM_ (Map.toList stale) <| \(path, days) -> + Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)" + + Lucid.with score_ [Lucid.id_ "hotspots"] <| do + title_ "Hotspots" + quantity_ "" -- TODO + previewChart <| do + Lucid.table_ [Lucid.class_ "charts-css column"] <| do + Lucid.tr_ <| do + forM_ (Map.toList hotspotMap) <| \(_, n) -> do + Lucid.td_ [Lucid.style_ <| size n totalCommits] "" + Lucid.details_ <| do + Lucid.summary_ "Details" + desc + [text| + A hotspot is an over-active code module: developers are continually + reworking this part of the code, wasting time redoing work instead + of progressing. + The flamegraph below plots files by how often they are changed, a + longer horizontal line means more changes. Hover over the bars to + see filenames and change count. + + **What you can do:** After identifying the hotspots, discuss with your + team how to improve the code. Why does the code change so often? Does + it need a more well-defined spec? Does it need a deep refactor? Maybe + part of it can be abstracted into a more solid module? + |] + Lucid.table_ [Lucid.class_ "charts-css bar"] <| do + Lucid.tr_ <| do + forM_ (Map.toList hotspotMap) <| \(path, n) -> do + Lucid.td_ [Lucid.style_ <| size n totalCommits] <| do + Lucid.span_ [Lucid.class_ "tooltip"] + <| Lucid.toHtml + <| path <> ": " <> show n <> " commits" + where + simpleBar :: (Show i, Monad m, Num i) => i -> Integer -> Lucid.HtmlT m () + simpleBar n total = do + Lucid.table_ [Lucid.class_ "charts-css bar stacked multiple"] <| do + Lucid.tr_ <| do + Lucid.td_ [Lucid.style_ <| size n total] "" + <> Lucid.td_ [Lucid.style_ <| size total total] "" + + len = toInteger <. length + 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" + size n total = "--size: calc(" <> show n <> "/" <> show total <> ")" + previewChart = div_ "preview-chart" + desc :: Monad m => Text -> Lucid.HtmlT m () + desc = Lucid.p_ <. Cmark.renderNode [] <. Cmark.commonmarkToNode [] + +-- | Captures an 'Analysis' with metadata used in the webapp to track who asked +-- it and so on. +data AnalysisAction = AnalysisAction + { -- | Monotonic incrementing integer id + analysisId :: Id.Id AnalysisAction, + -- | Who asked for this analysis + askedBy :: Id.Id User, + -- | Where is this coming from? + url :: URL, + -- | Is the URL publically visible? + repoVisibility :: Visibility, + -- | The actual analaysis + analysis :: Analysis + } + deriving (Eq, Ord, Generic, Show, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Analysis) +$(deriveSafeCopy 0 'base ''AnalysisAction) + +instance Indexable AnalysisAction where + empty = + ixSet + [ ixFun <| \AnalysisAction {..} -> [analysisId], + ixFun <| \AnalysisAction {..} -> [askedBy], + ixFun <| \AnalysisAction {..} -> [url], + ixFun <| \AnalysisAction {..} -> [repoVisibility], + ixFun <| \AnalysisAction {..} -> [commit analysis] + ] + +-- | The database. +data Keep = Keep + { users :: IxSet User, + nextUserId :: Id.Id User, + analyses :: IxSet AnalysisAction, + nextAnalysisId :: Id.Id AnalysisAction + } + deriving (Data, Typeable) + +$(deriveSafeCopy 0 'base ''Keep) + +createUser :: User -> Acid.Update Keep User +createUser u = do + keep <- get + let newUser = u {userId = nextUserId keep} :: User + put + <| keep + { users = IxSet.insert newUser (users keep), + nextUserId = succ <| nextUserId keep + } + pure newUser + +updateUser :: User -> Acid.Update Keep User +updateUser u@User {..} = do + keep <- get + put <| keep {users = IxSet.updateIx userGitHubId u (users keep)} + pure u + +getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) +getUserByEmail email = do + Keep {..} <- ask + pure <| IxSet.getOne <| users @= email + +getUserByGitHubId :: GitHubId -> Acid.Query Keep (Maybe User) +getUserByGitHubId id = do + Keep {..} <- ask + pure <| IxSet.getOne <| users @= id + +getUsers :: Acid.Query Keep [User] +getUsers = do + Keep {..} <- ask + pure <| IxSet.toList users + +createAnalysis :: AnalysisAction -> Acid.Update Keep AnalysisAction +createAnalysis a = do + keep@Keep {..} <- get + let newAnalysis = a {analysisId = nextAnalysisId} :: AnalysisAction + put + <| keep + { analyses = IxSet.insert newAnalysis analyses, + nextAnalysisId = succ nextAnalysisId + } + pure newAnalysis + +getAnalysisById :: Id.Id AnalysisAction -> Acid.Query Keep (Maybe AnalysisAction) +getAnalysisById id = do + Keep {..} <- ask + pure <| IxSet.getOne <| analyses @= id + +getAllAnalyses :: Acid.Query Keep [AnalysisAction] +getAllAnalyses = do + Keep {..} <- ask + pure <| IxSet.toList analyses + +getAnalysesByAsker :: User -> Acid.Query Keep [AnalysisAction] +getAnalysesByAsker User {..} = do + Keep {..} <- ask + pure <| IxSet.toList <| analyses @= userId + +getAnalysesByUrl :: URL -> Acid.Query Keep [AnalysisAction] +getAnalysesByUrl url = do + Keep {..} <- ask + pure <| IxSet.toList <| analyses @= url + +getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe AnalysisAction) +getAnalysisByUrlAndCommit url sha = do + Keep {..} <- ask + pure <| IxSet.getOne <| analyses @= url &&& analyses @= sha + +$( makeAcidic + ''Keep + [ 'createUser, + 'updateUser, + 'getUsers, + 'getUserByEmail, + 'getUserByGitHubId, + 'createAnalysis, + 'getAnalysisById, + 'getAllAnalyses, + 'getAnalysesByAsker, + 'getAnalysesByUrl, + 'getAnalysisByUrlAndCommit + ] + ) + +upsertGitHubUser :: + Acid.AcidState Keep -> + ByteString -> + GitHub.User -> + IO (Either Text User) +upsertGitHubUser keep tok ghUser = + ghUser + |> GitHub.userId + |> GitHub.untagId + |> GitHubId + |> GetUserByGitHubId + |> Acid.query keep + +> \case + Just user -> + -- if we already know this user, we need to refresh the token + UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} + |> Acid.update keep + Nothing -> + CreateUser + User + { userEmail = UserEmail <| GitHub.userEmail ghUser, + userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser, + userGitHubHandle = + GitHubHandle <| GitHub.untagName <| GitHub.userLogin ghUser, + userGitHubToken = Encoding.decodeUtf8 tok, + userSubscription = Free, + userId = mempty + } + |> Acid.update keep + /> Right + +test_upsertGitHubUser :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree +test_upsertGitHubUser load = + Test.group + "upsertUser" + [ Test.unit "userId is not mempty" <| do + (_, _, k) <- load + Right User {..} <- upsertGitHubUser k "token" mock_ghUser + userId @?!= mempty, + Test.unit "creates user when email is empty" <| do + (_, _, k) <- load + Right User {..} <- upsertGitHubUser k "token" mock_ghUser {GitHub.userEmail = Nothing} + userEmail @?!= UserEmail Nothing + ] + +mock_ghUser :: GitHub.User +mock_ghUser = + GitHub.User + { GitHub.userId = GitHub.mkId (Proxy :: Proxy GitHub.User) 123, + GitHub.userEmail = Just "user@example.com", + GitHub.userLogin = "user", + GitHub.userName = Nothing, + GitHub.userType = GitHub.OwnerUser, + GitHub.userCreatedAt = + Time.UTCTime (Time.ModifiedJulianDay 1) (Time.secondsToDiffTime 100), + GitHub.userPublicGists = 123, + GitHub.userAvatarUrl = GitHub.URL "http://example.com", + GitHub.userFollowers = 0, + GitHub.userFollowing = 0, + GitHub.userHireable = Nothing, + GitHub.userBlog = Nothing, + GitHub.userBio = Nothing, + GitHub.userPublicRepos = 0, + GitHub.userLocation = Nothing, + GitHub.userCompany = Nothing, + GitHub.userUrl = GitHub.URL "http://example.com", + GitHub.userHtmlUrl = GitHub.URL "http://example.com" + } + +init :: Keep +init = + Keep + { nextAnalysisId = Id.mk (Proxy :: Proxy AnalysisAction) 1, + nextUserId = Id.mk (Proxy :: Proxy User) 1, + users = IxSet.empty, + analyses = IxSet.empty + } + +-- * main and test + +main :: IO () +main = Cli.main <| Cli.Plan help move test tidy + +help :: Cli.Docopt +help = + [Cli.docopt| +dragons + +Usage: + dragons [--quiet] + dragons test +|] + +move :: Cli.Arguments -> IO () +move args = + Exception.bracket + (startup <| args `Cli.has` Cli.longOption "quiet") + shutdown + run + +startup :: Bool -> IO (Config, Application, Acid.AcidState Keep) +startup quiet = do + cfg <- Envy.decodeWithDefaults Envy.defConfig + 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 ["boot", "dragons"] >> 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 () +shutdown (_, _, kp) = Acid.createCheckpointAndClose kp + +tidy :: Config -> IO () +tidy Config {..} = Directory.removeDirectoryRecursive keep + +run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO () +run (cfg, app, _) = Warp.run (port cfg) (Log.wai app) + +liveCookieSettings :: Auth.CookieSettings +liveCookieSettings = + Auth.defaultCookieSettings + { Auth.cookieIsSecure = Auth.Secure, + -- disable XSRF protection because we don't use any javascript + Auth.cookieXsrfSetting = Nothing + } + +testCookieSettings :: Auth.CookieSettings +testCookieSettings = + Auth.defaultCookieSettings + { Auth.cookieIsSecure = Auth.NotSecure, + Auth.cookieXsrfSetting = Nothing + } + +test :: Test.Tree +test = + Test.group + "Biz.Dragons" + [ test_spliceCreds, + Test.with + (startup True) + (\t@(c, _, _) -> shutdown t >> tidy c) + test_upsertGitHubUser, + Test.with + (startup True) + (\t@(c, _, _) -> shutdown t >> tidy c) + test_analyzeGitHub + ] + +-- * app configurations + +data Area = Test | Live + deriving (Generic, Show) + +instance Envy.Var Area where + toVar = show + fromVar "Test" = Just Test + fromVar "Live" = Just Live + fromVar _ = Just Test + +data Config = Config + { port :: Warp.Port, + -- | The repo depo! Depository of repositories! + depo :: FilePath, + keep :: FilePath, + 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, + -- | The example shown on the homepage + homeExample :: URL + } + deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = + Config + { port = 8005, + depo = "_/var/dragons/depo", + keep = "_/var/dragons/keep", + area = Test, + tokn = mempty, + homeExample = URL "https://github.com/github/training-kit" + } + +instance Envy.FromEnv Config + +-- * paths and pages + +-- | Wraps pages in default HTML +instance (Lucid.ToHtml a, App.HasCss a) => Lucid.ToHtml (App.Html a) where + toHtmlRaw = Lucid.toHtml + toHtml (App.Html x) = + Lucid.doctypehtml_ <| do + Lucid.head_ <| do + Lucid.title_ "Dragons.dev :: Know your codebase, know your team." + Lucid.meta_ + [ Lucid.name_ "description", + Lucid.content_ "Know your codebase, know your team." + ] + Lucid.meta_ + [ Lucid.name_ "viewport", + Lucid.content_ "width=device-width, initial-scale=1" + ] + Lucid.meta_ [Lucid.charset_ "utf-8"] + jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js" + -- base styles + style baseStyle + cssRef "//unpkg.com/charts.css/dist/charts.min.css" + -- page styles + style <| App.cssFor x + Lucid.body_ (Lucid.toHtml x) + where + style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.compact [] + jsRef _href = + Lucid.with + (Lucid.script_ mempty) + [ Lucid.makeAttribute "src" _href, + Lucid.makeAttribute "async" mempty, + Lucid.makeAttribute "defer" mempty + ] + cssRef _href = + Lucid.with + (Lucid.link_ mempty) + [ Lucid.makeAttribute "rel" "stylesheet", + Lucid.makeAttribute "href" _href + ] + +-- | All of the routes in the app. +data Paths path = Paths + { home :: + path + :- Get '[Lucid.HTML] (App.Html Home), + login :: + path + :- "login" + :> Verb 'GET 301 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent), + githubAuth :: + path + :- "auth" + :> "github" + :> "callback" + :> QueryParam "code" Text + :> Get '[Lucid.HTML] (Auth.SetCookies (App.Html UserAccount)), + getAccount :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "account" + :> Get '[Lucid.HTML] (App.Html UserAccount), + postAccount :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "account" + :> ReqBody '[FormUrlEncoded] Subscription + :> Post '[Lucid.HTML] (App.Html UserAccount), + selectRepo :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "select-repo" + :> Get '[Lucid.HTML] (App.Html SelectRepo), + getAnalyses :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> Get '[Lucid.HTML] (App.Html Analyses), + getAnalysis :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> Capture "analysisId" (Id.Id AnalysisAction) + :> Get '[Lucid.HTML] (App.Html AnalysisDisplay), + postAnalysis :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> ReqBody '[FormUrlEncoded] SubmitAnalysis + :> Post '[Lucid.HTML] (App.Html AnalysisDisplay), + admin :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "admin" + :> Get '[Lucid.HTML] (App.Html AdminDashboard) + } + deriving (Generic) + +paths :: Proxy (ToServantApi Paths) +paths = genericApi (Proxy :: Proxy Paths) + +guardAuth :: + MonadError ServerError m => + Auth.AuthResult a -> + m a +guardAuth = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "No authentication found"} + Auth.Authenticated user -> pure user + +guardAdmin :: + MonadError ServerError m => + Auth.AuthResult User -> + m User +guardAdmin = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "No authentication found"} + Auth.Authenticated user@User {..} + | userGitHubId == GitHubId 200617 -> pure user + | otherwise -> throwError err401 {errBody = "You're not admin..."} + +requiredScopes :: Set Text +requiredScopes = Set.fromList ["repo"] + +guardScope :: Text -> Servant.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 -> + Acid.AcidState Keep -> + Config -> + JWK -> + Auth.OAuthArgs -> + Paths AsServer +htmlApp cooks kp cfg jwk oAuthArgs = + Paths + { home = + homeExample cfg + |> GetAnalysesByUrl + |> Acid.query' kp + /> head + /> Home oAuthArgs + /> App.Html, + login = + pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, + githubAuth = \case + Nothing -> throwError err503 {errBody = "Bad response from GitHub API"} + Just code -> do + Auth.OAuthResponse {..} <- Auth.githubOauth oAuthArgs code |> liftIO + guardScope scope + let warn :: Text -> Servant.Handler a + warn msg = + Log.warn [msg] + >> Log.br + |> liftIO + >> throwError err502 {errBody = str msg} + user <- + GitHub.userInfoCurrentR + |> GitHub.github (userGitHubAuth access_token) + |> liftIO + +> either (show .> warn) pure + +> upsertGitHubUser kp (Encoding.encodeUtf8 access_token) + .> liftIO + +> either warn pure + Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user + |> liftIO + +> \case + Nothing -> throwError err502 {errBody = "login didn't work"} + -- I think this should redirect to instead of rendering UserAccount + Just applyCookies -> + UserAccount user + |> App.Html + |> applyCookies + |> pure, + getAccount = + guardAuth >=> UserAccount .> App.Html .> pure, + postAccount = \a subscription -> + guardAuth a + +> \user -> + UpdateUser user {userSubscription = subscription} + |> Acid.update' kp + +> UserAccount + .> App.Html + .> pure, + selectRepo = + guardAuth + >=> \user@User {..} -> + GitHub.github + (userGitHubAuth userGitHubToken) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + |> liftIO + +> \case + Left err -> throwError err502 {errBody = str <| (show err :: String)} + Right repos -> pure <. App.Html <| SelectRepo user repos, + getAnalyses = + guardAuth + >=> \user@User {..} -> + GetAnalysesByAsker user + |> Acid.query' kp + +> Analyses user + .> App.Html + .> pure, + getAnalysis = \a analysisId -> + guardAuth a + +> \user -> + GetAnalysisById analysisId + |> Acid.query' kp + +> \case + Nothing -> throwError err404 + Just analysis -> pure <| App.Html <| AnalysisDisplay user analysis, + postAnalysis = \a SubmitAnalysis {..} -> + guardAuth a + +> \user@User {..} -> do + -- we just assume github for now + analyzeGitHub + kp + user + (userGitHubAuth userGitHubToken) + (depo cfg) + owner + repo + |> liftIO + +> AnalysisDisplay user + .> App.Html + .> pure, + admin = + guardAdmin + >=> \user -> do + allUsers <- Acid.query' kp GetUsers + totalAnalyses <- length </ Acid.query' kp GetAllAnalyses + AdminDashboard {..} + |> App.Html + |> pure + } + +baseStyle :: Clay.Css +baseStyle = do + Biz.Look.fuckingStyle + + Biz.Look.whenDark <| do + "body" ? do + Clay.backgroundColor black + "a:link" <> "a:visited" ? do + Clay.textDecorationColor Clay.white + Clay.color Clay.white + "a:hover" ? do + Clay.textDecorationColor yellow + "select" <> "button" <> "input" ? do + Clay.backgroundColor black + Clay.color Clay.white + + Biz.Look.whenLight <| do + "body" ? do + Clay.color black + "a:link" <> "a:visited" ? do + Clay.textDecorationColor black + Clay.color black + "a:hover" ? do + Clay.textDecorationColor yellow + "select" <> "button" <> "input" ? do + Clay.backgroundColor Clay.white + Clay.color black + + "body" ? Biz.Look.fontStack + "header" ? do + Clay.maxWidth (pct 100) + "footer" ? do + Clay.fontStyle Clay.italic + Clay.fontSize (rem 0.8) + Clay.marginTop (em 6) + Clay.marginBottom (em 6) + "a" <> "input.link" ? do + Clay.transition "all" (sec 0.2) Clay.ease 0 + Clay.transitionProperties + [ "text-decoration-color", + "text-decoration-thickness", + "text-decoration-width" + ] + Clay.textDecoration Clay.underline + Biz.Look.textDecorationThickness (em 0.1) + Biz.Look.textDecorationWidth (em 0.1) + "a:hover" <> "input.link" ? do + Clay.textDecorationColor yellow + Clay.textDecoration Clay.underline + Biz.Look.textDecorationThickness (em 0.2) + Biz.Look.textDecorationWidth (em 0.2) + + "select" <> "button" <> "input" ? do + Biz.Look.paddingAll (em 0.5) + Biz.Look.marginX (em 0.5) + Clay.borderColor yellow + Clay.borderStyle Clay.solid + + -- for making POST requests with a form disguised as a link + "input.link" ? do + Clay.cursor Clay.pointer + Clay.borderWidth 0 + Clay.fontSize (rem 1) + Biz.Look.marginAll (px 0) + Biz.Look.paddingAll (px 0) + + ".badge" ? do + Clay.borderWidth (px 1) + Clay.borderColor Clay.grey + Clay.borderStyle Clay.solid + Biz.Look.borderRadiusAll (rem 2) + Clay.fontSize (rem 0.8) + Biz.Look.marginAll (rem 1) + Biz.Look.paddingX (rem 0.5) + Biz.Look.paddingY (rem 0.25) + + "label" ? do + Clay.display Clay.inlineBlock + Clay.width (px 100) + + "nav" ? do + Clay.display Clay.flex + Clay.justifyContent Clay.spaceBetween + "a" ? do + Clay.padding (em 1) (em 1) (em 1) (em 1) + Clay.display Clay.block + "ul" ? do + Clay.display Clay.flex + Clay.justifyContent Clay.flexEnd + Clay.listStyleType Clay.none + Clay.margin (Clay.px 0) 0 0 0 + "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 + +yellow, black :: Clay.Color +yellow = "#ffe000" +black = "#121212" + +data AdminDashboard = AdminDashboard + { user :: User, + allUsers :: [User], + totalAnalyses :: Int + } + +instance App.HasCss AdminDashboard where + cssFor _ = mempty + +instance Lucid.ToHtml AdminDashboard where + toHtmlRaw = Lucid.toHtml + toHtml AdminDashboard {..} = do + header <| Just user + Lucid.main_ <| do + Lucid.section_ <| do + Lucid.h2_ <| Lucid.toHtml <| "Total Analyses: " <> tshow totalAnalyses + Lucid.section_ <| do + Lucid.h2_ "Post analysis" + let action = linkAction_ "/" <| fieldLink postAnalysis + Lucid.form_ [action, Lucid.method_ "post"] <| do + Lucid.input_ [Lucid.type_ "text", Lucid.name_ "owner"] + Lucid.input_ [Lucid.type_ "text", Lucid.name_ "repo"] + Lucid.input_ + [ Lucid.type_ "submit" + ] + + Lucid.section_ <| do + Lucid.h2_ "All Users" + Lucid.ul_ + <| forM_ allUsers + <| \User {..} -> do + Lucid.li_ <| do + Lucid.toHtml <| unGitHubHandle userGitHubHandle + + footer + +-- | 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. +data Home = Home Auth.OAuthArgs (Maybe AnalysisAction) + +instance App.HasCss Home where + cssFor (Home _ mAnalysis) = do + "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) + maybe mempty App.cssFor mAnalysis + "section" ? do + Clay.padding (rem 3) 0 (rem 3) 0 + "a#try-button" <> "a#try-button:visited" ? do + Clay.transition "all" (sec 0.2) Clay.ease 0 + Clay.transitionProperties + ["color", "background-color", "border-color"] + Clay.padding (em 0.5) (em 1) (em 0.5) (em 1) + Clay.display Clay.flex + Clay.flexDirection Clay.column + Clay.margin (em 3) Clay.auto 0 Clay.auto + Clay.width (px 250) + Clay.borderWidth (px 1) + Clay.borderStyle Clay.solid + Clay.borderColor black + Clay.backgroundColor yellow + Clay.color black + Clay.textDecoration Clay.none + Clay.justifyContent Clay.center + Clay.alignItems Clay.center + Clay.fontWeight Clay.bold + "small" ? do + Clay.fontSize (px 10) + "a#try-button:hover" ? do + Clay.borderColor yellow + Clay.color yellow + Clay.backgroundColor black + +instance Lucid.ToHtml Home where + toHtmlRaw = Lucid.toHtml + toHtml (Home oAuthArgs analysis) = do + header Nothing + Lucid.main_ <| do + section <| do + h1 "Know your codebase." + h1 "Know your team." + p "Dragons 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 - Dragons warns you when it finds a problem." + Lucid.toHtml <| tryButton oAuthArgs "Give it a try with GitHub" mempty + section <| do + h2 "Identify blackholes in your codebase" + p + "What if none of your active employees have touched some part of the codebase? \ + \ This happens too often with legacy code, and then it turns into a huge source of tech debt. \ + \ Dragons finds these \"blackholes\" and warns you about them so you can be proactive in eliminating tech debt." + section <| do + h2 "Find developer hotspots" + p + "Which pieces of code get continually rewritten, taking up valuable dev time? \ + \ Find these module hotspots 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, dragons identifes siloed knowledge. This allows you to protect against the risk of this knowledge leaving the company if an employee leaves." + section <| do + h2 "Don't just measure code coverage - also know your dev coverage" + p "No matter how smart your employees are, if you are under- or over-utilizing your developers then you will never get optimal performance from your team." + p "Know how your devs work best: which ones have depth of knowledge, and which ones have breadth?" + section <| do + h2 "See how your teams *actually* organize themselves with cluster analysis" + p "Does your team feel splintered or not cohesive? Which developers work best together? Dragons 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 + "Give it a try with GitHub" + "It's free for a limited time!" + footer + where + section = Lucid.section_ + markdown = Cmark.renderNode [] <. Cmark.commonmarkToNode [] + p = Lucid.p_ <. markdown + h1 = Lucid.h1_ + h2 = Lucid.h2_ <. markdown + exampleWrapper = Lucid.div_ [Lucid.class_ "example"] + +data Analyses = Analyses User [AnalysisAction] + +instance App.HasCss Analyses where + cssFor _ = mempty + +instance Lucid.ToHtml Analyses where + toHtmlRaw = Lucid.toHtml + toHtml (Analyses user@User {..} analyses) = do + header <| Just user + Lucid.main_ <| do + Lucid.section_ <| do + Lucid.h2_ "Your Analyses" + Lucid.p_ + <| Lucid.a_ + [Lucid.linkHref_ "/" <| fieldLink selectRepo] + "Analyze one of your repos" + Lucid.div_ <| do + forM_ analyses <| \AnalysisAction {..} -> + Lucid.a_ + [ href analysisId, + css <| Biz.Look.marginAll (em 1) + <> Clay.textDecoration Clay.none + ] + <| do + Lucid.div_ <| Lucid.toHtml url + Lucid.div_ [css <| Clay.fontSizeCustom Clay.Font.small] + <| Lucid.toHtml (commit analysis) + footer + where + href aid = Lucid.linkHref_ "/" <| fieldLink getAnalysis aid + +newtype UserAccount = UserAccount User + +instance App.HasCss UserAccount where + cssFor (UserAccount _) = mempty + +instance Lucid.ToHtml Subscription where + toHtmlRaw = Lucid.toHtml + toHtml Free = "Free" + toHtml Invoice = "Invoice me" + +linkAction_ :: ToHttpApiData a => Text -> a -> Lucid.Attribute +linkAction_ baseUrl = Lucid.action_ <. (baseUrl <>) <. Servant.toUrlPiece + +instance Lucid.ToHtml UserAccount where + toHtmlRaw = Lucid.toHtml + toHtml (UserAccount user@User {..}) = do + header <| Just user + Lucid.main_ <| do + Lucid.h1_ "Welcome!" + Lucid.section_ <| do + Lucid.h2_ "Subscription" + let action = linkAction_ "/" <| fieldLink postAccount + Lucid.form_ [action, Lucid.method_ "post"] <| do + let name = "user-subscription" + Lucid.label_ [Lucid.for_ name] "Your plan:" + Lucid.select_ [Lucid.name_ name] <| do + Lucid.option_ + (Lucid.value_ "Free" : isSelected Free) + <| Lucid.toHtml Free + Lucid.option_ + (Lucid.value_ "Invoice" : isSelected Invoice) + <| Lucid.toHtml Invoice + Lucid.input_ [Lucid.type_ "submit", Lucid.value_ "Save"] + when (userSubscription == Invoice) <| do + Lucid.p_ "Thanks! You will receive an invoice by email every month." + footer + where + isSelected sel = + if userSubscription == sel + then [Lucid.selected_ <| tshow sel] + else mempty + +css :: Clay.Css -> Lucid.Attribute +css = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] + +userGitHubAuth :: + -- | Token from `User.userGitHubToken` or `Config.tokn` + Text -> + GitHub.Auth +userGitHubAuth = GitHub.OAuth <. Encoding.encodeUtf8 + +-- GitHub OAuth endpoint. For what the parameters mean, see: +-- https://docs.github.com/en/developers/apps/authorizing-oauth-apps +githubLoginUrl :: Auth.OAuthArgs -> Text +githubLoginUrl Auth.OAuthArgs {..} = + "https://github.com/login/oauth/authorize?" + <> encodeParams + [ ("client_id", clientId), + ("state", clientState), + ("scope", Text.intercalate " " <| Set.toList requiredScopes) + ] + +-- | This view presents a list of repos to select for analysis. +data SelectRepo = SelectRepo User (Vector GitHub.Repo) + +instance App.HasCss SelectRepo where + cssFor (SelectRepo _ _) = do + "ul" ? do + Clay.listStyleType Clay.none + Clay.margin (px 0) 0 0 0 + Clay.padding (px 0) 0 0 0 + "li" ? do + Clay.borderBottomWidth (px 1) + Clay.borderBottomColor "#999" + Clay.borderBottomStyle Clay.solid + Clay.padding (em 1.5) 0 (em 1.5) 0 + ".link" ? do + Clay.fontSize (em 1.17) + +instance Lucid.ToHtml SelectRepo where + toHtmlRaw = Lucid.toHtml + toHtml (SelectRepo user repos) = do + header <| Just user + Lucid.main_ <| do + Lucid.h2_ "Select a repo to analyze" + Lucid.ul_ <| Lucid.toHtml <| traverse_ displayRepo (Vector.toList repos) + footer + where + displayRepo :: GitHub.Repo -> Lucid.Html () + displayRepo repo = + Lucid.li_ <| do + let action = linkAction_ "/" <| fieldLink postAnalysis + Lucid.form_ [action, Lucid.method_ "post"] <| do + Lucid.input_ + [ Lucid.type_ "submit", + Lucid.class_ "link", + Lucid.value_ <| GitHub.untagName + <| GitHub.repoName repo + ] + Lucid.input_ + [ Lucid.type_ "hidden", + Lucid.name_ "owner", + Lucid.value_ <| GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo + ] + Lucid.input_ + [ Lucid.type_ "hidden", + Lucid.name_ "repo", + Lucid.value_ <| GitHub.untagName <| GitHub.repoName repo + ] + when (GitHub.repoPrivate repo) <| privateBadge + maybe mempty (Lucid.p_ <. Lucid.toHtml) (GitHub.repoDescription repo) + privateBadge = Lucid.span_ [Lucid.class_ "badge"] "Private" + +-- * parts + +-- | Utility for turning a list of tuples into a URL querystring. +encodeParams :: [(Text, Text)] -> Text +encodeParams = + Encoding.decodeUtf8 + <. LBS.toStrict + <. Web.urlEncodeParams + +-- | Login button for GitHub. +tryButton :: Auth.OAuthArgs -> Text -> Text -> Lucid.Html () +tryButton oAuthArgs title subtitle = + Lucid.a_ + [Lucid.id_ "try-button", Lucid.href_ <| githubLoginUrl oAuthArgs] + <| do + Lucid.toHtml title + Lucid.small_ <| Lucid.toHtml subtitle + +-- | Universal header +header :: Monad m => Maybe User -> Lucid.HtmlT m () +header muser = + Lucid.header_ <| do + Lucid.nav_ <| do + a "Dragons" <| fieldLink home + case muser of + Nothing -> + Lucid.ul_ <| do + li "Login" <| fieldLink login + Just _ -> + Lucid.ul_ <| do + li "Analyses" <| fieldLink getAnalyses + li "Account" <| fieldLink getAccount + where + a txt href = + Lucid.a_ [Lucid.linkHref_ "/" href] txt + li txt href = Lucid.li_ <| a txt href + +-- | Universal footer +footer :: Monad m => Lucid.HtmlT m () +footer = + Lucid.footer_ <| do + Lucid.p_ <| Lucid.i_ "Copyright ©2020-2021 Dragons.dev" + +-- * analysis + +data SubmitAnalysis = SubmitAnalysis + { owner :: Text, + repo :: Text + } + deriving (Eq, Show, Generic) + +instance Web.FromForm SubmitAnalysis + +-- | I need more information than just 'Analysis' has to render a full, useful +-- web page, hence this type. +data AnalysisDisplay = AnalysisDisplay User AnalysisAction + +instance App.HasCss AnalysisDisplay where + cssFor (AnalysisDisplay _ analysis) = App.cssFor analysis + +instance Lucid.ToHtml AnalysisDisplay where + toHtmlRaw = Lucid.toHtml + toHtml (AnalysisDisplay user anal) = do + header <| Just user + Lucid.main_ <| do + Lucid.h1_ "Analysis Results" + Lucid.toHtml anal + footer + +-- | Run a full analysis on a git repo +analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> Bool -> IO AnalysisAction +analyze keep askedBy activeAuthors url bareRepo repoPrivate = do + commit <- Sha </ Text.strip </ Text.pack </ Analysis.git bareRepo ["log", "-n1", "--format=%H"] + Acid.query keep (GetAnalysisByUrlAndCommit url commit) +> \case + Just analysis -> pure analysis + Nothing -> + Analysis.run activeAuthors bareRepo + /> ( \a -> + AnalysisAction + { analysisId = mempty, + analysis = a, + repoVisibility = repoPrivate ?: (Private, Public), + .. + } + ) + /> CreateAnalysis + +> Acid.update keep + +spliceCreds :: User -> Text -> Text +spliceCreds User {..} url = + scheme <> "//" <> unGitHubHandle userGitHubHandle <> ":" <> userGitHubToken <> "@" <> Text.drop 2 rest + where + (scheme, rest) = Text.breakOn "//" url + +test_spliceCreds :: Test.Tree +test_spliceCreds = + Test.group + "spliceCreds" + [ Test.unit "simple happy path" + <| "https://user:token@github.com/owner/repo" + @=? spliceCreds mock_user "https://github.com/owner/repo" + ] + where + mock_user = + User + { userEmail = UserEmail <| Just "user@example.com", + userGitHubHandle = GitHubHandle "user", + userGitHubId = GitHubId 0, + userGitHubToken = "token", + userSubscription = Free, + userId = mempty + } + +-- | 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 -> + -- | How to auth with GitHub API + ghAuth -> + -- | The repo depo + FilePath -> + -- | GitHub owner + Text -> + -- | GitHub repo + Text -> + IO AnalysisAction +analyzeGitHub keep user@User {userId} ghAuth depo o r = do + activeAuthors <- + getPeople + /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR) + /> Vector.toList + +> Async.mapConcurrently (GitHub.github ghAuth) + /> map (either (const Nothing) GitHub.userEmail) + /> catMaybes + /> List.nub + GitHub.github ghAuth (GitHub.repositoryR ghOwner ghRepo) +> \case + Left err -> throwIO <| toException err + Right repo -> do + let canonicalUrl = GitHub.getUrl <| GitHub.repoHtmlUrl repo + let cloningUrl = if GitHub.repoPrivate repo then spliceCreds user canonicalUrl else canonicalUrl + let worktree = depo </> removeScheme canonicalUrl <.> "git" + bareRepo <- fetchBareRepo cloningUrl worktree + analyze keep userId activeAuthors (URL canonicalUrl) bareRepo (GitHub.repoPrivate repo) + where + ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o + ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r + + getPeople :: IO (Vector GitHub.SimpleUser) + getPeople = + Async.runConcurrently <| (Vector.++) + </ Concurrently getCollaborators + <*> Concurrently getTopContributors + + getCollaborators :: IO (Vector GitHub.SimpleUser) + getCollaborators = + GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll + |> GitHub.github ghAuth + /> either mempty identity + + getTopContributors :: IO (Vector GitHub.SimpleUser) + getTopContributors = + -- 'False' means don't include anonymous contributors + GitHub.contributorsR ghOwner ghRepo False GitHub.FetchAll + |> GitHub.github ghAuth + /> either mempty identity + -- TODO: return top 10%; 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 + let user@User {userGitHubToken} = mock_user c + AnalysisAction {..} <- + analyzeGitHub + k + user + (userGitHubAuth userGitHubToken) + (depo c) + "octocat" + "hello-world" + url @?= URL "https://github.com/octocat/Hello-World" + -- bareRepo @?= depo c <> "/github.com/octocat/Hello-World.git" + let Analysis {..} = analysis + length activeAuthors @?= 2 + activeAuthors @?= ["hire@spacegho.st", "octocat@github.com"] + blackholes @?= ["README"] + liabilities @?= ["README"] + Map.member "README" stale @?= True + score @?= 20 + totalFiles @?= 1 + commit @?= Sha "7fd1a60b01f91b314f59955a4e4d4e80d8edf11d", + Test.unit "can analyze a private repo (bsima/biz)" <| do + (c, _, k) <- load + let user@User {userGitHubToken} = mock_user c + AnalysisAction {..} <- + analyzeGitHub + k + user + (userGitHubAuth userGitHubToken) + (depo c) + "bsima" + "biz" + url @?= URL "https://github.com/bsima/biz" + -- bareRepo @?= depo c <> "/github.com/bsima/biz.git" + ] + where + mock_user c = + User + { userEmail = UserEmail <| Just "ben@bsima.me", + userGitHubHandle = GitHubHandle "bsima", + userGitHubId = GitHubId 0, + userGitHubToken = tokn c, + userSubscription = Free, + userId = mempty + } + +-- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a +-- @git fetch@. pures the full path to the local repo. +fetchBareRepo :: Text -> String -> IO FilePath +fetchBareRepo url worktree = + Directory.doesPathExist worktree + +> fetchOrClone + >> pure worktree + where + fetchOrClone True = + Log.info ["git", "fetch", url] + >> Log.br + >> Process.callProcess "git" ["--git-dir", worktree, "fetch", "--quiet", "origin"] + fetchOrClone False = + 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 |