git-phoenix (empty) → 0.0.1
raw patch · 26 files changed
+1790/−0 lines, 26 filesdep +QuickCheckdep +basedep +binary
Dependencies added: QuickCheck, base, binary, bytestring, conduit, containers, cryptohash-sha1, deepseq, directory, extra, filepath, git-phoenix, lens, memory, optparse-applicative, pretty-hex, regex-tdfa, relude, tagged, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, template-haskell, time, trace-embrace, unliftio, wl-pprint-text, word8, zlib
Files
- app/GitPhoenix.hs +8/−0
- changelog.md +4/−0
- git-phoenix.cabal +243/−0
- src/Data/Git/Phoenix.hs +34/−0
- src/Data/Git/Phoenix/App.hs +47/−0
- src/Data/Git/Phoenix/CmdArgs.hs +147/−0
- src/Data/Git/Phoenix/CmdRun.hs +30/−0
- src/Data/Git/Phoenix/Commit.hs +61/−0
- src/Data/Git/Phoenix/CommitSearch.hs +116/−0
- src/Data/Git/Phoenix/Extraction.hs +83/−0
- src/Data/Git/Phoenix/HeadsDiscovery.hs +121/−0
- src/Data/Git/Phoenix/Io.hs +75/−0
- src/Data/Git/Phoenix/Object.hs +46/−0
- src/Data/Git/Phoenix/Prelude.hs +33/−0
- src/Data/Git/Phoenix/Pretty.hs +67/−0
- src/Data/Git/Phoenix/Repo.hs +25/−0
- src/Data/Git/Phoenix/Sha.hs +67/−0
- src/Data/Git/Phoenix/ShaCollision.hs +69/−0
- src/Data/Git/Phoenix/Tree.hs +134/−0
- src/Data/Git/Phoenix/Uber.hs +134/−0
- test/Data/Git/Phoenix/Test.hs +78/−0
- test/Data/Git/Phoenix/Test/UberCommitSearch.hs +85/−0
- test/Data/Git/Phoenix/Test/UberExtract.hs +23/−0
- test/Data/Git/Phoenix/Test/UberHeadsDiscovery.hs +46/−0
- test/Discovery.hs +1/−0
- test/Driver.hs +13/−0
+ app/GitPhoenix.hs view
@@ -0,0 +1,8 @@+module Main where++import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.CmdRun+import Data.Git.Phoenix.Prelude++main :: IO ()+main = execWithArgs runCmd
+ changelog.md view
@@ -0,0 +1,4 @@+# git-phoenix changelog++## Version 0.0.1 2025-06-28+ * init
+ git-phoenix.cabal view
@@ -0,0 +1,243 @@+cabal-version: 3.0+name: git-phoenix+version: 0.0.1++synopsis: Recover Git repositories from disk recovery tool output (photorec)+description:+ This is a command line tool for recovery Git repositories after+ accidental removal or file system failure.+ + == Motivation+ #motivation#+ + The tool is started as a practical attempt to retrieve a few unpublished+ repositories from an EXT4 disk, with hundreds of other repos including+ very big ones (nixpkgs, Linux kernel, GHC), played a role of haystack+ here.+ + EXT4 has tools, such as extundelete and ext4magic, but they didn’t+ succeed in that case. So I switched to more primitive tool (photorec),+ producing independent files with arbitrary names, based on magic headers+ and other content heuristics, specific to particular format, and luck+ that files take sequencial disk blocks. The tool did the job, but+ requried magic tuning, because by default GIT object files are skipped.+ Rescued git files usually were bigger than compressed content and had+ trailing trash bytes.+ + == Getting input with photorec+ #getting-input-with-photorec#+ + git-phoenix need input produced by photorec or similar tool. To make+ photorec recognize the zlib file format put following config into+ @~\/.photorec.sig@ on livecd. I used system-rescue distributive.+ + > go1 0 0x7801+ > go2 0 0x78DA+ > go3 0 0x789C+ + Launch photorec without arguments - it has ncurses terminal UI.+ + photorec output looks like:+ + > $ tree /paranoid-no-brutforce-nonexpert-nocorrupted-zlib/+ > |-- recup_dir.1+ > | |-- f0305926.go1+ > | |-- f0378540.go1+ > | |-- f0421825.go1+ > ...+ > |-- recup_dir.1055+ > ...+ > |-- f167043017.go1+ > `-- f167043025.go1+ > $+ + == Building+ #building#+ + The easiest way to build the project is to use nix.+ + > $ nix-build+ > $ ./result/bin/git-phoenix --help+ + == git-phoenix recovery steps+ #git-phoenix-recovery-steps#+ + git-phoenix sunny day scenario assumes execution of several commands to+ get GIT repo from photorec output.+ + === Step 1. Building uber repo+ #step-1.-building-uber-repo#+ + Uber repo is a folder with structure equal to @.git\/objects@ but+ instead of regular files symlinks point to files in photorec structure.+ + > $ git-phoenix uber -o uber -i /paranoid-no-brutforce-nonexpert-nocorrupted-zlib/+ > Duration: 45.71s+ > Found: 423254+ > Speed: 9260.03 files per second+ > Maximum number of SHA collisions: 17+ > $+ + Uber command picks valid GIT objects and mitigates SHA collisions, which+ is pretty common in this situation.+ + === Step 2. Discovery HEAD commit+ #step-2.-discovery-head-commit#+ + This step is optional if you managed to recover reflog by simply+ grepping commit comment just pick the latest hash from there.+ + Command prints SHAs of consistent commit chains i.e. ending with a+ commit without parent.+ + > $ git-phoenix heads -a '^John' -u uber+ > 7768eed9387ff 1970-01-01 00:00 John Doe Big Bang+ + Arbitrary commit can be filter in uber repo too:+ + > $ git-phoenix search --days-before 0 --days-after 9 -a '^John' -u uber+ > 7768eed9387ff 1970-01-01 00:00 John Doe Big Bang+ + === Step 3. Real GIT repo extraction+ #step-3.-real-git-repo-extraction#+ + Uber repo should contain all required files, but it is not a valid GIT+ repo. GIT thoroughly checks object files and complains about any+ trailing trash. Extraction creates GIT repo with master branch referring+ specified commit, chopping off trailing trash and disambiguating SHAs.+ + > $ git-phoenix extract -g my-foo -u uber -s 7768eed9387ff+ > $ git -C my-foo reset+ > $ git -C my-foo checkout .+ > $ echo Woo-Hah+ + == Development environment+ #development-environment#+ + == Building+ #building-1#+ + HLS should be available inside dev env.+ + > $ nix-shell+ > $ emacs src/Data/Git/Phoenix.hs &+ > $ cabal build+ > $ cabal test+ + == Static linking+ #static-linking#+ + Static is not enabled by default, because GitHub CI job times out.+ + > nix-build --arg staticBuild true++homepage: http://github.com/yaitskov/git-phoenix+license: BSD-3-Clause+author: Daniil Iaitskov+maintainer: dyaitskov@gmail.com+copyright: Daniil Iaitkov 2025+category: System+build-type: Simple+bug-reports: https://github.com/yaitskov/git-phoenix/issues+extra-doc-files:+ changelog.md+tested-with:+ GHC == 9.12.2++source-repository head+ type:+ git+ location:+ https://github.com/yaitskov/git-phoenix.git++common base+ default-language: GHC2024+ ghc-options: -Wall+ default-extensions:+ DefaultSignatures+ NoImplicitPrelude+ OverloadedStrings+ TemplateHaskell+ build-depends:+ base >=4.7 && < 5+ , bytestring >= 0.12.1 && < 1+ , directory < 2+ , optparse-applicative < 1+ , relude >= 1.2.2 && < 2+ , tagged < 1+ , unliftio < 1++library+ import: base+ hs-source-dirs: src+ exposed-modules:+ Data.Git.Phoenix+ Data.Git.Phoenix.App+ Data.Git.Phoenix.CmdArgs+ Data.Git.Phoenix.CmdRun+ Data.Git.Phoenix.Commit+ Data.Git.Phoenix.CommitSearch+ Data.Git.Phoenix.Extraction+ Data.Git.Phoenix.HeadsDiscovery+ Data.Git.Phoenix.Io+ Data.Git.Phoenix.Object+ Data.Git.Phoenix.Prelude+ Data.Git.Phoenix.Pretty+ Data.Git.Phoenix.Repo+ Data.Git.Phoenix.Sha+ Data.Git.Phoenix.ShaCollision+ Data.Git.Phoenix.Tree+ Data.Git.Phoenix.Uber+ other-modules:+ Paths_git_phoenix+ autogen-modules:+ Paths_git_phoenix+ build-depends:+ , base < 5+ , binary < 1+ , conduit < 2+ , containers < 1+ , cryptohash-sha1 < 1+ , deepseq < 2+ , extra < 2+ , filepath < 2+ , lens < 6+ , memory < 1+ , pretty-hex < 2+ , regex-tdfa < 2+ , template-haskell < 3+ , time < 2+ , trace-embrace >= 1.2.0 && < 2+ , wl-pprint-text < 2+ , word8 < 1+ , zlib < 1++test-suite test+ import: base+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ Data.Git.Phoenix.Test+ Data.Git.Phoenix.Test.UberCommitSearch+ Data.Git.Phoenix.Test.UberExtract+ Data.Git.Phoenix.Test.UberHeadsDiscovery+ Discovery+ hs-source-dirs:+ test+ ghc-options: -Wall -rtsopts -threaded -main-is Driver+ build-depends:+ , git-phoenix+ , QuickCheck+ , tasty+ , tasty-discover+ , tasty-hunit+ , tasty-quickcheck+ , time++executable git-phoenix+ import: base+ ghc-options: -Wall -threaded -with-rtsopts=-N+ main-is: GitPhoenix.hs+ hs-source-dirs: app+ build-depends:+ , git-phoenix
+ src/Data/Git/Phoenix.hs view
@@ -0,0 +1,34 @@+module Data.Git.Phoenix where++-- import Codec.Compression.Zlib qualified as Z+-- import Conduit ( MonadUnliftIO, MonadResource, ConduitT+-- , foldMC, mapMC, concatC, sourceDirectoryDeep)+-- import Data.ByteString.Lazy qualified as L+-- import Data.ByteString qualified as BS+-- import Data.Conduit (runConduitRes, (.|))+-- import Data.Digest.Pure.SHA (Digest, SHA1State, showDigest, sha1)+-- import Data.Git.Phoenix.CmdArgs (InDir, OutDir)+-- import Data.List qualified as I+-- import Data.Map.Strict qualified as M+-- import Data.Tagged (Tagged (..), untag)+-- -- import Hexdump (simpleHex)+-- import Relude+-- import System.FilePath ((</>), dropFileName)+-- import UnliftIO.Exception qualified as U+-- import UnliftIO.QSem qualified as U+-- import UnliftIO.IO qualified as U+-- import UnliftIO.Directory qualified as U++-- blobPath :: FilePath+-- blobPath = "/home/dan/pro/git-phoenix/.git/objects/04/327561a0005dc9ac2742e88ff4d059bf122ca2"+-- foo :: IO ()+-- foo = do+-- print . showDigest . sha1 . Z.decompress . (<> "aoeu") =<< L.readFile blobPath+-- print . L.take 42 . Z.decompress . L.take 48 =<< L.readFile blobPath+-- print $ simpleHex $ toStrict $ Z.compressWith+-- (Z.defaultCompressParams { Z.compressLevel = Z.CompressionLevel 0 })+-- "Hello World"+-- print . Z.decompress . (<> "aoeu") =<< L.readFile blobPath+-- print . simpleHex . toStrict =<< L.readFile blobPath+-- print $ simpleHex $ toStrict $ Z.compress "Hello World"+-- print . Z.decompress $ Z.compress "Hello World"
+ src/Data/Git/Phoenix/App.hs view
@@ -0,0 +1,47 @@+-- {-# LANGUAGE UndecidableInstances #-}+module Data.Git.Phoenix.App where++import Conduit (MonadUnliftIO, MonadResource)+import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.Io+import Data.Tagged (Tagged)+import Relude+import UnliftIO.QSem qualified as U++type PhoenixM m = (HasCallStack, MonadUnliftIO m, MonadFail m, HasInHandlesSem m)++data PhoenixUberConf+ = PhoenixUberConf+ { destObjectDir :: Tagged OutDir FilePath+ , inHandlesSem :: U.QSem+ }++instance HasInHandlesSem (ReaderT PhoenixUberConf IO) where+ getInHandlesSem = asks inHandlesSem++type PhoenixUberM m = (PhoenixM m, MonadReader PhoenixUberConf m)++data PhoenixExtractConf+ = PhoenixExtractConf+ { destGitDir :: Tagged OutDir FilePath+ , uberDir :: Tagged InDir FilePath+ , inHandlesSem' :: U.QSem+ }++type PhoenixExtractM m = (PhoenixM m, MonadReader PhoenixExtractConf m)++instance HasInHandlesSem (ReaderT PhoenixExtractConf IO) where+ getInHandlesSem = asks inHandlesSem'++data PhoenixSearchConf+ = PhoenixSearchConf+ { uberRepoDir :: Tagged InDir FilePath+ , inHandlesSem'' :: U.QSem+ }++type PhoenixSearchM m = (PhoenixM m, MonadReader PhoenixSearchConf m)++instance HasInHandlesSem (ReaderT PhoenixSearchConf IO) where+ getInHandlesSem = asks inHandlesSem''++type PhoenixCoCon m = (PhoenixM m, MonadResource m)
+ src/Data/Git/Phoenix/CmdArgs.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DuplicateRecordFields #-}+module Data.Git.Phoenix.CmdArgs where++import Data.Char (toLower)+import Data.Tagged (Tagged (..))+import Data.Time.Clock+import Data.Time.Format+import Options.Applicative+import Relude+import System.FilePath ((</>))+import System.IO.Unsafe+import Text.Regex.TDFA++data InDir+data OutDir+data ShaPrefix+data DaysAfter+data DaysBefore++data SearchCommitBy+ = SearchCommitBy2+ { author :: String+ , daysBefore :: Tagged DaysBefore Int+ , uberRepoDir :: Tagged InDir FilePath+ , daysAfter :: Tagged DaysAfter Int+ }+ deriving (Show, Eq)++data HeadsDiscovery+ = HeadsDiscovery2+ { author :: String+ , uberRepoDir :: Tagged InDir FilePath+ }+ deriving (Show, Eq)++data CmdArgs+ = BuildUberRepo+ { inDir :: Tagged InDir FilePath+ , outDir :: Tagged OutDir FilePath+ }+ | ExtractCommitTreeAsGitRepo+ { rootCommit :: Tagged ShaPrefix String+ , uberRepoDir :: Tagged InDir FilePath+ , gitRepoOut :: Tagged OutDir FilePath+ }+ | SearchCommitBy SearchCommitBy+ | HeadsDiscovery HeadsDiscovery+ | GitPhoenixVersion+ deriving (Show, Eq)++execWithArgs :: MonadIO m => (CmdArgs -> m a) -> m a+execWithArgs a = a =<< liftIO (execParser $ info (cmdp <**> helper) phelp)+ where+ authorP =+ strOption (long "author" <> short 'a' <> value "." <>+ help "Regex pattern of commit's author")+ uberP = BuildUberRepo <$> inputDirOp <*> outputDirOp+ extractP = ExtractCommitTreeAsGitRepo <$> shaP <*> inUberDirOp <*> gitOutDirOp+ headsDiscoveryP = HeadsDiscovery <$> (HeadsDiscovery2 <$> authorP <*> inUberDirOp)+ searchP =+ SearchCommitBy <$>+ (SearchCommitBy2+ <$> authorP+ <*> (Tagged <$> option auto (long "days-before" <> short 'b' <> showDefault <> value 0+ <> help "Exclude commits older than N days"))+ <*> inUberDirOp+ <*> (Tagged <$> option auto (long "days-after" <> short 'f' <> showDefault <> value 180+ <> help "Exclude commits newer than N days")))+ cmdp =+ hsubparser+ ( command "uber"+ (infoP uberP $+ "discovers GIT object files in disk recovery tool output and " <>+ "puts symlinks to them in a folder (uber repo)")+ <> command "extract"+ (infoP extractP "clone GIT repository with root commit sha")+ <> command "heads"+ (infoP headsDiscoveryP "discover commits without descendants")+ <> command "version"+ (infoP (pure GitPhoenixVersion) "print program version")+ <> command "search"+ (infoP searchP "find commit in the uber repo"))++ infoP p h = info p (progDesc h <> fullDesc)+ phelp =+ progDesc+ "git-phoenix reconstructs GIT repositories from output of a disk recovery tool"++defaultOutputDir :: IO FilePath+defaultOutputDir =+ formatTime defaultTimeLocale "git-phoenix-objects-%F_%H_%M_%S"+ <$> getCurrentTime++outputDirOp :: Parser (Tagged OutDir FilePath)+outputDirOp = Tagged <$>+ strOption+ ( long "output"+ <> short 'o'+ <> showDefault+ <> value ("." </> unsafePerformIO defaultOutputDir)+ <> help ( "Path to objects folder of an uber GIT repo containing " <>+ "all discovered GIT objects. Default name is timestamp. " <>+ "Default path is current folder.")+ <> metavar "OUTDIR"+ )++gitOutDirOp :: Parser (Tagged OutDir FilePath)+gitOutDirOp = Tagged <$>+ strOption+ ( long "git-repo"+ <> short 'g'+ <> help "Path to output GIT repository"+ <> metavar "GIT-DIR"+ )++sha1PrefixRegex :: String+sha1PrefixRegex = "^[A-Fa-f0-9]+$"++shaP :: Parser (Tagged ShaPrefix String)+shaP = Tagged <$>+ option (maybeReader (\s -> if (s =~ sha1PrefixRegex) :: Bool+ then Just $ fmap toLower s+ else Nothing))+ ( long "sha-prefix"+ <> short 's'+ <> help "unique SHA1 prefix of commit tree root in hexdecimal form"+ <> metavar "SHA1"+ )++inUberDirOp :: Parser (Tagged InDir FilePath)+inUberDirOp = Tagged <$>+ strOption+ ( long "uber-dir"+ <> short 'u'+ <> help "Path to uber dir with discovered GIT objects"+ <> metavar "UBER-DIR"+ )++inputDirOp :: Parser (Tagged InDir FilePath)+inputDirOp = Tagged <$>+ strOption+ ( long "input"+ <> short 'i'+ <> help ( "Path to a folder with files produced by a disk recovery tool. " <>+ "e.g. photorec (testdisk). File names and locations do not matter.")+ <> metavar "PHOTOREC-OUTPUT-DIR"+ )
+ src/Data/Git/Phoenix/CmdRun.hs view
@@ -0,0 +1,30 @@+module Data.Git.Phoenix.CmdRun where++import Data.Git.Phoenix.App+import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.CommitSearch as CS+import Data.Git.Phoenix.HeadsDiscovery as HD+import Data.Git.Phoenix.Extraction+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Pretty+import Data.Git.Phoenix.Uber+import Data.Version (showVersion)+import Paths_git_phoenix++runCmd :: CmdArgs -> IO ()+runCmd = \case+ BuildUberRepo { inDir, outDir } -> do+ createDirectory $ untag outDir+ s <- newQSem =<< getNumCapabilities+ runReaderT (recoverFrom inDir) (PhoenixUberConf outDir s)+ ExtractCommitTreeAsGitRepo { rootCommit, uberRepoDir, gitRepoOut } -> do+ s <- newQSem . $(tw "numCapabilities/") =<< getNumCapabilities+ runReaderT+ (extractCommitChainAsRepo rootCommit)+ (PhoenixExtractConf gitRepoOut uberRepoDir s)+ SearchCommitBy scb ->+ runCommitSearch scb >>= printDoc . CS.commitObjectsToDoc+ HeadsDiscovery ctx ->+ runHeadsDiscovery ctx >>= printDoc . HD.commitObjectsToDoc+ GitPhoenixVersion ->+ printDoc $ "Version" <+> doc (showVersion version) <> linebreak
+ src/Data/Git/Phoenix/Commit.hs view
@@ -0,0 +1,61 @@+module Data.Git.Phoenix.Commit where++import Data.ByteString.Lazy qualified as L+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+-- import Data.Time.Format.Internal+import Data.Word8 qualified as W+import Relude++type LbsPair = (LByteString, LByteString)++extractField ::+ Word8 -> LByteString -> (LByteString -> LbsPair) -> LByteString -> LbsPair+extractField b field parseValue bs =+ case L.dropWhile (/= b) bs of+ "" -> ("", "")+ bs' ->+ if field `L.isPrefixOf` bs'+ then parseValue $ L.drop (L.length field) bs'+ else extractField b field parseValue $ L.drop 1 bs'++extractParent :: L.ByteString -> LbsPair+extractParent =+ extractField W._lf "\nparent " (L.span W.isHexDigit)++extractAuthor :: LByteString -> LbsPair+extractAuthor =+ extractField W._lf "\nauthor " (L.span (/= W._less))++extractCommitTs :: LByteString -> Maybe (Int64, LByteString)+extractCommitTs bs =+ case extractField W._greater "> " (L.span (/= W._lf)) bs of+ (tsBs, bs') ->+ case L8.readInt64 tsBs of+ Nothing -> Nothing+ Just (epoch', spcTzBs) ->+ case L8.readInt64 $ L.dropWhile W.isSpace spcTzBs of+ Nothing -> Nothing+ Just (tz, _) ->+ let+ tzAbs = abs tz+ (tzH, tzM) = tzAbs `divMod` 100+ in+ Just (epoch' + (tzH * 3600 + tzM * 60) * signum tz, bs')++extractMessage :: LByteString -> LByteString+extractMessage bs =+ case extractField W._lf "\n\n" (L.span (/= W._lf)) bs of+ (msgFirstLine, _) -> msgFirstLine++extractTreeHash :: LByteString -> LbsPair+extractTreeHash =+ extractField 0 "\0tree " (L.span W.isHexDigit)++epoch :: UTCTime+epoch = posixSecondsToUTCTime 0+{-# INLINE epoch #-}++secondsToUtcTime :: Integer -> UTCTime+secondsToUtcTime x = addUTCTime (realToFrac $ picosecondsToDiffTime (x * 1000000000000)) epoch
+ src/Data/Git/Phoenix/CommitSearch.hs view
@@ -0,0 +1,116 @@+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+ { message :: LByteString+ , sha :: LByteString+ , commitTs :: Int64+ , author :: LByteString+ } deriving (Eq, Show, Generic)++instance NFData CommitObject++readCommitObject :: forall m . PhoenixSearchM m => FilePath -> m [CommitObject]+readCommitObject = 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 bs =+ case extractAuthor bs of+ ("", _) -> pure []+ (author, bs') ->+ case extractCommitTs bs' of+ Nothing -> pure []+ Just (commitTs, bs'') ->+ case extractMessage bs'' of+ message ->+ let sha = gitPath2Bs . shaToPath . showDigest $ sha1 bs in+ pure [CommitObject {message, sha, commitTs, author}]+++ go :: FilePath -> m [CommitObject]+ go absGop = do+ lr <- withCompressedH absGop $ \cbs bs ->+ case classifyGitObject bs of+ Just BlobType -> pure $ Right []+ Just TreeType -> pure $ Right []+ Just CommitType -> Right <$> goCommit bs+ Just CollidedHash -> pure $ Left cbs+ Nothing -> pure $ Right []+ case lr of+ Right cmt -> pure cmt+ Left cbs -> do+ disLinks <- disambiguateByPair CommitType . fmap C8.unpack $ parseFileLinks cbs+ concat <$> mapM go disLinks++parseGitObject :: PhoenixSearchM m =>+ Regex ->+ Tagged DaysAfter Int64 ->+ Tagged DaysBefore Int64 ->+ FilePath ->+ m [CommitObject]+parseGitObject authorRegex (Tagged epochSecondsAfter) (Tagged epochSecondsBefore) fp =+ filter commitPredicate <$> readCommitObject fp+ where+ commitPredicate co =+ case execute authorRegex (Data.Git.Phoenix.CommitSearch.author co) of+ Right (Just _) ->+ commitTs co >= epochSecondsAfter && commitTs co <= epochSecondsBefore+ Right _ -> False+ Left _ -> False++dedupOrderedList :: Eq a => [a] -> [a]+dedupOrderedList = fmap head . groupWith id++searchCommit :: PhoenixSearchM m =>+ String -> Tagged DaysAfter Int -> Tagged DaysBefore Int -> m [CommitObject]+searchCommit authorPat daysAfter daysBefore = do+ (Tagged udr) <- asks A.uberRepoDir+ now <- liftIO (systemSeconds <$> getSystemTime)+ let daysToEpochSecs :: forall x. Tagged x Int -> Tagged x Int64+ daysToEpochSecs = fmap ((now -) . (* 86400)) . fromIntegral+ case compile defaultCompOpt (ExecOption False) $ C8.pack authorPat of+ Left e -> fail $ "Invalid author regex pattern due: " <> e+ Right authorRePat ->+ dedupOrderedList . sortOn commitTs <$> runConduitRes+ ( sourceDirectoryDeep False udr+ .| mapMC (parseGitObject authorRePat+ (daysToEpochSecs daysAfter)+ (daysToEpochSecs daysBefore))+ .| foldMC (\l a -> pure $ a <> l) []+ )++commitObjectsToDoc :: [CommitObject] -> Doc+commitObjectsToDoc = \case+ [] -> mempty+ o -> vcat (fmap formatCommit o) <> linebreak++runCommitSearch :: SearchCommitBy -> IO [CommitObject]+runCommitSearch SearchCommitBy2 { author, daysBefore, uberRepoDir, daysAfter } = do+ s <- newQSem =<< liftIO getNumCapabilities+ runReaderT+ (searchCommit author daysAfter daysBefore)+ (PhoenixSearchConf uberRepoDir s)++formatCommit :: CommitObject -> Doc+formatCommit co = hsep+ [ take 8 (binSha2Str (sha co))+ , formatTime defaultTimeLocale "%Y-%m-%d %H:%M" (secondsToUtcTime . fromIntegral $ commitTs co)+ , C8.unpack (Data.Git.Phoenix.CommitSearch.author co)+ , take 60 (C8.unpack (message co))+ ]
+ src/Data/Git/Phoenix/Extraction.hs view
@@ -0,0 +1,83 @@+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 gop = go . (</> toFp gop) . untag =<< asks uberDir+ where+ goCommit bs =+ case extractTreeHash $ $(tr "eee/bs") bs of+ ("", _) -> fail $ show gop <> " does not have tree field"+ (treeComit, bs') -> do+ gitDir <- untag <$> asks destGitDir+ saveCompressedBs+ (gitDir </> ".git" </> "objects" </> toFp gop)+ bs+ case extractParent bs' of+ ("", _) -> pure (Nothing, shaToPath $ L8.unpack treeComit)+ (!ph, _) -> pure ( Just . shaToPath $ L8.unpack ph+ , $(tr "/treeComit") . shaToPath $ L8.unpack treeComit+ )+ go absGop = do+ lr <- withCompressedH absGop $ \cbs bs ->+ case classifyGitObject bs of+ Just BlobType -> fail $ show gop <> " is Git blob but expected Git commit"+ Just TreeType -> fail $ show gop <> " is Git tree but expected Git commit"+ Just CommitType -> Right <$> goCommit bs+ Just CollidedHash -> pure $ Left cbs+ Nothing -> fail $ show gop <> " is not a Git commit object"+ case lr of+ Right cmt -> pure cmt+ Left cbs -> do+ uniPath <- uniqBs gop cbs CommitType+ withCompressed uniPath $ \ubs ->+ case classifyGitObject ubs of+ Just CommitType -> goCommit ubs+ ops -> fail $ "Uniq BS of " <> show gop <> " is not commit but " <> show ops+++extractCommit :: PhoenixExtractM m => GitPath Commit -> m ()+extractCommit ohp = do+ liftIO $(trIo "/ohp")+ (mParHash, treeHash) <- readCommitObject ohp+ extractTree $ $(tw "/") treeHash+ mapM_ extractCommit mParHash++extractCommitChainAsRepo :: PhoenixExtractM m => Tagged ShaPrefix String -> m ()+extractCommitChainAsRepo (Tagged rootCommit) = do+ (Tagged udr) <- asks uberDir+ completePath (udr </> (toFp $ shaToPath rootCommit)) >>= \case+ [up] -> do+ gitDir <- untag <$> asks destGitDir+ initGitRepo gitDir+ let uc = GitPath . $(tw "/udr up") $ makeRelative udr up+ extractCommit uc+ withBinaryFile+ (gitDir </> ".git" </> "refs" </> "heads" </> "master")+ WriteMode+ (`hPut` toCommitSha uc)+ [] -> fail $ "No commit matching prefix: " <> show rootCommit+ ambiP -> fail $ "Commit prefix is ambioguous:\n " <> intercalate "\n" ambiP++completePath :: MonadUnliftIO m => FilePath -> m [FilePath]+completePath fp = do+ ifM (doesFileExist fp) (pure [fp]) $ do+ ifM (doesDirectoryExist fp)+ (completeNonEmptyDir fp id) $ do+ case splitFileName fp of+ (dp, fpre) ->+ completeNonEmptyDir dp (filter (fpre `isPrefixOf`))+ where+ completeNonEmptyDir dp fnf =+ listDirectory dp >>= (\case [] -> pure [dp] ; o -> pure $ fmap (dp </>) o) . fnf
+ src/Data/Git/Phoenix/HeadsDiscovery.hs view
@@ -0,0 +1,121 @@+-- | 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+ { message :: LByteString+ , commitTs :: Int64+ , comAuthor :: LByteString+ , parent :: Maybe LByteString+ } deriving (Eq, Show, Generic)++instance NFData CommitObject++type ShaBs = LByteString++readCommitObject :: forall m . PhoenixSearchM m => FilePath -> m [(ShaBs, CommitObject)]+readCommitObject gop =+ case cutGitPath gop of+ Nothing -> pure []+ Just gp -> fmap (gp,) <$> go gop+ where+ orphanCommit parent bs =+ case extractAuthor bs of+ ("", _) -> pure []+ (comAuthor, bs') ->+ case extractCommitTs bs' of+ Nothing -> pure []+ Just (commitTs, bs'') ->+ case extractMessage bs'' of+ message ->+ pure [CommitObject {message, commitTs, comAuthor, parent}]++ goCommit bs =+ case extractParent bs of+ ("", bs') -> orphanCommit Nothing bs'+ (parent, bs') -> orphanCommit (Just $ hexToBin parent) bs'++ go :: FilePath -> m [CommitObject]+ go absGop = do+ lr <- withCompressedH absGop $ \cbs bs ->+ case classifyGitObject bs of+ Just BlobType -> pure $ Right []+ Just TreeType -> pure $ Right []+ Just CommitType -> Right <$> goCommit bs+ Just CollidedHash -> pure $ Left cbs+ Nothing -> pure $ Right []+ case lr of+ Right cmt -> pure cmt+ Left cbs -> do+ disLinks <- disambiguateByPair CommitType . fmap C8.unpack $ parseFileLinks cbs+ concat <$> mapM go disLinks++loadCommitMap :: PhoenixSearchM m => m (M.Map ShaBs CommitObject)+loadCommitMap = do+ (Tagged udr) <- asks A.uberRepoDir+ runConduitRes+ ( sourceDirectoryDeep False udr+ .| mapMC readCommitObject+ .| concatC+ .| foldMC (\m (k, c) -> pure $ M.insert k c m) mempty+ )++doesMatch :: Regex -> LByteString -> Bool+doesMatch rxPat bs =+ case execute rxPat bs of+ Right (Just _) -> True+ Right _ -> False+ Left _ -> False++discoverHeads :: PhoenixSearchM m => String -> m [(ShaBs, CommitObject)]+discoverHeads authorPat = do+ case compile defaultCompOpt (ExecOption False) $ C8.pack authorPat of+ Left e -> fail $ "Invalid author regex pattern due: " <> e+ Right authorRePat -> do+ cm <- loadCommitMap+ let parentSet = S.fromList . catMaybes . fmap parent $ M.elems cm+ unreachable m k (v :: CommitObject) =+ if (k `S.member` parentSet) || (not $ doesMatch authorRePat (comAuthor v))+ then m+ else M.insert k v m+ ucm = M.foldlWithKey unreachable mempty cm+ pure . sortOn (\(_, c) -> (commitTs c, comAuthor c)) $ M.toList ucm++runHeadsDiscovery :: HeadsDiscovery -> IO [(ShaBs, CommitObject)]+runHeadsDiscovery HeadsDiscovery2 { author, uberRepoDir } = do+ s <- newQSem =<< liftIO getNumCapabilities+ runReaderT+ (discoverHeads author)+ (PhoenixSearchConf uberRepoDir s)++formatCommit :: (ShaBs, CommitObject) -> Doc+formatCommit (sha, co) = hsep+ [ take 8 (binSha2Str sha)+ , formatTime+ defaultTimeLocale+ "%Y-%m-%d %H:%M"+ (secondsToUtcTime . fromIntegral $ commitTs co)+ , C8.unpack (comAuthor co)+ , take 60 (C8.unpack (message co))+ ]++commitObjectsToDoc :: [(ShaBs, CommitObject)] -> Doc+commitObjectsToDoc = \case+ [] -> mempty+ o -> vcat (fmap formatCommit o) <> linebreak
+ src/Data/Git/Phoenix/Io.hs view
@@ -0,0 +1,75 @@+module Data.Git.Phoenix.Io where++import Data.ByteString.Lazy qualified as L+import Data.ByteString qualified as BS+import Data.Git.Phoenix.Prelude+import System.IO (openBinaryFile)++class HasInHandlesSem m where+ getInHandlesSem :: m QSem++instance (Monad m, HasInHandlesSem m) => HasInHandlesSem (ResourceT m) where+ getInHandlesSem = lift getInHandlesSem++data Compressed++withHandleX :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>+ IOMode -> FilePath -> (Handle -> m a) -> m a+withHandleX mode fp a = do+ s <- getInHandlesSem+ bracket_ (waitQSem s) (signalQSem s) $+ -- withFile is not applicable because Handle might be closed twice+ -- https://github.com/haskell/bytestring/issues/707+ bracket (liftIO $ openBinaryFile fp mode)+ (\h -> whenM (hIsOpen h) $ hClose h) go+ where+ go h = do+ !r <- a h+ case rnf r of+ () -> pure r++withHandle :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>+ FilePath -> (Handle -> m a) -> m a+withHandle = withHandleX ReadMode++withCompressedH :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>+ FilePath ->+ (Tagged Compressed LByteString -> LByteString -> m a) ->+ m a+withCompressedH fp a =+ withHandle ($(tr "/fp") fp) $ \inH -> hGetContents inH >>= (\cbs -> a (Tagged cbs) $ decompress cbs)++withCompressed :: (HasCallStack, NFData a, MonadUnliftIO m, HasInHandlesSem m) =>+ FilePath -> (HasCallStack => L.ByteString -> m a) -> m a+withCompressed fp a = withCompressedH fp (\_cbs bs -> a bs)++hGet :: MonadIO m => Handle -> Int -> m ByteString+hGet h n = liftIO $ BS.hGet h n++hGetContents :: MonadIO m => Handle -> m LByteString+hGetContents h = liftIO $ L.hGetContents h++hPut :: MonadIO m => Handle -> LByteString -> m ()+hPut h bs = liftIO $ L.hPut h bs++-- | just 'copyFile' is not possible due to trash after archive+saveCompressedBs :: MonadUnliftIO m => FilePath -> LByteString -> m ()+saveCompressedBs fp bs = do+ createDirectoryIfMissing False $ dropFileName fp+ withBinaryFile ($(tr "/fp") fp) WriteMode $ \h -> hPut h $ compress bs++readNumber :: MonadIO m => Int -> Int -> m Int+readNumber minVal maxVal = go+ where+ go = do+ s <- liftIO $ getLine+ case readMaybe $ toString s of+ Just n+ | n >= minVal && n <= maxVal ->+ pure n+ | otherwise -> do+ putStrLn "Value is out of range. Try again"+ go+ Nothing -> do+ putStrLn "Value is number. Try again"+ go
+ src/Data/Git/Phoenix/Object.hs view
@@ -0,0 +1,46 @@+module Data.Git.Phoenix.Object where++import Data.Binary qualified as B+import Data.ByteString.Lazy qualified as L+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Git.Phoenix.Prelude++data GitObjType = CommitType | TreeType | BlobType | CollidedHash deriving (Show, Eq)++data GitObjTypeG = Commit | Tree deriving (Show, Eq)++-- | Path relative to .git/objects or uber dir+newtype GitPath (t :: GitObjTypeG) = GitPath { toFp :: FilePath } deriving (Show, Eq, NFData)++toCommitSha :: GitPath t -> LByteString+toCommitSha (GitPath p) = L8.pack $ filter (/= '/') p++classifyGitObject :: LByteString -> Maybe GitObjType+classifyGitObject bs+ | blob `L.isPrefixOf` bs = pure BlobType+ | tree `L.isPrefixOf` bs = pure TreeType+ | commit `L.isPrefixOf` bs = pure CommitType+ | disambiguate `L.isPrefixOf` bs = pure CollidedHash+ | otherwise = Nothing++commit, tree, blob, disambiguate :: L.ByteString+disambiguate = "disambigate "+commit = "commit "+blob = "blob "+tree = "tree "++gitObjectP :: LByteString -> Bool+gitObjectP bs =+ case classifyGitObject bs of+ Nothing -> False+ Just CollidedHash -> False+ Just _ -> True++compressedDisambiguate :: L.ByteString+compressedDisambiguate =+ compressWith+ (defaultCompressParams { compressLevel = CompressionLevel 0 })+ disambiguate++encodedIntLen :: Int64+encodedIntLen = L.length . B.encode $ L.length ""
+ src/Data/Git/Phoenix/Prelude.hs view
@@ -0,0 +1,33 @@+module Data.Git.Phoenix.Prelude (module X) where++import Control.Concurrent as X (getNumCapabilities)+import Codec.Compression.Zlib as X+ ( CompressionLevel (..), DecompressError (..)+ , CompressParams (..), DecompressParams (..)+ , compress, decompress+ , compressWith, decompressWith, defaultCompressParams+ , defaultDecompressParams+ )+import Conduit as X+ ( MonadUnliftIO, ResourceT, ConduitT, foldMC+ , mapMC, concatC, sourceDirectoryDeep+ )+import Control.DeepSeq as X+import Debug.TraceEmbrace as X hiding (a)+import Data.Conduit as X (runConduitRes, (.|))+import Data.List as X ((!?))+import Data.Tagged as X (Tagged (..), untag)+import Data.Word8 as X (isHexDigit)+import Relude as X+import System.FilePath as X ((</>), dropFileName, splitFileName, makeRelative)+import System.Time.Extra as X+import Text.Printf as X+import UnliftIO.IO as X (withBinaryFile, hIsOpen, hClose)+import UnliftIO.QSem as X (QSem, newQSem, signalQSem, waitQSem)+import UnliftIO.Exception as X (bracket, bracket_, catch)+import UnliftIO.Directory as X+ ( createFileLink, createDirectoryIfMissing+ , pathIsSymbolicLink, makeAbsolute, createDirectory+ , getSymbolicLinkTarget, removeFile, copyFile+ , doesFileExist, doesDirectoryExist, listDirectory+ )
+ src/Data/Git/Phoenix/Pretty.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Data.Git.Phoenix.Pretty+ ( doc+ , hsep+ , vsep+ , (&!)+ , ($$)+ , tab+ , printDoc+ , apNe+ , module PP+ ) where++import Data.Time ( NominalDiffTime )+import Control.Exception ( IOException )+import Relude+import Text.PrettyPrint.Leijen.Text as PP hiding+ ( (<$>), bool, group, hsep, vsep, empty, isEmpty, (</>) )+import Text.PrettyPrint.Leijen.Text qualified as PP++infixr 5 $$+($$) :: Doc -> Doc -> Doc+($$) = (<$$>)++doc :: Pretty a => a -> Doc+doc = pretty++hsep :: Pretty a => [a] -> Doc+hsep = PP.hsep . fmap doc+{-# INLINE hsep #-}++vsep :: Pretty a => [a] -> Doc+vsep = vcat . fmap doc+{-# INLINE vsep #-}++printDoc :: (MonadIO m, Pretty a) => a -> m ()+printDoc x = liftIO (putDoc $ pretty x)++tab :: Pretty a => a -> Doc+tab = nest 2 . doc++class IsEmpty a where+ isEmpty :: a -> Bool++instance IsEmpty [a] where+ isEmpty = null++apNe :: (IsEmpty a, Pretty a) => a -> (Doc -> Doc) -> Doc+apNe d f+ | isEmpty d = d'+ | otherwise = f d'+ where+ d' = doc d++(&!) :: (IsEmpty a, Pretty a) => a -> (Doc -> Doc) -> Doc+(&!) = apNe++infixl 7 &!++instance Pretty IOException where+ pretty = text . show++instance Pretty a => Pretty (Set a) where+ pretty x = "{" <+> hsep (toList x) <+> "}"++instance Pretty NominalDiffTime where+ pretty = text . show
+ src/Data/Git/Phoenix/Repo.hs view
@@ -0,0 +1,25 @@+module Data.Git.Phoenix.Repo where++import Relude+import System.Directory+import System.FilePath++initGitRepo :: MonadIO m => FilePath -> m ()+initGitRepo rp = liftIO $ do+ mapM_ createDirectory $ rp : rpGit : rpGitDirs+ mapM_ (\(fn, fc) -> writeFile (rpGit </> fn) fc)+ [ ("HEAD", "ref: refs/heads/master")+ , ( "description"+ , "Unnamed repository; edit this file 'description' to name the repository."+ )+ , ( "config"+ , "[core]\n\trepositoryformatversion = 0\n\t" <>+ "filemode = true\n\tbare = false\n\tlogallrefupdates = true\n"+ )+ ]+ where+ rpGit = rp </> ".git"+ rpGitDirs =+ fmap (rpGit </>) $ ["branches", "hooks", "info"]+ <> fmap ("objects" </>) ["", "info", "pack"]+ <> fmap ("refs" </>) ["", "heads", "tags"]
+ src/Data/Git/Phoenix/Sha.hs view
@@ -0,0 +1,67 @@+module Data.Git.Phoenix.Sha+ ( ComHash+ , hexToBin+ , shaToPath+ , binSha2Path+ , binSha2Str+ , parseSha1+ , showDigest+ , sha1+ , gitPath2Bs+ , cutGitPath+ ) where++import Crypto.Hash.SHA1 (hashlazy)+import Data.Binary qualified as B+import Data.ByteArray.Encoding (Base(Base16), convertFromBase, convertToBase)+import Data.ByteString.Char8 qualified as C+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Char (isHexDigit)+import Data.Git.Phoenix.Object+import Data.List.Extra qualified as L+import Relude++type ComHash = ByteString++sha1 :: LByteString -> ByteString+sha1 = hashlazy++showDigest :: ByteString -> String+showDigest = C.unpack . convertToBase Base16++parseSha1 :: String -> Either String ComHash+parseSha1+ h | length (filter isHexDigit h) == 40 =+ fmap (B.decode . toLazy) $ convertFromBase Base16 (C.pack h)+ | otherwise = Left $ "Failed to parse SHA1: " <> h++fromRightEr :: Either String a -> a+fromRightEr = \case+ Right a -> a+ Left e -> error $ toText e++hexToBin :: LByteString -> LByteString+hexToBin = toLazy . fromRightEr . convertFromBase Base16 . toStrict++shaToPath :: String -> GitPath a+shaToPath = \case+ a:b:r -> GitPath $ a:b:'/':r+ o -> GitPath o++binSha2Path :: LByteString -> GitPath a+binSha2Path = shaToPath . binSha2Str++binSha2Str :: LByteString -> String+binSha2Str = C.unpack . convertToBase Base16 . toStrict++gitPath2Bs :: GitPath a -> LByteString+gitPath2Bs (GitPath fp) =+ case fp of+ a:b:'/':r -> hexToBin . L8.pack $ a:b:r+ _ -> error . toText $ "Bad GitPath: " <> fp++cutGitPath :: FilePath -> Maybe LByteString+cutGitPath fp =+ case L.takeEnd 41 fp of+ a:b:'/':r -> Just . hexToBin . L8.pack $ a:b:r+ _ -> Nothing
+ src/Data/Git/Phoenix/ShaCollision.hs view
@@ -0,0 +1,69 @@+module Data.Git.Phoenix.ShaCollision where++import Data.List.NonEmpty (groupWith)+import Data.Binary qualified as B+import Data.ByteString.Lazy qualified as L+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Git.Phoenix.App+import Data.Git.Phoenix.Io+import Data.Git.Phoenix.Object+import Data.Git.Phoenix.Prelude+++disambiguateByPair :: PhoenixM m => GitObjType -> [FilePath] -> m [FilePath]+disambiguateByPair tt links =+ fmap (snd . head) . groupWith fst . sort . catMaybes <$> mapM go links+ where+ go l = do+ withCompressed l $ \bs -> do+ case classifyGitObject bs of+ Just x | x == tt -> pure $ Just (bs, l)+ | otherwise -> pure Nothing+ Nothing -> pure Nothing++uniqBs :: PhoenixExtractM m =>+ GitPath x ->+ Tagged Compressed LByteString ->+ GitObjType ->+ m FilePath+uniqBs ambiHash cbs expectedGitObjType = do+ case parseFileLinks cbs of+ [_] -> fail $ show cbs <> " is not ambiguous"+ [] -> fail $ show cbs <> " is emply list"+ links -> do+ disLinks <- disambiguateByPair expectedGitObjType $ fmap L8.unpack links+ case disLinks of+ [] -> fail $ show cbs <> " is emply list after dis"+ [a] -> pure a+ uniqLinks -> chooseOneLink uniqLinks+ where+ chooseOneLink links = do+ forM_ (zip [0 :: Int ..] links) $ \(i, l) -> putStrLn $ printf "%4d) %s" i l+ putStrLn "-----------------------------------------------------------"+ putStrLn $ "Enter link number to disambiguate SHA " <> toFp ambiHash <> " of " <> show expectedGitObjType+ i <- readNumber 0 (length links - 1)+ case links !? i of+ Nothing -> fail $ "Link index out of range: " <> show i <> " for " <> show (length links)+ Just l -> pure l++parseFileLinks :: Tagged Compressed LByteString -> [LByteString]+parseFileLinks (Tagged preCbs) = go cbs+ where+ go bs =+ case L.splitAt encodedIntLen bs of+ ("", _) -> []+ (binLen, bs') ->+ case B.decodeOrFail binLen of+ Right (_, _, fsLinkLen) ->+ case L.splitAt fsLinkLen bs' of+ (fsLinkBs, bs'')+ | L.length fsLinkBs == fsLinkLen ->+ fsLinkBs : go bs''+ | otherwise ->+ error $ "Expected link len " <> show fsLinkLen+ <> " but got " <> show (L.length fsLinkBs)+ Left e ->+ error $ "List of files with collided SHA is corrupted (error: "+ <> show e <> ") near: " <> show bs++ cbs = L.drop (L.length compressedDisambiguate) preCbs
+ src/Data/Git/Phoenix/Tree.hs view
@@ -0,0 +1,134 @@+module Data.Git.Phoenix.Tree where++import Data.ByteString.Lazy qualified as L+import Data.Git.Phoenix.App+import Data.Git.Phoenix.Object+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Sha+import Data.Git.Phoenix.ShaCollision+import Data.Git.Phoenix.Io++dropTreeHeader :: LByteString -> LByteString+dropTreeHeader = L.drop 1 . L.dropWhile (/= 0)++data DOF = Dir | File deriving (Eq, Show, Generic)++instance NFData DOF++dofToGitObjType :: DOF -> GitObjType+dofToGitObjType =+ \case+ Dir -> TreeType+ File -> BlobType++readTreeShas :: LByteString -> [(DOF, LByteString)]+readTreeShas modePrefixedBs =+ case L.uncons modePrefixedBs of+ Just (0x31, bs) -> go File bs {- '1' blob -}+ Just (0x34, bs) -> go Dir bs {- '4' tree -}+ Nothing -> []+ Just (ue, _) ->+ error $ "tree entry mode does not start with 1 nor 4: "+ <> show ue <> "\n" <> show modePrefixedBs+ where+ shaBinLen = 20+ go dof bs =+ case L.uncons $ L.dropWhile (/= 0) bs of+ Just (0, shaPrefixedBs) ->+ let (sha, bs') = L.splitAt shaBinLen shaPrefixedBs in+ (dof, sha) : readTreeShas bs'+ Just (nz, _) ->+ error $ "expected zero byte but got " <> show nz <> " in "+ <> show modePrefixedBs+ Nothing ->+ error $ "unexpected end of tree entry: " <> show modePrefixedBs++-- Type is defined to decouple reading files and handling there content.+-- Such trick minimize QSem+data NonRecursive+ = JustBlob !()+ | TreeShas ![(DOF, LByteString)]+ -- collision strict BS is not big just list of file names+ -- so it is safe to return out of lazy scope+ | Collision !(Tagged Compressed LByteString)+ deriving (Show, Eq, Generic)++instance NFData NonRecursive++parseTreeObject :: PhoenixExtractM m =>+ FilePath ->+ Tagged Compressed LByteString ->+ LByteString ->+ m (Either (Tagged Compressed LByteString) [(DOF, LByteString)])+parseTreeObject gop cbs bs =+ case classifyGitObject bs of+ Just BlobType -> fail $ gop <> " is Git blob but expected Git tree"+ Just CommitType -> fail $ gop <> " is Git commit but expected Git tree"+ Just TreeType -> do+ pure . Right . readTreeShas $ dropTreeHeader bs+ Just CollidedHash -> pure $ Left cbs+ Nothing -> fail $ gop <> " is not a Git tree object"++onRight_ :: Monad m => (b -> m ()) -> Either a b -> m (Either a b)+onRight_ f = \case+ v@(Left _) -> pure v+ r@(Right v) -> f v >> pure r++extractTree :: PhoenixExtractM m => GitPath Tree -> m ()+extractTree treeHash = do+ Tagged udr <- asks uberDir+ dd <- getDestDir+ copyTree (udr </> toFp treeHash) treeHash >>=+ mapM_ (copyTreeLinks dd) . $(tw "len/")+ where+ copyTree treePath trH = do+ let save bs = do+ destDir <- getDestDir+ saveCompressedBs (destDir </> toFp trH) bs+ rl <- withCompressedH treePath $ \cTreeBs treeBs ->+ parseTreeObject treePath cTreeBs treeBs >>= onRight_ (\_ -> save treeBs)+ shas <- case rl of+ Right shas' -> pure shas'+ Left cbs -> do+ uniPath <- uniqBs (GitPath @Tree treePath) cbs TreeType+ withCompressed uniPath+ (\ubs -> do+ save ubs+ pure . readTreeShas $ dropTreeHeader ubs+ )+ pure shas+ getDestDir = (\(Tagged r) -> r </> ".git" </> "objects") <$> asks destGitDir+ copyTreeLinks destDir (dof, binSha) = do+ (Tagged udr) <- asks uberDir+ liftIO $(trIo "/destDir binSha")+ let shaP = binSha2Path binSha+ absSha = udr </> toFp shaP+ saveBlob = saveCompressedBs (destDir </> toFp shaP)+ saveTree bs = do+ saveBlob bs+ pure . readTreeShas $ dropTreeHeader bs+ nonRec <- withCompressedH absSha $ \cbs bs ->+ case classifyGitObject bs of+ Just BlobType+ | dof == File -> JustBlob <$> saveBlob bs+ | otherwise -> fail $ absSha <> " is not a GIT blob"+ Just TreeType+ | dof == Dir -> TreeShas <$> saveTree bs+ | otherwise -> fail $ absSha <> " is not a GIT tree"+ Just CollidedHash ->+ pure $ Collision cbs+ _ -> fail $ absSha <> " is not a GIT tree nor GIT blob nor disambiguate file"+ case nonRec of+ JustBlob () -> pure ()+ TreeShas rows ->+ mapM_ (copyTreeLinks destDir) rows+ Collision cbs' -> do+ uniPath <- uniqBs shaP cbs' (dofToGitObjType dof)+ !lr <- withCompressed uniPath $ \ubs ->+ case classifyGitObject ubs of+ Just BlobType -> Left <$> saveBlob ubs+ Just TreeType -> Right <$> saveTree ubs+ _ -> fail $ absSha <> " is not GIT tree nor GIT blob"+ case lr of+ Left () -> pure ()+ Right rows -> mapM_ (copyTreeLinks destDir) rows
+ src/Data/Git/Phoenix/Uber.hs view
@@ -0,0 +1,134 @@+-- | Collect links to GIT objects under 1 directory+module Data.Git.Phoenix.Uber where++import Control.Lens ((%~), _2)+import Data.Binary qualified as B+import Data.ByteString.Lazy qualified as L+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Git.Phoenix.App+import Data.Git.Phoenix.CmdArgs (InDir)+import Data.Git.Phoenix.Io+import Data.Git.Phoenix.Object+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Sha+import Data.List qualified as I+import Data.Map.Strict qualified as M++type ShaDedupMap = M.Map ComHash Int++data GitObject+ = GitObject+ { gobHash :: !ComHash+ , gobOrigin :: !FilePath -- abs+ }+ deriving (Show, Eq, Generic)++instance NFData GitObject++gitObjectFilePath :: GitObject -> FilePath+gitObjectFilePath = uncurry (</>) . I.splitAt 2 . showDigest . gobHash++mkGitObject :: PhoenixM m => FilePath -> m (Maybe GitObject)+mkGitObject fp =+ withHandle fp $ \inH -> do+ magicBs <- hGet inH 2+ if zlibP magicBs+ then do+ (`catch` skipCorruptedFile) $ do+ headerBs <- (toLazy magicBs <>) . toLazy <$> hGet inH 510+ if gitObjectP $ decompress headerBs+ then do+ !goh <- sha1 . decompress . (headerBs <>) <$> hGetContents inH+ pure . Just $! GitObject goh fp+ else+ pure Nothing+ else pure Nothing+ where+ skipCorruptedFile (_ :: DecompressError) = do+ liftIO $ $(trIo "Skip corrupted file/fp")+ pure Nothing++ zlibNoCompression = "\x0078\x0001"+ zlibDefaultCompression = "\x0078\x009C"+ zlibBestCompression = "\x0078\x00DA"++ zlibP bs =+ zlibNoCompression == bs ||+ zlibDefaultCompression == bs ||+ zlibBestCompression == bs++findGitObjects :: PhoenixCoCon m => FilePath -> ConduitT i GitObject m ()+findGitObjects photorecOutDir =+ sourceDirectoryDeep False photorecOutDir+ .| mapMC mkGitObject+ .| concatC++alrr :: Monad m => (x -> m y) -> (x, z) -> m z+alrr f (a, !r) = f a >> pure r++replaceSymLinkWithDisambiguate :: MonadUnliftIO m => FilePath -> GitObject -> m ()+replaceSymLinkWithDisambiguate uberGob gob = do+ firstGobOrigin <- L8.pack <$> getSymbolicLinkTarget uberGob+ removeFile uberGob+ withBinaryFile uberGob WriteMode $ \oh ->+ hPut oh . mconcat $ [ compressedDisambiguate+ , B.encode $ L.length firstGobOrigin+ , firstGobOrigin+ , B.encode $ L.length gobPacked+ , gobPacked+ ]+ where+ gobPacked = L8.pack $ gobOrigin gob++appendPathToUberGob :: MonadUnliftIO m => FilePath -> GitObject -> m ()+appendPathToUberGob uberGob gob =+ withBinaryFile uberGob AppendMode $ \oh ->+ hPut oh $ gobLen <> gobPacked+ where+ gobPacked = L8.pack $ gobOrigin gob+ gobLen = B.encode $ L.length gobPacked++storeGitObject :: PhoenixUberM m => (ShaDedupMap, Int, Int) -> GitObject -> m (ShaDedupMap, Int, Int)+storeGitObject (dedupMap, !countDown, !mapSize) gob = do+ when (countDown == 0) $ do+ putStrLn $ "GIT objects found: " <> show mapSize+ -- todo: dynamic init countDown value to keep print period ~ a few seconds+ -- usb stick is slow, but SSD is fast+ (,if countDown <= 0 then 10000 else countDown - 1, mapSize + 1)+ <$> (alrr writeGitObject $ M.insertLookupWithKey (\_h -> (+)) (gobHash gob) 1 dedupMap)+ where+ gobPath = gitObjectFilePath gob+ writeGitObject = \case+ Nothing -> do+ dod <- asks $ untag . destObjectDir+ createDirectoryIfMissing False (dod </> dropFileName gobPath)+ createFileLink (gobOrigin gob) (dod </> gobPath)+ Just _dedupSuffix -> do+ dod <- asks $ untag . destObjectDir+ let uberGob = dod </> gobPath+ pathIsSymbolicLink uberGob >>= \case+ True ->+ replaceSymLinkWithDisambiguate uberGob gob+ False ->+ appendPathToUberGob uberGob gob++recoverFrom :: PhoenixUberM m => Tagged InDir FilePath -> m ()+recoverFrom (Tagged photorecOutDir) =+ duration (makeAbsolute photorecOutDir >>= go) >>= reportCollisions+ where+ go absInDir =+ (_2 %~ M.elems) . (\(m, _, objectsStored) -> (objectsStored, m)) <$>+ runConduitRes+ ( findGitObjects absInDir+ .| foldMC storeGitObject (mempty, 10, 0)+ )+ reportCollisions = \case+ (_, (_, [])) ->+ putStrLn $ "Dir [" <> photorecOutDir <> "] doesn't have Git files"+ (durSecs, (objectStored, collisions)) -> do+ putStrLn . printf "Duration: %s" $ showDuration durSecs+ putStrLn . printf "Found: %d" $ objectStored+ putStrLn . printf "Speed: %.2f files per second" $ fromIntegral objectStored / durSecs+ case I.maximum collisions of+ 1 -> pure ()+ cn -> putStrLn $ "Maximum number of SHA collisions: " <> show cn
+ test/Data/Git/Phoenix/Test.hs view
@@ -0,0 +1,78 @@+module Data.Git.Phoenix.Test where++import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as C8+import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.CmdRun+import Data.Git.Phoenix.Prelude+import Test.QuickCheck as QC+import UnliftIO.Directory+import UnliftIO.IO (hSeek, SeekMode (..))+import UnliftIO.Temporary++currentHead :: String+currentHead = "62324a152b2f9272c922571ab1e08a5212da2d65"++readBranchCommit :: FilePath -> IO String+readBranchCommit fp = C8.unpack . BS.takeWhile isHexDigit <$> BS.readFile fp++data Root+data Uber++withUber :: (Tagged Root FilePath -> Tagged Uber FilePath -> IO ()) -> IO ()+withUber doWithUberDir =+ withSystemTempDirectory "gitphoenix" $ \rdir ->+ let phOut = rdir </> "photorec-output" in do+ createDirectory phOut+ forM_ cases $ \(d, f) -> do+ let destDir = phOut </> d+ createDirectory destDir+ runConduitRes+ ( sourceDirectoryDeep False "test-git-objects"+ .| foldMC (f destDir) (0 :: Int)+ )+ let uberOut = rdir </> "uber"+ runCmd BuildUberRepo { inDir = Tagged phOut+ , outDir = Tagged uberOut+ }+ doWithUberDir (Tagged @Root rdir) (Tagged @Uber uberOut)+ where+ cases =+ [ ("trail-trash", trailTrash)+ , ("middle-trash", middleTrash)+ , ("symlinks", symlinks)+ , ("clean-copy", cleanCopy)+ ]+ markWritable fp =+ setPermissions fp . setOwnerWritable True =<< getPermissions fp+ trailTrash destDir nextFileName gitObjFp = liftIO $ do+ let destFp = destDir </> show nextFileName <> ".go1"+ copyFile gitObjFp destFp+ markWritable destFp+ withBinaryFile destFp AppendMode $ \h -> genBs >>= BS.hPut h+ pure $ nextFileName + 1+ middleTrash destDir nextFileName gitObjFp = liftIO $ do+ let destFp = destDir </> show nextFileName <> ".go1"+ copyFile gitObjFp destFp+ markWritable destFp+ withBinaryFile destFp WriteMode $ \h -> do+ hs <- fromIntegral <$> getFileSize gitObjFp+ i <- fromIntegral <$> generate (chooseInt (0, hs - 1))+ hSeek h AbsoluteSeek i+ genBs >>= BS.hPut h+ pure $ nextFileName + 1+ symlinks destDir nextFileName gitObjFp = liftIO $ do+ let destFp = destDir </> show nextFileName <> ".go1"+ (`createFileLink` destFp) =<< makeAbsolute gitObjFp+ pure $ nextFileName + 1+ cleanCopy destDir nextFileName gitObjFp = liftIO $ do+ let destFp = destDir </> show nextFileName <> ".go1"+ copyFile gitObjFp destFp+ pure $ nextFileName + 1++genBs :: MonadIO m => m ByteString+genBs = liftIO $ generate go+ where+ go = do+ s <- QC.getSize+ BS.pack <$> QC.vector (1 + s)
+ test/Data/Git/Phoenix/Test/UberCommitSearch.hs view
@@ -0,0 +1,85 @@+module Data.Git.Phoenix.Test.UberCommitSearch where++import Data.ByteString.Lazy qualified as L+import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.CommitSearch+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Test+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Clock.System+import Test.Tasty.HUnit++epoch :: UTCTime+epoch = posixSecondsToUTCTime 0+{-# INLINE epoch #-}++utcTimeToMicros :: UTCTime -> Integer+utcTimeToMicros t = diffTimeToPicoseconds (realToFrac (diffUTCTime t epoch)) `div` 1000000++utcTimeToMillis :: UTCTime -> Integer+utcTimeToMillis = (`div` 1000) . utcTimeToMicros++utcTimeToSeconds :: UTCTime -> Integer+utcTimeToSeconds = (`div` 1000) . utcTimeToMillis++unit_format_commit :: IO ()+unit_format_commit =+ assertEqual+ "gold"+ ( "00010203 2025-07-06 15:12 Daniil Iaitskov Hello\nWorld\n"+ <> "fffefdfc 2025-07-06 14:05 Iaitskov Daniil Bye\n" :: String+ )+ (show $ commitObjectsToDoc+ [ CommitObject+ { message = "Hello\nWorld\n"+ , sha = L.pack [0..19]+ , commitTs = 1751814758+ , author = "Daniil Iaitskov "+ }+ , CommitObject+ { message = "Bye"+ , sha = L.pack . take 20 $ reverse [0.. 0xFF]+ , commitTs = 1751810759+ , author = "Iaitskov Daniil "+ }+ ])++unit_uber_commit_search :: IO ()+unit_uber_commit_search = withUber go+ where+ matchingAuthor = "Daniil"+ sunny uberDir daysToLastcommit = do+ commits <- runCommitSearch $ SearchCommitBy2+ { author = matchingAuthor+ , daysBefore = Tagged $ 0 + daysToLastcommit+ , uberRepoDir = Tagged uberDir+ , daysAfter = Tagged $ 10000 + daysToLastcommit+ }+ assertEqual ("no commits matching author name") (commits == []) False+ authorMismatch uberDir daysToLastcommit = do+ commits <- runCommitSearch $ SearchCommitBy2+ { author = "^Ladiin"+ , daysBefore = Tagged $ 0 + daysToLastcommit+ , uberRepoDir = Tagged uberDir+ , daysAfter = Tagged $ 10000 + daysToLastcommit+ }+ assertEqual "author does not match" [] commits++ outOfDayRange uberDir daysToLastcommit = do+ commits <- runCommitSearch $ SearchCommitBy2+ { author = matchingAuthor+ , daysBefore = Tagged $ 20 + daysToLastcommit+ , uberRepoDir = Tagged uberDir+ , daysAfter = Tagged $ 1000 + daysToLastcommit+ }+ assertEqual ("no commits matching day range") [] commits++ go :: Tagged Root FilePath -> Tagged Uber FilePath -> IO ()+ go _rdir (Tagged uberDir) = do+ now :: Int64 <- liftIO (systemSeconds <$> getSystemTime)+ lastCommitEpoch :: Int64 <- fromIntegral . utcTimeToSeconds <$> parseTimeM False defaultTimeLocale "%Y-%m-%d" "2025-07-06"+ let daysToLastcommit :: Int = fromIntegral $ (now - lastCommitEpoch) `div` 86400+ sunny uberDir daysToLastcommit+ authorMismatch uberDir daysToLastcommit+ outOfDayRange uberDir daysToLastcommit
+ test/Data/Git/Phoenix/Test/UberExtract.hs view
@@ -0,0 +1,23 @@+module Data.Git.Phoenix.Test.UberExtract where++import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.CmdRun+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Test+import UnliftIO.Process++unit_uber_extract :: IO ()+unit_uber_extract = withUber go+ where+ go :: Tagged Root FilePath -> Tagged Uber FilePath -> IO ()+ go (Tagged rdir) (Tagged uberOut) = do+ let gitOut = rdir </> "git-phoenix"+ runCmd ExtractCommitTreeAsGitRepo { rootCommit = Tagged $ take 15 currentHead+ , uberRepoDir = Tagged uberOut+ , gitRepoOut = Tagged gitOut+ }+ callCommand $ "git -C " <> gitOut <> " fsck --full"+ gotHead <- readBranchCommit (gitOut </> ".git/refs/heads/master")+ when (gotHead /= currentHead) $ do+ fail $ "HEAD commit mismatch\nGot: [" <> gotHead+ <> "]\nExpected: [" <> currentHead <> "]"
+ test/Data/Git/Phoenix/Test/UberHeadsDiscovery.hs view
@@ -0,0 +1,46 @@+module Data.Git.Phoenix.Test.UberHeadsDiscovery where++import Data.ByteString.Lazy qualified as L+import Data.Git.Phoenix.CmdArgs+import Data.Git.Phoenix.HeadsDiscovery+import Data.Git.Phoenix.Prelude+import Data.Git.Phoenix.Test+import Test.Tasty.HUnit++unit_format_commit :: IO ()+unit_format_commit =+ assertEqual+ "gold"+ ("00010203 2025-07-06 15:12 Daniil Iaitskov Hello\nWorld\n" :: String)+ (show $ commitObjectsToDoc+ [ ( L.pack [0..19]+ , CommitObject+ { message = "Hello\nWorld\n"+ , parent = Nothing+ , commitTs = 1751814758+ , comAuthor = "Daniil Iaitskov "+ }+ )+ ])++unit_uber_heads_discovery :: IO ()+unit_uber_heads_discovery = withUber go+ where+ go :: Tagged Root FilePath -> Tagged Uber FilePath -> IO ()+ go _rdir (Tagged uberDir) = do+ sunny uberDir+ authorMismatch uberDir++ sunny uberDir = do+ commits <- runHeadsDiscovery HeadsDiscovery2+ { author = "Daniil"+ , uberRepoDir = Tagged uberDir+ }+ assertEqual "no commits matching author name" 3 (length commits)++ authorMismatch uberDir = do+ commits <- runHeadsDiscovery HeadsDiscovery2+ { author = "^Ladiin"+ , uberRepoDir = Tagged uberDir+ }+ assertEqual "author does not match" [] commits
+ test/Discovery.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-}
+ test/Driver.hs view
@@ -0,0 +1,13 @@+module Driver where++import qualified Discovery+import Relude+import Test.Tasty++main :: IO ()+main = defaultMain =<< testTree+ where+ testTree :: IO TestTree+ testTree = do+ tests <- Discovery.tests+ pure $ testGroup "git-phoenix" [ tests ]