-- | Find commits without descendants
module Data.Git.Phoenix.HeadsDiscovery where

import Data.ByteString.Lazy.Char8 qualified as C8
import Data.Map.Strict qualified as M
import Data.Git.Phoenix.App as A
import Data.Git.Phoenix.Commit
import Data.Git.Phoenix.CmdArgs
import Data.Git.Phoenix.Io
import Data.Git.Phoenix.Object
import Data.Git.Phoenix.Prelude
import Data.Git.Phoenix.Pretty
import Data.Git.Phoenix.Sha
import Data.Set qualified as S
import Data.Git.Phoenix.ShaCollision
import Data.Time.Format
import Text.Regex.TDFA.ByteString.Lazy
import Text.Regex.TDFA

data CommitObject
  = CommitObject
    { CommitObject -> LByteString
message :: LByteString
    , CommitObject -> Int64
commitTs :: Int64
    , CommitObject -> LByteString
comAuthor :: LByteString
    , CommitObject -> Maybe LByteString
parent :: Maybe LByteString
    } deriving (CommitObject -> CommitObject -> Bool
(CommitObject -> CommitObject -> Bool)
-> (CommitObject -> CommitObject -> Bool) -> Eq CommitObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommitObject -> CommitObject -> Bool
== :: CommitObject -> CommitObject -> Bool
$c/= :: CommitObject -> CommitObject -> Bool
/= :: CommitObject -> CommitObject -> Bool
Eq, Int -> CommitObject -> ShowS
[CommitObject] -> ShowS
CommitObject -> [Char]
(Int -> CommitObject -> ShowS)
-> (CommitObject -> [Char])
-> ([CommitObject] -> ShowS)
-> Show CommitObject
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommitObject -> ShowS
showsPrec :: Int -> CommitObject -> ShowS
$cshow :: CommitObject -> [Char]
show :: CommitObject -> [Char]
$cshowList :: [CommitObject] -> ShowS
showList :: [CommitObject] -> ShowS
Show, (forall x. CommitObject -> Rep CommitObject x)
-> (forall x. Rep CommitObject x -> CommitObject)
-> Generic CommitObject
forall x. Rep CommitObject x -> CommitObject
forall x. CommitObject -> Rep CommitObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommitObject -> Rep CommitObject x
from :: forall x. CommitObject -> Rep CommitObject x
$cto :: forall x. Rep CommitObject x -> CommitObject
to :: forall x. Rep CommitObject x -> CommitObject
Generic)

instance NFData CommitObject

type ShaBs = LByteString

readCommitObject :: forall m . PhoenixSearchM m => FilePath -> m [(ShaBs, CommitObject)]
readCommitObject :: forall (m :: * -> *).
PhoenixSearchM m =>
[Char] -> m [(LByteString, CommitObject)]
readCommitObject [Char]
gop =
  case [Char] -> Maybe LByteString
cutGitPath [Char]
gop of
    Maybe LByteString
