diff options
| -rw-r--r-- | Biz/Devalloc.hs | 227 |
1 files changed, 190 insertions, 37 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 7cf906a..ec8f870 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -29,16 +29,19 @@ -- : dep warp module Biz.Devalloc ( main, + test, ) where -import Alpha +import Alpha hiding ((<.>)) import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Look import qualified Clay import qualified Control.Exception as Exception import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as List +import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import Data.Vector (Vector) @@ -50,12 +53,14 @@ import qualified Lucid.Servant as Lucid import Network.HTTP.Req ((/:), (=:)) import qualified Network.HTTP.Req as Req import qualified Network.Wai as Wai -import Network.Wai.Application.Static (defaultWebAppSettings) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger (logStdout) import Servant import Servant.HTML.Lucid +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 main :: IO () @@ -67,15 +72,20 @@ main = Exception.bracket startup shutdown run putText "@" putText "devalloc" putText <| "port: " <> (show <| port cfg) + putText <| "depo: " <> (Text.pack <| depo cfg) return (cfg, serve (Proxy @AllPaths) <| paths cfg oAuthArgs) shutdown :: (Config, Application) -> IO () shutdown _ = pure () run :: (Config, Wai.Application) -> IO () run (cfg, app) = Warp.run (port cfg) (logStdout app) +test :: IO () +test = test_analyzeGitHub >> pure () + data Config = Config { port :: Warp.Port, - assets :: FilePath + -- | The repo depo! Depository of repositories! + depo :: FilePath } deriving (Generic, Show) @@ -83,7 +93,7 @@ instance Envy.DefConfig Config where defConfig = Config { port = 8005, - assets = "_/bild/dev/static/devalloc.js" + depo = "_/var/devalloc/depo" } instance Envy.FromEnv Config @@ -136,32 +146,30 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where -- * paths and pages type AllPaths = - Get '[HTML] (HtmlApp Page) + Get '[HTML] (HtmlApp Home) :<|> "auth" :> "github" :> "callback" :> QueryParam "code" Text - :> Get '[HTML] (HtmlApp Page) - :<|> ShowAnalysis - :<|> ("static" :> Raw) + :> Get '[HTML] (HtmlApp SelectRepo) + :<|> GitHubAnalysis :<|> "css" :> "main.css" :> Get '[CSS] Text allPaths :: Proxy AllPaths allPaths = Proxy :: Proxy AllPaths -type ShowAnalysis = "analysis" :> QueryParam "id" Int :> Get '[HTML] (HtmlApp Analysis) +type GitHubAnalysis = + "analysis" :> "github" + :> Capture "user" Text + :> Capture "repo" Text + :> Get '[HTML] (HtmlApp Analysis) paths :: Config -> OAuthArgs -> Server AllPaths -paths Config {assets} oAuthArgs = +paths cfg oAuthArgs = page (Home oAuthArgs) :<|> auth oAuthArgs - :<|> analyze - :<|> static + :<|> (\user repo -> liftIO <| analyzeGitHub cfg user repo >>= pure . HtmlApp) :<|> look where page = pure . HtmlApp - analyze Nothing = panic "could not analyze this repo" - analyze (Just id) = - pure . HtmlApp <| Analysis {targetRepo = GitHub.mkId (Proxy :: Proxy GitHub.Repo) id} - static = serveDirectoryWith <| defaultWebAppSettings assets look = return . toStrict . Clay.render <| do Biz.Look.fuckingStyle @@ -176,18 +184,12 @@ linkTo :: MkLink path Lucid.Attribute linkTo = Lucid.safeHref_ "/" allPaths -data Page - = Home OAuthArgs - | GitHubRepos (Vector GitHub.Repo) +newtype Home = Home OAuthArgs -instance Lucid.ToHtml Page where +instance Lucid.ToHtml Home where toHtmlRaw = Lucid.toHtml - toHtml page = - Lucid.toHtml <| case page of - Home authArgs -> pitch authArgs - GitHubRepos repos -> do - Lucid.h1_ "Select a repo to analyze" - selectRepo repos + toHtml (Home oAuthArgs) = + Lucid.toHtml <| pitch oAuthArgs data OAuthResponse = OAuthResponse { access_token :: Text, @@ -196,26 +198,34 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) -auth :: OAuthArgs -> Maybe Text -> Handler (HtmlApp Page) +newtype SelectRepo = SelectRepo (Vector GitHub.Repo) + +instance Lucid.ToHtml SelectRepo where + toHtmlRaw = Lucid.toHtml + toHtml (SelectRepo repos) = + Lucid.toHtml <| do + Lucid.h1_ "Select a repo to analyze" + selectRepo repos + +auth :: OAuthArgs -> Maybe Text -> Handler (HtmlApp SelectRepo) auth _ Nothing = panic "no code from github api" auth OAuthArgs {..} (Just code) = liftIO <| getAccessToken >>= getRepos >>= \case Left err -> panic <| show err - Right repos -> - pure <| HtmlApp <| GitHubRepos repos + Right repos -> pure . HtmlApp <| SelectRepo repos where getRepos oAuthToken = GitHub.github (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken) (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) getAccessToken = - Req.runReq Req.defaultHttpConfig - <| accessTokenRequest + accessTokenRequest >>= Req.responseBody /> access_token /> return + |> Req.runReq Req.defaultHttpConfig accessTokenRequest = Req.req Req.POST @@ -228,7 +238,15 @@ auth OAuthArgs {..} (Just code) = <> "state" =: githubState data Analysis = Analysis - { targetRepo :: GitHub.Id GitHub.Repo + { bareRepo :: FilePath, + -- | A path with no active contributors + blackholes :: [Text], + -- | A path with < 3 active contributors + liabilities :: [Text], + -- | Files that have not been touched in 6 months + stale :: [Text], + -- | Total score for the repo + score :: Int } instance Lucid.ToHtml Analysis where @@ -236,10 +254,145 @@ instance Lucid.ToHtml Analysis where toHtml = Lucid.toHtml . render where render :: Analysis -> Lucid.Html () - render analysis = + render Analysis {..} = Lucid.div_ <| do Lucid.h1_ "Analysis Results" - Lucid.p_ (Lucid.toHtml <| Text.pack <| show <| targetRepo analysis) + Lucid.h3_ "blackholes:" + Lucid.ul_ <| do + mapM_ (Lucid.li_ . Lucid.toHtml) blackholes + +-- | Takes a list of active authors and a path to a bare git repo and runs a +-- regular analysis +analyze :: [Text] -> FilePath -> IO Analysis +analyze activeAuthors bareRepo = do + tree <- + Process.readProcess + "git" + [ "--git-dir", + bareRepo, + "ls-tree", + "--full-tree", + "--name-only", + "-r", -- recurse into subtrees + "HEAD" + ] + "" + /> String.lines + authors <- mapM (authorsFor bareRepo) tree :: IO [[(Text, Text, Text)]] + let authorMap = + zipWith + ( \path authors_ -> + (path, authors_) + ) + tree + authors :: + [(FilePath, [(Text, Text, Text)])] + + return + Analysis + { blackholes = + [ Text.pack path + | (path, authors_) <- authorMap, + length (List.intersect (map third authors_) activeAuthors) < 1 + ], + liabilities = [], + stale = [], -- actually a map of path->staleness + score = 10, + .. + } + +third :: (a, b, c) -> c +third (_, _, a) = a + +-- | Given a git dir and a path inside the git repo, return a list of tuples +-- with number of commits and author. +authorsFor :: + FilePath -> + FilePath -> + -- | Returns (number of commits, author name, author email) + IO [(Text, Text, Text)] +authorsFor gitDir path = do + -- git shortlog writes to stderr for some reason, so we can't just use + -- Process.readProcess + Process.readProcess + "git" + [ "--git-dir", + gitDir, + "shortlog", + "--numbered", + "--summary", + "--email", + "HEAD", + "--", + path + ] + "" + /> Text.pack + /> Text.lines + /> map (Text.break (== '\t')) + /> map + ( \(commits, author) -> + ( Text.strip commits, + Text.strip <| Text.takeWhile (/= '<') author, + Text.strip <| Text.dropAround (`elem` ['<', '>']) <| Text.dropWhile (/= '<') author + ) + ) + +-- | Clones a repo from GitHub and does the analysis. +analyzeGitHub :: + Config -> + -- | GitHub owner + Text -> + -- | GitHub repo + Text -> + IO Analysis +analyzeGitHub cfg o r = do + -- 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 returns + -- 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 user <- + GitHub.github + () + ( GitHub.userInfoForR + <| GitHub.mkName (Proxy :: Proxy GitHub.User) o + ) + -- assume the only active author is the owner, for now + let activeAuthors = [require "user email" <| GitHub.userName user] + Right repo <- GitHub.github () (GitHub.repositoryR ghOwner ghRepo) + bareRepo <- gitBareClone cfg . GitHub.getUrl <| GitHub.repoHtmlUrl repo + analyze activeAuthors bareRepo + where + ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o + ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r + +test_analyzeGitHub :: IO Analysis +test_analyzeGitHub = analyzeGitHub Envy.defConfig "bsima" "bin" + +-- | Clone the repo to /var/devalloc/repos/<url>, return the full path to the +-- local repo. +gitBareClone :: Config -> Text -> IO FilePath +gitBareClone Config {depo} url = do + worktreeExists <- Directory.doesPathExist worktree + let args = + if worktreeExists + then ["--git-dir", worktree, "fetch", "origin"] + else ["clone", "--bare", "--", Text.unpack url, worktree] + Process.callProcess "git" args + return worktree + where + removeScheme :: Text -> FilePath + removeScheme u = Text.unpack <. Text.dropWhile (== '/') <. snd <| Text.breakOn "//" u + worktree = depo </> removeScheme url <.> "git" -- * parts @@ -257,8 +410,9 @@ selectRepo = Lucid.ul_ . mapM_ render . Vector.toList Lucid.li_ . Lucid.a_ [ linkTo - (Proxy :: Proxy ShowAnalysis) - (Just <| GitHub.untagId <| GitHub.repoId repo) + (Proxy :: Proxy GitHubAnalysis) + (GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo) + (GitHub.untagName <| GitHub.repoName repo) ] . Lucid.toHtml . GitHub.untagName @@ -272,7 +426,6 @@ loginButton OAuthArgs {..} = <> encodeParams [ ("client_id", githubClientId), ("state", githubState) - -- ("redirect_uri", "https://devalloc.io") ] ] "Get Started with GitHub" |