{-# 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 Int -> Ref -> ShowS
[Ref] -> ShowS
Ref -> String
(Int -> Ref -> ShowS)
-> (Ref -> String) -> ([Ref] -> ShowS) -> Show Ref
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ref] -> ShowS
$cshowList :: [Ref] -> ShowS
show :: Ref -> String
$cshow :: Ref -> String
showsPrec :: Int -> Ref -> ShowS
$cshowsPrec :: Int -> Ref -> ShowS
Show

instance Read Ref where
    readsPrec :: Int -> ReadS Ref
readsPrec Int
_ = ReadP Ref -> ReadS Ref
forall a. ReadP a -> ReadS a
R.readP_to_S (ReadP Ref -> ReadS Ref) -> ReadP Ref -> ReadS Ref
forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> [String] -> Ref
Ref
        (String -> String -> [String] -> [String] -> Ref)
-> ReadP String -> ReadP (String -> [String] -> [String] -> Ref)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
R.count Int
25 ReadP Char
R.get
        ReadP (String -> [String] -> [String] -> Ref)
-> ReadP String -> ReadP ([String] -> [String] -> Ref)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> ReadP Char
R.char Char
' ' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP String
readRef)
        ReadP ([String] -> [String] -> Ref)
-> ReadP [String] -> ReadP ([String] -> Ref)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP String -> ReadP [String]
forall a. ReadP a -> ReadP [a]
R.many1 (Char -> ReadP Char
R.char Char
' ' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP String
readRef)
        ReadP ([String] -> Ref) -> ReadP [String] -> ReadP Ref
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP [String]
readNames
      where
        readRef :: ReadP String
readRef = Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
R.count Int
40 (ReadP Char -> ReadP String)
-> (String -> ReadP Char) -> String -> ReadP String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ReadP Char] -> ReadP Char
forall a. [ReadP a] -> ReadP a
R.choice ([ReadP Char] -> ReadP Char)
-> (String -> [ReadP Char]) -> String -> ReadP Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ReadP Char) -> String -> [ReadP Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> ReadP Char
R.char (String -> ReadP String) -> String -> ReadP String
forall a b. (a -> b) -> a -> b
$ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'f']
        readNames :: ReadP [String]
readNames = do
            ReadP String -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP String -> ReadP ()) -> ReadP String -> ReadP ()
forall a b. (a -> b) -> a -> b
$ String -> ReadP String
R.string String
" ("
            [String]
res <- ReadP String -> ReadP String -> ReadP [String]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
R.sepBy ((Char -> Bool) -> ReadP String
R.munch (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',',Char
')']))) (String -> ReadP String
R.string String
", ")
            ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
R.char Char
')'
            [String] -> ReadP [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
res


toDot :: Ref -> [String]
toDot :: Ref -> [String]
toDot (Ref String
_ String
_ [String]
_ []) = []
toDot (Ref String
date (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6 -> String
ref) (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6) -> [String]
parents) names :: [String]
names@(String
mainName:[String]
_)) =
    String
"  \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ref String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" [ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
" " [String]
attrs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
edges
  where
    edges :: [String]
edges = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
parent -> String
"  \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ref String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" -> \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
parent String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"") [String]
parents
    truncateName :: ShowS
truncateName String
name
      | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
25 = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
22 String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..."
      | Bool
otherwise = String
name

    attrs :: [String]
attrs =
        [ String
"label = \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\\n" (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
10 String
date String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
truncateName [String]
names) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
        , String
"tooltip = \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\\n" [String]
names String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
        , String
"fillcolor = \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
nameColor String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
        ]

    palette :: [String]
palette =
        [ String
"#ccff00"
        , String
"#ccffff"
        , String
"#ffff66"
        , String
"#cccc00"
        , String
"#ccccff"
        , String
"#ffccff"
        , String
"#ffcccc"
        , String
"#ffcc33"
        , String
"#cc9933"
        , String
"#cc9999"
        , String
"#cc99ff"
        , String
"#ff99ff"
        , String
"#ff9933"
        , String
"#cc6633"
        , String
"#66cc99"
        , String
"#99cc33"
        , String
"#009900"
        ]

    nameColor :: String
nameColor =
        case (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
':',Char
'/']) String
mainName of
          String
"HEAD -> master" -> String
"red"
          String
"tag" -> String
"#cccccc"
          String