Nothing -> [(LByteString, CommitObject)] -> m [(LByteString, CommitObject)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just LByteString
gp -> (CommitObject -> (LByteString, CommitObject))
-> [CommitObject] -> [(LByteString, CommitObject)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LByteString
gp,) ([CommitObject] -> [(LByteString, CommitObject)])
-> m [CommitObject] -> m [(LByteString, CommitObject)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m [CommitObject]
go [Char]
gop
  where
    orphanCommit :: Maybe LByteString -> LByteString -> f [CommitObject]
orphanCommit Maybe LByteString
parent LByteString
bs =
      case LByteString -> LbsPair
extractAuthor LByteString
bs of
        (LByteString
"", LByteString
_) -> [CommitObject] -> f [CommitObject]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        (LByteString
comAuthor, LByteString
bs') ->
          case LByteString -> Maybe (Int64, LByteString)
extractCommitTs LByteString
bs' of
            Maybe (Int64, LByteString)
Nothing -> [CommitObject] -> f [CommitObject]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Just (Int64
commitTs, LByteString
bs'') ->
              case LByteString -> LByteString
extractMessage LByteString
bs'' of
                LByteString
message ->
                    [CommitObject] -> f [CommitObject]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CommitObject {LByteString
message :: LByteString
message :: LByteString
message, Int64
commitTs :: Int64
commitTs :: Int64
commitTs, LByteString
comAuthor :: LByteString
comAuthor :: LByteString
comAuthor, Maybe LByteString
parent :: Maybe LByteString
parent :: Maybe LByteString
parent}]

    goCommit :: LByteString -> f [CommitObject]
goCommit LByteString
bs =
      case LByteString -> LbsPair
extractParent LByteString
bs of
        (LByteString
"", LByteString
bs') -> Maybe LByteString -> LByteString -> f [CommitObject]
forall {f :: * -> *}.
Applicative f =>
Maybe LByteString -> LByteString -> f [CommitObject]
orphanCommit Maybe LByteString
forall a. Maybe a
Nothing LByteString
bs'
        (LByteString
parent, LByteString
bs') -> Maybe LByteString -> LByteString -> f [CommitObject]
forall {f :: * -> *}.
Applicative f =>
Maybe LByteString -> LByteString -> f [CommitObject]
orphanCommit (LByteString -> Maybe LByteString
forall a. a -> Maybe a
Just (LByteString -> Maybe LByteString)
-> LByteString -> Maybe LByteString
forall a b. (a -> b) -> a -> b
$ LByteString -> LByteString
hexToBin LByteString
parent) LByteString
bs'

    go :: FilePath -> m [CommitObject]
    go :: [Char] -> m [CommitObject]
go [Char]
absGop = do
      lr <- [Char]
-> (Tagged Compressed LByteString
    -> LByteString
    -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a (m :: * -> *).
(NFData a, MonadUnliftIO m, HasInHandlesSem m) =>
[Char]
-> (Tagged Compressed LByteString -> LByteString -> m a) -> m a
withCompressedH [Char]
absGop ((Tagged Compressed LByteString
  -> LByteString
  -> m (Either (Tagged Compressed LByteString) [CommitObject]))
 -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> (Tagged Compressed LByteString
    -> LByteString
    -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a b. (a -> b) -> a -> b
$ \Tagged Compressed LByteString
cbs LByteString
bs ->
        case LByteString -> Maybe GitObjType
classifyGitObject LByteString
bs of
          Just GitObjType
BlobType -> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Tagged Compressed LByteString) [CommitObject]
 -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a b. (a -> b) -> a -> b
$ [CommitObject]
-> Either (Tagged Compressed LByteString) [CommitObject]
forall a b. b -> Either a b
Right []
          Just GitObjType
TreeType -> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Tagged Compressed LByteString) [CommitObject]
 -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a b. (a -> b) -> a -> b
$ [CommitObject]
-> Either (Tagged Compressed LByteString) [CommitObject]
forall a b. b -> Either a b
Right []
          Just GitObjType
CommitType -> [CommitObject]
-> Either (Tagged Compressed LByteString) [CommitObject]
forall a b. b -> Either a b
Right ([CommitObject]
 -> Either (Tagged Compressed LByteString) [CommitObject])
-> m [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LByteString -> m [CommitObject]
forall {f :: * -> *}.
Applicative f =>
LByteString -> f [CommitObject]
goCommit LByteString
bs
          Just GitObjType
CollidedHash -> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Tagged Compressed LByteString) [CommitObject]
 -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a b. (a -> b) -> a -> b
$ Tagged Compressed LByteString
-> Either (Tagged Compressed LByteString) [CommitObject]
forall a b. a -> Either a b
Left Tagged Compressed LByteString
cbs
          Maybe GitObjType
Nothing -> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Tagged Compressed LByteString) [CommitObject]
 -> m (Either (Tagged Compressed LByteString) [CommitObject]))
-> Either (Tagged Compressed LByteString) [CommitObject]
-> m (Either (Tagged Compressed LByteString) [CommitObject])
forall a b. (a -> b) -> a -> b
$ [CommitObject]
-> Either (Tagged Compressed LByteString) [CommitObject]
forall a b. b -> Either a b
Right []
      case lr of
        Right [CommitObject]
cmt -> [CommitObject] -> m [CommitObject]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CommitObject]
cmt
        Left Tagged Compressed LByteString
cbs -> do
          disLinks <- GitObjType -> [[Char]] -> m [[Char]]
forall (m :: * -> *).
PhoenixM m =>
GitObjType -> [[Char]] -> m [[Char]]
disambiguateByPair GitObjType
CommitType ([[Char]] -> m [[Char]])
-> ([LByteString] -> [[Char]]) -> [LByteString] -> m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LByteString -> [Char]) -> [LByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LByteString -> [Char]
C8.unpack ([LByteString] -> m [[Char]]) -> [LByteString] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ Tagged Compressed LByteString -> [LByteString]
parseFileLinks Tagged Compressed LByteString
cbs
          concat <$> mapM go disLinks

loadCommitMap :: PhoenixSearchM m => m (M.Map ShaBs CommitObject)
loadCommitMap :: forall (m :: * -> *).
PhoenixSearchM m =>
m (Map LByteString CommitObject)
loadCommitMap = do
  (Tagged udr) <- (PhoenixSearchConf -> Tagged InDir [Char])
-> m (Tagged InDir [Char])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixSearchConf -> Tagged InDir [Char]
A.uberRepoDir
  runConduitRes
    (  sourceDirectoryDeep False udr
    .| mapMC readCommitObject
    .| concatC
    .| foldMC (\Map LByteString CommitObject
m (LByteString
k, CommitObject
c) -> Map LByteString CommitObject
-> ResourceT m (Map LByteString CommitObject)
forall a. a -> ResourceT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map LByteString CommitObject
 -> ResourceT m (Map LByteString CommitObject))
-> Map LByteString CommitObject
-> ResourceT m (Map LByteString CommitObject)
forall a b. (a -> b) -> a -> b
$ LByteString
-> CommitObject
-> Map LByteString CommitObject
-> Map LByteString CommitObject
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert LByteString
k CommitObject
c Map LByteString CommitObject
m) mempty
    )

doesMatch :: Regex -> LByteString -> Bool
doesMatch :: Regex -> LByteString -> Bool
doesMatch Regex
rxPat LByteString
bs =
  case Regex -> LByteString -> Either [Char] (Maybe MatchArray)
execute Regex
rxPat LByteString
bs of
    Right (Just MatchArray
_) -> Bool
True
    Right Maybe MatchArray
_ -> Bool
False
    Left [Char]
_ -> Bool
False

discoverHeads :: PhoenixSearchM m => String -> m [(ShaBs, CommitObject)]
discoverHeads :: forall (m :: * -> *).
PhoenixSearchM m =>
[Char] -> m [(LByteString, CommitObject)]
discoverHeads [Char]
authorPat = do
  case CompOption -> ExecOption -> LByteString -> Either [Char] Regex
compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt (Bool -> ExecOption
ExecOption Bool
False) (LByteString -> Either [Char] Regex)
-> LByteString -> Either [Char] Regex
forall a b. (a -> b) -> a -> b
$ [Char] -> LByteString
C8.pack [Char]
authorPat of
    Left [Char]
e -> [Char] -> m [(LByteString, CommitObject)]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m [(LByteString, CommitObject)])
-> [Char] -> m [(LByteString, CommitObject)]
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid author regex pattern due: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>  [Char]
e
    Right Regex
