module Data.Git.Phoenix.CommitSearch where

import Data.ByteString.Lazy.Char8 qualified as C8
import Data.Git.Phoenix.App as A
import Data.Git.Phoenix.CmdArgs (DaysAfter, DaysBefore, SearchCommitBy (..))
import Data.Git.Phoenix.Commit
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.Git.Phoenix.ShaCollision
import Data.List.NonEmpty (groupWith)
import Data.Time.Clock.System
import Data.Time.Format
import Text.Regex.TDFA.ByteString.Lazy
import Text.Regex.TDFA

data CommitObject
  = CommitObject
    { CommitObject -> LByteString
message :: LByteString
    , CommitObject -> LByteString
sha :: LByteString
    , CommitObject -> Int64
commitTs :: Int64
    , CommitObject -> LByteString
author :: 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

readCommitObject :: forall m . PhoenixSearchM m => FilePath -> m [CommitObject]
readCommitObject :: forall (m :: * -> *).
PhoenixSearchM m =>
[Char] -> m [CommitObject]
readCommitObject = [Char] -> m [CommitObject]
go
  where
    -- "commit 192\NULtree 844eaa6a04859d069e9ae10f2c6c293d23efc459\nauthor Daniil Iaitskov <dyaitskov@gmail.com> 1750985584 -0800\ncommitter Daniil Iaitskov <dyaitskov@gmail.com> 1 750 985 584 -0800\n\n init git-phoenix\n"
    goCommit :: LByteString -> f [CommitObject]
goCommit 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
author, 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 ->
                  let sha :: LByteString
sha = GitPath (ZonkAny 0) -> LByteString
forall (a :: GitObjTypeG). GitPath a -> LByteString
gitPath2Bs (GitPath (ZonkAny 0) -> LByteString)
-> (ByteString -> GitPath (ZonkAny 0)) -> ByteString -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> GitPath (ZonkAny 0)
forall (a :: GitObjTypeG). [Char] -> GitPath a
shaToPath ([Char] -> GitPath (ZonkAny 0))
-> (ByteString -> [Char]) -> ByteString -> GitPath (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
showDigest (ByteString -> LByteString) -> ByteString -> LByteString
forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
sha1 LByteString
bs in
                    [CommitObject] -> f [CommitObject]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CommitObject {LByteString
message :: LByteString
message :: LByteString
message, LByteString
sha :: LByteString
sha :: LByteString
sha, Int64
commitTs :: Int64
commitTs :: Int64
commitTs, LByteString
author :: LByteString
author :: LByteString
author}]


    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

parseGitObject :: PhoenixSearchM m =>
  Regex ->
  Tagged DaysAfter Int64 ->
  Tagged DaysBefore Int64 ->
  FilePath ->
  m [CommitObject]
parseGitObject :: forall (m :: * -> *).
PhoenixSearchM m =>
Regex
-> Tagged DaysAfter Int64
-> Tagged DaysBefore Int64
-> [Char]
-> m [CommitObject]
parseGitObject Regex
authorRegex (Tagged Int64
epochSecondsAfter) (Tagged Int64
epochSecondsBefore) [Char]
fp =
  (CommitObject -> Bool) -> [CommitObject] -> [CommitObject]
forall a. (a -> Bool) -> [a] -> [a]
filter CommitObject -> Bool
commitPredicate ([CommitObject] -> [CommitObject])
-> m [CommitObject] -> m [CommitObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m [CommitObject]
forall (m :: * -> *).
PhoenixSearchM m =>
[Char] -> m [CommitObject]
readCommitObject [Char]
fp
  where
    commitPredicate :: CommitObject -> Bool
commitPredicate CommitObject
co =
      case Regex -> LByteString -> Either [Char] (Maybe MatchArray)
execute Regex
authorRegex (CommitObject -> LByteString
Data.Git.Phoenix.CommitSearch.author CommitObject
co) of
        Right (Just MatchArray
_) ->
          CommitObject -> Int64
commitTs CommitObject
co Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
epochSecondsAfter Bool -> Bool -> Bool
&& CommitObject -> Int64
commitTs CommitObject
co Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
epochSecondsBefore
        Right Maybe MatchArray
_ -> Bool
False
        Left [Char]
_ -> Bool
False

dedupOrderedList :: Eq a => [a] -> [a]
dedupOrderedList :: forall a. Eq a => [a] -> [a]
dedupOrderedList = (NonEmpty a -> a) -> [NonEmpty a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty a -> a
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head ([NonEmpty a] -> [a]) -> ([a] -> [NonEmpty a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> [a] -> [NonEmpty a]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
groupWith a -> a
forall a. a -> a
id

searchCommit :: PhoenixSearchM m =>
  String -> Tagged DaysAfter Int -> Tagged DaysBefore Int -> m [CommitObject]
searchCommit :: forall (m :: * -> *).
PhoenixSearchM m =>
[Char]
-> Tagged DaysAfter Int
-> Tagged DaysBefore Int
-> m [CommitObject]
searchCommit [Char]
authorPat Tagged DaysAfter Int
daysAfter Tagged DaysBefore Int
daysBefore = 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
  now <- liftIO (systemSeconds <$> getSystemTime)
  let daysToEpochSecs :: forall x. Tagged x Int -> Tagged x Int64
      daysToEpochSecs = (Int64 -> Int64) -> Tagged x Int64 -> Tagged x Int64
forall a b. (a -> b) -> Tagged x a -> Tagged x b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int64
now Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-) (Int64 -> Int64) -> (Int64 -> Int64) -> Int64 -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
86400)) (Tagged x Int64 -> Tagged x Int64)
-> (Tagged x Int -> Tagged x Int64)
-> Tagged x Int
-> Tagged x Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged x Int -> Tagged x Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  case compile defaultCompOpt (ExecOption False) $ C8.pack authorPat of
    Left [Char]
e -> [Char] -> m [CommitObject]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m [CommitObject]) -> [Char] -> m [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 ->
      [CommitObject] -> [CommitObject]
forall a. Eq a => [a] -> [a]
dedupOrderedList ([CommitObject] -> [CommitObject])
-> ([CommitObject] -> [CommitObject])
-> [CommitObject]
-> [CommitObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitObject -> Int64) -> [CommitObject] -> [CommitObject]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn CommitObject -> Int64
commitTs ([CommitObject] -> [CommitObject])
-> m [CommitObject] -> m [CommitObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void (ResourceT m) [CommitObject] -> m [CommitObject]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
        (  Bool -> [Char] -> ConduitT () [Char] (ResourceT m) ()
forall (m :: * -> *) i.
MonadResource m =>
Bool -> [Char] -> ConduitT i [Char] m ()
sourceDirectoryDeep Bool
False [Char]
udr
        ConduitT () [Char] (ResourceT m) ()
-> ConduitT [Char] Void (ResourceT m) [CommitObject]
-> ConduitT () Void (ResourceT m) [CommitObject]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([Char] -> ResourceT m [CommitObject])
-> ConduitT [Char] [CommitObject] (ResourceT m) ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (Regex
-> Tagged DaysAfter Int64
-> Tagged DaysBefore Int64
-> [Char]
-> ResourceT m [CommitObject]
forall (m :: * -> *).
PhoenixSearchM m =>
Regex
-> Tagged DaysAfter Int64
-> Tagged DaysBefore Int64
-> [Char]
-> m [CommitObject]
parseGitObject Regex
authorRePat
                   (Tagged DaysAfter Int -> Tagged DaysAfter Int64
forall {k} (x :: k). Tagged x Int -> Tagged x Int64
daysToEpochSecs Tagged DaysAfter Int
daysAfter)
                   (Tagged DaysBefore Int -> Tagged DaysBefore Int64
forall {k} (x :: k). Tagged x Int -> Tagged x Int64
daysToEpochSecs Tagged DaysBefore Int
daysBefore))
        ConduitT [Char] [CommitObject] (ResourceT m) ()
-> ConduitT [CommitObject] Void (ResourceT m) [CommitObject]
-> ConduitT [Char] Void (ResourceT m) [CommitObject]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([CommitObject] -> [CommitObject] -> ResourceT m [CommitObject])
-> [CommitObject]
-> ConduitT [CommitObject] Void (ResourceT m) [CommitObject]
forall (m :: * -> *) a b o.
Monad m =>
(a -> b -> m a) -> a -> ConduitT b o m a
foldMC (\[CommitObject]
l [CommitObject]
a -> [CommitObject] -> ResourceT m [CommitObject]
forall a. a -> ResourceT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CommitObject] -> ResourceT m [CommitObject])
-> [CommitObject] -> ResourceT m [CommitObject]
forall a b. (a -> b) -> a -> b
$ [CommitObject]
a [CommitObject] -> [CommitObject] -> [CommitObject]
forall a. Semigroup a => a -> a -> a
<> [CommitObject]
l) []
        )

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

runCommitSearch :: SearchCommitBy -> IO [CommitObject]
runCommitSearch :: SearchCommitBy -> IO [CommitObject]
runCommitSearch SearchCommitBy2 { [Char]
author :: [Char]
author :: SearchCommitBy -> [Char]
author, Tagged DaysBefore Int
daysBefore :: Tagged DaysBefore Int
daysBefore :: SearchCommitBy -> Tagged DaysBefore Int
daysBefore, Tagged InDir [Char]
uberRepoDir :: Tagged InDir [Char]
uberRepoDir :: SearchCommitBy -> Tagged InDir [Char]
uberRepoDir, Tagged DaysAfter Int
daysAfter :: Tagged DaysAfter Int
daysAfter :: SearchCommitBy -> Tagged DaysAfter Int
daysAfter } = 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
    (searchCommit author daysAfter daysBefore)
    (PhoenixSearchConf uberRepoDir s)

formatCommit :: CommitObject -> Doc
formatCommit :: CommitObject -> Doc
formatCommit CommitObject
co = [[Char]] -> Doc
forall a. Pretty a => [a] -> Doc
hsep
  [ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 (LByteString -> [Char]
binSha2Str (CommitObject -> LByteString
sha CommitObject
co))
  , 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
Data.Git.Phoenix.CommitSearch.author CommitObject
co)
  , Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
60 (LByteString -> [Char]
C8.unpack (CommitObject -> LByteString
message CommitObject
co))
  ]