author -> [String]
palette [String] -> Int -> String
forall a. [a] -> Int -> a
!! (([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (String -> [Int]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
author) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
palette))


minDate :: String
minDate :: String
minDate = String
"2022-01"


urlBase :: String
urlBase :: String
urlBase = String
"https://username:password@github.com/"


denyList :: [GH.Name GH.Owner]
denyList :: [Name Owner]
denyList =
    [ Name Owner
"4a256b6b3e7t3e8b7t9q7t"
    , Name Owner
"activistWannabe2"
    , Name Owner
"cha63506"
    , Name Owner
"chai3819"
    , Name Owner
"CNXTEoEorg"
    , Name Owner
"DannaScully"
    , Name Owner
"din982"
    , Name Owner
"fireeyeusa"
    , Name Owner
"grubern"
    , Name Owner
"haiiev"
    , Name Owner
"innnzzz6"
    , Name Owner
"jamiepg1"
    , Name Owner
"josephyzhou"
    , Name Owner
"jrtorres42"
    , Name Owner
"kigu"
    , Name Owner
"lucasborer1"
    , Name Owner
"lukw00"
    , Name Owner
"makianditro1"
    , Name Owner
"mehulsbhatt"
    , Name Owner
"mk21"
    , Name Owner
"nfkd"
    , Name Owner
"noikiy"
    , Name Owner
"ProgrammerAndHacker"
    , Name Owner
"receptpr9001"
    , Name Owner
"shaunstanislaus"
    , Name Owner
"sometwo"
    , Name Owner
"SunelContus"
    , Name Owner
"treejames"
    , Name Owner
"xeon2007"
    , Name Owner
"xuecai"
    ]


-- | Monadic version of @unless@, taking the condition in the monad
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: m Bool -> m () -> m ()
unlessM m Bool
condM m ()
acc = do
    Bool
cond <- m Bool
condM
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cond m ()
acc


getNetworkGraph
    :: Maybe GH.Auth
    -> [RepoRef]
    -> IO String
getNetworkGraph :: Maybe Auth -> [RepoRef] -> IO String
getNetworkGraph Maybe Auth
_ [] = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
getNetworkGraph Maybe Auth
auth repos :: [RepoRef]
repos@(RepoRef
rootRepo:[RepoRef]
seedRepos) = do
    -- Initialise HTTP manager so we can benefit from keep-alive connections.
    Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings

    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesDirectoryExist String
clonePath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Cloning initial repo"
        RepoRef -> IO ()
forall entity entity. (Name entity, Name entity) -> IO ()
clone RepoRef
rootRepo
        String -> IO ()
setCurrentDirectory String
clonePath

        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Adding remotes for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([RepoRef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RepoRef]
seedRepos) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" seed repos"
        (RepoRef -> IO ()) -> [RepoRef] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RepoRef -> IO ()
forall entity entity. (Name entity, Name entity) -> IO ()
addRemote [RepoRef]
seedRepos

        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Querying GitHub for forks..."
        Vector RepoRef
forks <- (RepoRef -> Bool) -> Vector RepoRef -> Vector RepoRef
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (Bool -> Bool
not (Bool -> Bool) -> (RepoRef -> Bool) -> RepoRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name Owner -> [Name Owner] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name Owner]
denyList) (Name Owner -> Bool) -> (RepoRef -> Name Owner) -> RepoRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoRef -> Name Owner
forall a b. (a, b) -> a
fst) (Vector RepoRef -> Vector RepoRef)
-> ([Vector RepoRef] -> Vector RepoRef)
-> [Vector RepoRef]
-> Vector RepoRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector RepoRef] -> Vector RepoRef
forall a. [Vector a] -> Vector a
V.concat ([Vector RepoRef] -> Vector RepoRef)
-> IO [Vector RepoRef] -> IO (Vector RepoRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RepoRef -> IO (Vector RepoRef))
-> [RepoRef] -> IO [Vector RepoRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Manager -> RepoRef -> IO (Vector RepoRef)
forksFor Manager
mgr) [RepoRef]
repos

        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Adding remotes for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Vector RepoRef -> Int
forall a. Vector a -> Int
V.length Vector RepoRef
forks) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" forks"
        (RepoRef -> IO ()) -> Vector RepoRef -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ RepoRef -> IO ()
forall entity entity. (Name entity, Name entity) -> IO ()
addRemote Vector RepoRef
forks

        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Fetching all remotes"
        IO ()
fetchAll

    String -> IO ()
setCurrentDirectory String
clonePath
    [String]