authorRePat -> do
      cm <- m (Map LByteString CommitObject)
forall (m :: * -> *).
PhoenixSearchM m =>
m (Map LByteString CommitObject)
loadCommitMap
      let parentSet = [LByteString] -> Set LByteString
forall a. Ord a => [a] -> Set a
S.fromList ([LByteString] -> Set LByteString)
-> ([CommitObject] -> [LByteString])
-> [CommitObject]
-> Set LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe LByteString] -> [LByteString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LByteString] -> [LByteString])
-> ([CommitObject] -> [Maybe LByteString])
-> [CommitObject]
-> [LByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitObject -> Maybe LByteString)
-> [CommitObject] -> [Maybe LByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommitObject -> Maybe LByteString
parent  ([CommitObject] -> Set LByteString)
-> [CommitObject] -> Set LByteString
forall a b. (a -> b) -> a -> b
$ Map LByteString CommitObject -> [CommitObject]
forall k a. Map k a -> [a]
M.elems Map LByteString CommitObject
cm
          unreachable Map LByteString CommitObject
m LByteString
k (CommitObject
v :: CommitObject) =
            if (LByteString
k LByteString -> Set LByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set LByteString
parentSet) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> LByteString -> Bool
doesMatch Regex
authorRePat (CommitObject -> LByteString
comAuthor CommitObject
v))
            then Map LByteString CommitObject
