module Data.Git.Phoenix.Extraction where

import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Git.Phoenix.App
import Data.Git.Phoenix.CmdArgs
import Data.Git.Phoenix.Commit
import Data.Git.Phoenix.Io
import Data.Git.Phoenix.Object
import Data.Git.Phoenix.Prelude
import Data.Git.Phoenix.Repo
import Data.Git.Phoenix.Sha
import Data.Git.Phoenix.ShaCollision
import Data.Git.Phoenix.Tree


readCommitObject :: PhoenixExtractM m => GitPath Commit -> m (Maybe (GitPath Commit), GitPath Tree)
readCommitObject :: forall (m :: * -> *).
PhoenixExtractM m =>
GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
readCommitObject GitPath 'Commit
gop = String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
go (String -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> (Tagged InDir String -> String)
-> Tagged InDir String
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> GitPath 'Commit -> String
forall (t :: GitObjTypeG). GitPath t -> String
toFp GitPath 'Commit
gop) (String -> String)
-> (Tagged InDir String -> String) -> Tagged InDir String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged InDir String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged InDir String -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> m (Tagged InDir String)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PhoenixExtractConf -> Tagged InDir String)
-> m (Tagged InDir String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged InDir String
uberDir
  where
    goCommit :: LByteString -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit LByteString
bs =
      case LByteString -> LbsPair
extractTreeHash (LByteString -> LbsPair) -> LByteString -> LbsPair
forall a b. (a -> b) -> a -> b
$ $(tr "eee/bs") LByteString
bs of
        (LByteString
"", LByteString
_) -> String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> String
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not have tree field"
        (LByteString
treeComit, LByteString
bs') -> do
          gitDir <- Tagged OutDir String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged OutDir String -> String)
-> m (Tagged OutDir String) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PhoenixExtractConf -> Tagged OutDir String)
-> m (Tagged OutDir String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged OutDir String
destGitDir
          saveCompressedBs
            (gitDir </> ".git" </> "objects" </> toFp gop)
            bs
          case extractParent bs' of
            (LByteString
"", LByteString
_) -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GitPath 'Commit)
forall a. Maybe a
Nothing, String -> GitPath 'Tree
forall (a :: GitObjTypeG). String -> GitPath a
shaToPath (String -> GitPath 'Tree) -> String -> GitPath 'Tree
forall a b. (a -> b) -> a -> b
$ LByteString -> String
L8.unpack LByteString
treeComit)
            (!LByteString
ph, LByteString
_) -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( GitPath 'Commit -> Maybe (GitPath 'Commit)
forall a. a -> Maybe a
Just (GitPath 'Commit -> Maybe (GitPath 'Commit))
-> (String -> GitPath 'Commit) -> String -> Maybe (GitPath 'Commit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GitPath 'Commit
forall (a :: GitObjTypeG). String -> GitPath a
shaToPath (String -> Maybe (GitPath 'Commit))
-> String -> Maybe (GitPath 'Commit)
forall a b. (a -> b) -> a -> b
$ LByteString -> String
L8.unpack LByteString
ph
                            , $(tr "/treeComit") (GitPath 'Tree -> GitPath 'Tree)
-> (String -> GitPath 'Tree) -> String -> GitPath 'Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GitPath 'Tree
forall (a :: GitObjTypeG). String -> GitPath a
shaToPath (String -> GitPath 'Tree) -> String -> GitPath 'Tree
forall a b. (a -> b) -> a -> b
$ LByteString -> String
L8.unpack LByteString
treeComit
                            )
    go :: String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
go String
absGop = do
      lr <- String
-> (Tagged Compressed LByteString
    -> LByteString
    -> m (Either
            (Tagged Compressed LByteString)
            (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a (m :: * -> *).
(NFData a, MonadUnliftIO m, HasInHandlesSem m) =>
String
-> (Tagged Compressed LByteString -> LByteString -> m a) -> m a
withCompressedH String
absGop ((Tagged Compressed LByteString
  -> LByteString
  -> m (Either
          (Tagged Compressed LByteString)
          (Maybe (GitPath 'Commit), GitPath 'Tree)))
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> (Tagged Compressed LByteString
    -> LByteString
    -> m (Either
            (Tagged Compressed LByteString)
            (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ \Tagged Compressed LByteString
cbs LByteString
bs ->
        case LByteString -> Maybe GitObjType
classifyGitObject LByteString
bs of
          Just GitObjType
BlobType -> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> String
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is Git blob but expected Git commit"
          Just GitObjType
TreeType -> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> String
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is Git tree but expected Git commit"
          Just GitObjType
CommitType -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> Either
     (Tagged Compressed LByteString)
     (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. b -> Either a b
Right ((Maybe (GitPath 'Commit), GitPath 'Tree)
 -> Either
      (Tagged Compressed LByteString)
      (Maybe (GitPath 'Commit), GitPath 'Tree))
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LByteString -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit LByteString
bs
          Just GitObjType
CollidedHash -> Either
  (Tagged Compressed LByteString)
  (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (Tagged Compressed LByteString)
   (Maybe (GitPath 'Commit), GitPath 'Tree)
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> Either
     (Tagged Compressed LByteString)
     (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ Tagged Compressed LByteString
-> Either
     (Tagged Compressed LByteString)
     (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. a -> Either a b
Left Tagged Compressed LByteString
cbs
          Maybe GitObjType
Nothing -> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> String
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> String
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a Git commit object"
      case lr of
        Right (Maybe (GitPath 'Commit), GitPath 'Tree)
cmt -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GitPath 'Commit), GitPath 'Tree)
cmt
        Left Tagged Compressed LByteString
cbs -> do
            uniPath <- GitPath 'Commit
-> Tagged Compressed LByteString -> GitObjType -> m String
forall (m :: * -> *) (x :: GitObjTypeG).
PhoenixExtractM m =>
GitPath x
-> Tagged Compressed LByteString -> GitObjType -> m String
uniqBs GitPath 'Commit
gop Tagged Compressed LByteString
cbs GitObjType
CommitType
            withCompressed uniPath $ \LByteString
ubs ->
              case LByteString -> Maybe GitObjType
classifyGitObject LByteString
ubs of
                Just GitObjType
CommitType -> LByteString -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit LByteString
ubs
                Maybe GitObjType
ops -> String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> String -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. (a -> b) -> a -> b
$ String
"Uniq BS of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GitPath 'Commit -> String
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not commit but " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe GitObjType -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe GitObjType
ops


extractCommit :: PhoenixExtractM m => GitPath Commit -> m ()
extractCommit :: forall (m :: * -> *). PhoenixExtractM m => GitPath 'Commit -> m ()
extractCommit GitPath 'Commit
ohp = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO $(trIo "/ohp")
  (mParHash, treeHash) <- GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall (m :: * -> *).
PhoenixExtractM m =>
GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
readCommitObject GitPath 'Commit
ohp
  extractTree $ $(tw "/") treeHash
  mapM_ extractCommit mParHash

extractCommitChainAsRepo :: PhoenixExtractM m => Tagged ShaPrefix String -> m ()
extractCommitChainAsRepo :: forall (m :: * -> *).
PhoenixExtractM m =>
Tagged ShaPrefix String -> m ()
extractCommitChainAsRepo (Tagged String
rootCommit) = do
  (Tagged udr) <- (PhoenixExtractConf -> Tagged InDir String)
-> m (Tagged InDir String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged InDir String
uberDir
  completePath (udr </> (toFp $ shaToPath rootCommit)) >>= \case
    [String
up] -> do
      gitDir <- Tagged OutDir String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged OutDir String -> String)
-> m (Tagged OutDir String) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PhoenixExtractConf -> Tagged OutDir String)
-> m (Tagged OutDir String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged OutDir String
destGitDir
      initGitRepo gitDir
      let uc = String -> GitPath 'Commit
forall (a :: GitObjTypeG). String -> GitPath a
GitPath (String -> GitPath 'Commit)
-> (String -> String) -> String -> GitPath 'Commit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. $(tw "/udr up") (String -> GitPath 'Commit) -> String -> GitPath 'Commit
forall a b. (a -> b) -> a -> b
$ String -> String -> String
makeRelative String
udr String
up
      extractCommit uc
      withBinaryFile
        (gitDir </> ".git" </> "refs" </> "heads" </> "master")
        WriteMode
        (`hPut` toCommitSha uc)
    [] -> String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"No commit matching prefix: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall b a. (Show a, IsString b) => a -> b
show String
rootCommit
    [String]
ambiP -> String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Commit prefix is ambioguous:\n " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
ambiP

completePath :: MonadUnliftIO m => FilePath -> m [FilePath]
completePath :: forall (m :: * -> *). MonadUnliftIO m => String -> m [String]
completePath String
fp = do
  m Bool -> m [String] -> m [String] -> m [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
fp) ([String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
fp]) (m [String] -> m [String]) -> m [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ do
    m Bool -> m [String] -> m [String] -> m [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
fp)
      (String -> ([String] -> [String]) -> m [String]
forall {m :: * -> *}.
MonadIO m =>
String -> ([String] -> [String]) -> m [String]
completeNonEmptyDir String
fp [String] -> [String]
forall a. a -> a
id) (m [String] -> m [String]) -> m [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ do
        case String -> (String, String)
splitFileName String
fp of
          (String
dp, String
fpre) ->
            String -> ([String] -> [String]) -> m [String]
forall {m :: * -> *}.
MonadIO m =>
String -> ([String] -> [String]) -> m [String]
completeNonEmptyDir String
dp ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
fpre String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
  where
    completeNonEmptyDir :: String -> ([String] -> [String]) -> m [String]
completeNonEmptyDir String
dp [String] -> [String]
fnf =
      String -> m [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
listDirectory String
dp m [String] -> ([String] -> m [String]) -> m [String]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case [] -> [String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
dp] ; [String]
o -> [String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
dp String -> String -> String
</>) [String]
o) ([String] -> m [String])
-> ([String] -> [String]) -> [String] -> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
fnf