feat: Add github network graph tool.

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"),

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

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

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)

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

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

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