m
            else LByteString
-> CommitObject
-> Map LByteString CommitObject
-> Map LByteString CommitObject
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert LByteString
k CommitObject
v Map LByteString CommitObject
m
          ucm = (Map LByteString CommitObject
 -> LByteString -> CommitObject -> Map LByteString CommitObject)
-> Map LByteString CommitObject
-> Map LByteString CommitObject
-> Map LByteString CommitObject
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey Map LByteString CommitObject
-> LByteString -> CommitObject -> Map LByteString CommitObject
unreachable Map LByteString CommitObject
forall a. Monoid a => a
mempty Map LByteString CommitObject
cm
      pure . sortOn (\(LByteString
_, CommitObject
c) -> (CommitObject -> Int64
commitTs CommitObject
c, CommitObject -> LByteString
comAuthor CommitObject
c)) $ M.toList ucm

runHeadsDiscovery :: HeadsDiscovery -> IO [(ShaBs, CommitObject)]
runHeadsDiscovery :: HeadsDiscovery -> IO [(LByteString, CommitObject)]
runHeadsDiscovery HeadsDiscovery2 { [Char]
author :: [Char]
author :: HeadsDiscovery -> [Char]
author, Tagged InDir [Char]
uberRepoDir :: Tagged InDir [Char]
uberRepoDir :: HeadsDiscovery -> Tagged InDir [Char]
uberRepoDir } = do
  s <- Int -> IO QSem
forall (m :: * -> *). MonadIO m => Int -> m QSem
newQSem (Int -> IO QSem) -> IO Int -> IO QSem
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumCapabilities
  runReaderT
    (discoverHeads author)
    (PhoenixSearchConf uberRepoDir s)

formatCommit :: (ShaBs, CommitObject) -> Doc
formatCommit :: (LByteString, CommitObject) -> Doc
formatCommit (LByteString
sha, CommitObject
co) = [[Char]] -> Doc
forall a. Pretty a => [a] -> Doc
hsep
  [ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 (LByteString -> [Char]
binSha2Str LByteString
sha)
  , TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime
      TimeLocale
defaultTimeLocale
      [Char]
"%Y-%m-%d %H:%M"
      (Integer -> UTCTime
secondsToUtcTime (Integer -> UTCTime) -> (Int64 -> Integer) -> Int64 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> UTCTime) -> Int64 -> UTCTime
forall a b. (a -> b) -> a -> b
$ CommitObject -> Int64
commitTs CommitObject
co)
  , LByteString -> [Char]
C8.unpack (CommitObject -> LByteString
comAuthor CommitObject
co)
  , Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
60 (LByteString -> [Char]
C8.unpack (CommitObject -> LByteString
message CommitObject
co))
  ]

commitObjectsToDoc :: [(ShaBs, CommitObject)] -> Doc
commitObjectsToDoc :: [(LByteString, CommitObject)] -> Doc
commitObjectsToDoc = \case
  [] -> Doc
forall a. Monoid a => a
mempty
  [(LByteString, CommitObject)]
o -> [Doc] -> Doc
vcat (((LByteString, CommitObject) -> Doc)
-> [(LByteString, CommitObject)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LByteString, CommitObject) -> Doc
formatCommit [(LByteString, CommitObject)]
o) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
linebreak