diff --git a/BUILD.bazel b/BUILD.bazel index 9aa1d59..4800295 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -66,6 +66,7 @@ haskell_library( hazel_library("bytestring"), hazel_library("containers"), hazel_library("cryptohash"), + hazel_library("directory"), hazel_library("exceptions"), hazel_library("github"), hazel_library("html"), diff --git a/github-tools.cabal b/github-tools.cabal index 89af81c..38342bc 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -21,6 +21,7 @@ library exposed-modules: GitHub.Tools.AutoMerge GitHub.Tools.Changelogs + GitHub.Tools.NetworkGraph GitHub.Tools.PullRequestInfo GitHub.Tools.PullStatus GitHub.Tools.Requests @@ -130,6 +131,7 @@ library , containers , cryptohash , exceptions + , directory , github >= 0.25 && <= 0.27 , html , http-client >= 0.4.30 diff --git a/src/GitHub/Tools/AutoMerge.hs b/src/GitHub/Tools/AutoMerge.hs index b607dcf..7c31563 100644 --- a/src/GitHub/Tools/AutoMerge.hs +++ b/src/GitHub/Tools/AutoMerge.hs @@ -13,7 +13,7 @@ import qualified Data.Vector as V import qualified GitHub import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import System.Posix.Directory (changeWorkingDirectory) +import System.Directory (setCurrentDirectory) import System.Process (callProcess) import GitHub.Tools.PullRequestInfo (PullRequestInfo (..)) @@ -53,7 +53,7 @@ autoMerge token ownerName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin , "https://github.com/" <> Text.unpack prUser <> "/" <> Text.unpack prOrigin , clonePath ] - changeWorkingDirectory clonePath + setCurrentDirectory clonePath callProcess "git" [ "remote", "add", "upstream" @@ -64,7 +64,7 @@ autoMerge token ownerName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin -- Go back to a directory that will definitely exist even when next time -- we "rm -rf" the git repo cloned above. - changeWorkingDirectory workDir + setCurrentDirectory workDir mergeable :: PullRequestInfo -> Bool diff --git a/src/GitHub/Tools/NetworkGraph.hs b/src/GitHub/Tools/NetworkGraph.hs new file mode 100644 index 0000000..3d76424 --- /dev/null +++ b/src/GitHub/Tools/NetworkGraph.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE ViewPatterns #-} +module GitHub.Tools.NetworkGraph + ( getNetworkGraph + ) where + +import Control.Arrow ((&&&)) +import Control.Monad (unless, void) +import Data.Char (ord) +import qualified Data.List as List +import qualified Data.List.Split as List +--import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as V +import qualified GitHub as GH +import qualified GitHub.Data.Name as GH +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import System.Directory (doesDirectoryExist, + setCurrentDirectory) +import System.IO (hPutStrLn, stderr) +import System.Process (callProcess, readProcess) +import qualified Text.ParserCombinators.ReadP as R + +import GitHub.Tools.Requests + + +type RepoRef = (GH.Name GH.Owner, GH.Name GH.Repo) + + +data Ref = Ref String String [String] [String] + deriving Show + +instance Read Ref where + readsPrec _ = R.readP_to_S $ Ref + <$> R.count 25 R.get + <*> (R.char ' ' >> readRef) + <*> R.many1 (R.char ' ' >> readRef) + <*> readNames + where + readRef = R.count 40 . R.choice . map R.char $ ['0'..'9'] ++ ['a'..'f'] + readNames = do + void $ R.string " (" + res <- R.sepBy (R.munch (not . (`elem` [',',')']))) (R.string ", ") + void $ R.char ')' + return res + + +toDot :: Ref -> [String] +toDot (Ref _ _ _ []) = [] +toDot (Ref date (take 6 -> ref) (map (take 6) -> parents) names@(mainName:_)) = + " \"" <> ref <> "\" [ " <> List.intercalate " " attrs <> " ]" + : edges + where + edges = map (\parent -> " \"" <> ref <> "\" -> \"" <> parent <> "\"") parents + truncateName name + | length name > 25 = take 22 name <> "..." + | otherwise = name + + attrs = + [ "label = \"" <> List.intercalate "\\n" (take 10 date : map truncateName names) <> "\"" + , "tooltip = \"" <> List.intercalate "\\n" names <> "\"" + , "fillcolor = \"" <> nameColor <> "\"" + ] + + palette = + [ "#ccff00" + , "#ccffff" + , "#ffff66" + , "#cccc00" + , "#ccccff" + , "#ffccff" + , "#ffcccc" + , "#ffcc33" + , "#cc9933" + , "#cc9999" + , "#cc99ff" + , "#ff99ff" + , "#ff9933" + , "#cc6633" + , "#66cc99" + , "#99cc33" + , "#009900" + ] + + nameColor = + case fst $ List.break (`elem` [':','/']) mainName of + "HEAD -> master" -> "red" + "tag" -> "#cccccc" + author -> palette !! ((sum . map ord $ author) `mod` (length palette)) + + +minDate :: String +minDate = "2022-01" + + +urlBase :: String +urlBase = "https://username:password@github.com/" + + +denyList :: [GH.Name GH.Owner] +denyList = + [ "4a256b6b3e7t3e8b7t9q7t" + , "activistWannabe2" + , "cha63506" + , "chai3819" + , "CNXTEoEorg" + , "DannaScully" + , "din982" + , "fireeyeusa" + , "grubern" + , "haiiev" + , "innnzzz6" + , "jamiepg1" + , "josephyzhou" + , "jrtorres42" + , "kigu" + , "lucasborer1" + , "lukw00" + , "makianditro1" + , "mehulsbhatt" + , "mk21" + , "nfkd" + , "noikiy" + , "ProgrammerAndHacker" + , "receptpr9001" + , "shaunstanislaus" + , "sometwo" + , "SunelContus" + , "treejames" + , "xeon2007" + , "xuecai" + ] + + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do + cond <- condM + unless cond acc + + +getNetworkGraph + :: Maybe GH.Auth + -> [RepoRef] + -> IO String +getNetworkGraph _ [] = return [] +getNetworkGraph auth repos@(rootRepo:seedRepos) = do + -- Initialise HTTP manager so we can benefit from keep-alive connections. + mgr <- newManager tlsManagerSettings + + unlessM (doesDirectoryExist clonePath) $ do + hPutStrLn stderr "Cloning initial repo" + clone rootRepo + setCurrentDirectory clonePath + + hPutStrLn stderr $ "Adding remotes for " <> show (length seedRepos) <> " seed repos" + mapM_ addRemote seedRepos + + hPutStrLn stderr $ "Querying GitHub for forks..." + forks <- V.filter (not . (`elem` denyList) . fst) . V.concat <$> mapM (forksFor mgr) repos + + hPutStrLn stderr $ "Adding remotes for " <> show (V.length forks) <> " forks" + V.mapM_ addRemote forks + + setCurrentDirectory clonePath + hPutStrLn stderr "Fetching all remotes" + fetchAll + dotLines <- concatMap toDot <$> gitLog + + return . unlines . concat $ + [ [ "strict digraph \"" <> repoPath rootRepo <> "\" {" + , " graph [splines=ortho, rankdir=LR]" + , " node [shape=box width=2.5 margin=\"0,0.02\" style=filled]" + , " edge [dir=back]" + ] + , dotLines + , ["}"] + ] + + where + repoPath (GH.N (Text.unpack -> owner), GH.N (Text.unpack -> repo)) = + owner <> "/" <> repo + + clonePath = "/tmp/hub-graph/" <> (Text.unpack . GH.untagName . snd $ rootRepo) + + clone repo = + callProcess "git" ["clone", urlBase <> repoPath repo, clonePath] + + addRemote repo@(GH.N (Text.unpack -> owner), _) = + callProcess "git" ["remote", "add", owner, urlBase <> repoPath repo] + + fetchAll = + -- callProcess "git" ["fetch", "--all", "--prune", "--jobs=10"] + return () + + gitLog = + map read + . filter (>= minDate) + . List.splitOn "\n" + <$> readProcess "git" ["log", "--all", "--format=%cI %H %P%d", "--topo-order", "--simplify-by-decoration"] "" + + forksFor :: Manager -> RepoRef -> IO (V.Vector RepoRef) + forksFor mgr (owner, repo) = + V.map (GH.simpleOwnerLogin . GH.repoOwner &&& GH.repoName) <$> request auth mgr (GH.forksForR owner repo GH.FetchAll) diff --git a/src/GitHub/Types/Base/Release.hs b/src/GitHub/Types/Base/Release.hs index 08a0805..6e423ef 100644 --- a/src/GitHub/Types/Base/Release.hs +++ b/src/GitHub/Types/Base/Release.hs @@ -23,6 +23,7 @@ data Release = Release , releaseDraft :: Bool , releaseHtmlUrl :: Text , releaseId :: Int + , releaseMentionsCount :: Int , releaseName :: Text , releaseNodeId :: Text , releasePrerelease :: Bool @@ -32,7 +33,7 @@ data Release = Release , releaseTargetCommitish :: Text , releaseUploadUrl :: Text , releaseUrl :: Text - , releaseZipballUrl :: Text + , releaseZipballUrl :: Maybe Text } deriving (Eq, Show, Read) @@ -46,6 +47,7 @@ instance FromJSON Release where <*> x .: "draft" <*> x .: "html_url" <*> x .: "id" + <*> x .: "mentions_count" <*> x .: "name" <*> x .: "node_id" <*> x .: "prerelease" @@ -70,6 +72,7 @@ instance ToJSON Release where , "draft" .= releaseDraft , "html_url" .= releaseHtmlUrl , "id" .= releaseId + , "mentions_count" .= releaseMentionsCount , "name" .= releaseName , "node_id" .= releaseNodeId , "prerelease" .= releasePrerelease @@ -103,3 +106,4 @@ instance Arbitrary Release where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/src/GitHub/Types/Events/ReleaseEvent.hs b/src/GitHub/Types/Events/ReleaseEvent.hs index c20d57b..2287b0c 100644 --- a/src/GitHub/Types/Events/ReleaseEvent.hs +++ b/src/GitHub/Types/Events/ReleaseEvent.hs @@ -19,6 +19,7 @@ data ReleaseEvent = ReleaseEvent , releaseEventSender :: User , releaseEventAction :: Text + , releaseEventChanges :: Maybe Changes , releaseEventRelease :: Release } deriving (Eq, Show, Read) @@ -34,6 +35,7 @@ instance FromJSON ReleaseEvent where <*> x .: "sender" <*> x .: "action" + <*> x .:? "changes" <*> x .: "release" parseJSON _ = fail "ForkEvent" @@ -46,6 +48,7 @@ instance ToJSON ReleaseEvent where , "sender" .= releaseEventSender , "action" .= releaseEventAction + , "changes" .= releaseEventChanges , "release" .= releaseEventRelease ] @@ -59,3 +62,4 @@ instance Arbitrary ReleaseEvent where <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/tools/hub-graph.hs b/tools/hub-graph.hs new file mode 100644 index 0000000..77a603f --- /dev/null +++ b/tools/hub-graph.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.ByteString.Char8 as BS8 +import qualified GitHub +import System.Environment (getEnv) + +import GitHub.Tools.NetworkGraph + + +repos :: [(GitHub.Name GitHub.Owner, GitHub.Name GitHub.Repo)] +repos = + [ ("TokTok", "c-toxcore") + , ("irungentoo", "toxcore") + ] + +main :: IO () +main = do + -- Get auth token from the $GITHUB_TOKEN environment variable. + auth <- Just . GitHub.OAuth . BS8.pack <$> getEnv "GITHUB_TOKEN" + putStr =<< getNetworkGraph auth repos