dotLines <- (Ref -> [String]) -> [Ref] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ref -> [String]
toDot ([Ref] -> [String]) -> IO [Ref] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Ref]
gitLog

    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> ([[String]] -> String) -> [[String]] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([[String]] -> [String]) -> [[String]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> IO String) -> [[String]] -> IO String
forall a b. (a -> b) -> a -> b
$
        [ [ String
"strict digraph \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RepoRef -> String
forall entity entity. (Name entity, Name entity) -> String
repoPath RepoRef
rootRepo String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" {"
          , String
"  graph [splines=ortho, rankdir=LR]"
          , String
"  node [shape=box width=2.5 margin=\"0,0.02\" style=filled]"
          , String
"  edge [dir=back]"
          ]
        , [String]
dotLines
        , [String
"}"]
        ]

  where
    repoPath :: (Name entity, Name entity) -> String
repoPath (GH.N (Text -> String
Text.unpack -> String
owner), GH.N (Text -> String
Text.unpack -> String
repo)) =
        String
owner String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
repo

    clonePath :: String
clonePath = String
"/tmp/hub-graph/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Text -> String
Text.unpack (Text -> String) -> (RepoRef -> Text) -> RepoRef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name Repo -> Text
forall entity. Name entity -> Text
GH.untagName (Name Repo -> Text) -> (RepoRef -> Name Repo) -> RepoRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoRef -> Name Repo
forall a b. (a, b) -> b
snd (RepoRef -> String) -> RepoRef -> String
forall a b. (a -> b) -> a -> b
$ RepoRef
rootRepo)

    clone :: (Name entity, Name entity) -> IO ()
clone (Name entity, Name entity)
repo =
        String -> [String] -> IO ()
callProcess String
"git" [String
"clone", String
urlBase String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Name entity, Name entity) -> String
forall entity entity. (Name entity, Name entity) -> String
repoPath (Name entity, Name entity)
repo, String
clonePath]

    addRemote :: (Name entity, Name entity) -> IO ()
addRemote repo :: (Name entity, Name entity)
repo@(GH.N (Text -> String
Text.unpack -> String
owner), Name entity
_) =
        String -> [String] -> IO ()
callProcess String
"git" [String
"remote", String
"add", String
owner, String
urlBase String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Name entity, Name entity) -> String
forall entity entity. (Name entity, Name entity) -> String
repoPath (Name entity, Name entity)
repo]

    fetchAll :: IO ()
fetchAll =
        String -> [String] -> IO ()
callProcess String
"git" [String
"fetch", String
"--all", String
"--prune", String
"--jobs=10"]

    gitLog :: IO [Ref]
gitLog =
        (String -> Ref) -> [String] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map String -> Ref
forall a. Read a => String -> a
read
        ([String] -> [Ref]) -> (String -> [String]) -> String -> [Ref]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Ord a => a -> a -> Bool
>= String
minDate)
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
List.splitOn String
"\n"
        (String -> [Ref]) -> IO String -> IO [Ref]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"git" [String
"log", String
"--all", String
"--format=%cI %H %P%d", String
"--topo-order", String
"--simplify-by-decoration"] String
""

    forksFor :: Manager -> RepoRef -> IO (V.Vector RepoRef)
    forksFor :: Manager -> RepoRef -> IO (Vector RepoRef)
forksFor Manager
mgr (Name Owner
owner, Name Repo
repo) =
        (Repo -> RepoRef) -> Vector Repo -> Vector RepoRef
forall a b. (a -> b) -> Vector a -> Vector b
V.map (SimpleOwner -> Name Owner
GH.simpleOwnerLogin (SimpleOwner -> Name Owner)
-> (Repo -> SimpleOwner) -> Repo -> Name Owner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repo -> SimpleOwner
GH.repoOwner (Repo -> Name Owner) -> (Repo -> Name Repo) -> Repo -> RepoRef
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Repo -> Name Repo
GH.repoName) (Vector Repo -> Vector RepoRef)
-> IO (Vector Repo) -> IO (Vector RepoRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Auth
-> Manager -> Request 'RO (Vector Repo) -> IO (Vector Repo)
forall a.
FromJSON a =>
Maybe Auth -> Manager -> Request 'RO a -> IO a
request Maybe Auth
auth Manager
mgr (Name Owner -> Name Repo -> FetchCount -> Request 'RO (Vector Repo)
forall (k :: RW).
Name Owner -> Name Repo -> FetchCount -> Request k (Vector Repo)
GH.forksForR Name Owner
owner Name Repo
repo FetchCount
GH.FetchAll)