git-phoenix 0.0.1 → 0.0.2

raw patch · 13 files changed

+227/−193 lines, 13 filesdep +lazy-scopePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lazy-scope

API changes (from Hackage documentation)

Files

• changelog.md +3/−0
• git-phoenix.cabal +2/−1
• src/Data/Git/Phoenix/Commit.hs +26/−27
• src/Data/Git/Phoenix/CommitSearch.hs +18/−14
• src/Data/Git/Phoenix/Extraction.hs +37/−27
• src/Data/Git/Phoenix/HeadsDiscovery.hs +18/−15
• src/Data/Git/Phoenix/Io.hs +16/−25
• src/Data/Git/Phoenix/Object.hs +28/−16
• src/Data/Git/Phoenix/Prelude.hs +2/−2
• src/Data/Git/Phoenix/ShaCollision.hs +6/−6
• src/Data/Git/Phoenix/Tree.hs +44/−34
• src/Data/Git/Phoenix/Uber.hs +26/−25
• test/Data/Git/Phoenix/Test.hs +1/−1

@@ -1,4 +1,7 @@ # git-phoenix changelog +## Version 0.0.2 2025-07-14+  * use lazy-scope+ ## Version 0.0.1 2025-06-28   * init

@@ -1,6 +1,6 @@ cabal-version: 3.0 name:          git-phoenix-version:       0.0.1+version:       0.0.2  synopsis:      Recover Git repositories from disk recovery tool output (photorec) description:@@ -201,6 +201,7 @@     , deepseq                 < 2     , extra                   < 2     , filepath                < 2+    , lazy-scope              < 1     , lens                    < 6     , memory                  < 1     , pretty-hex              < 2

@@ -1,57 +1,56 @@ 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 Lazy.Scope as S import Relude -type LbsPair = (LByteString, LByteString)- extractField ::-  Word8 -> LByteString -> (LByteString -> LbsPair) -> LByteString -> LbsPair+  Monad m =>+  Word8 -> Bs s -> (Bs s -> LazyT s m  (Bs s, Bs s)) -> Bs s -> LazyT s m (Bs s, Bs s) 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'+  case S.dropWhile (/= b) bs of+    "" -> pure ("", "")+    bs' -> condM+      [ ( field `S.isPrefixOf` bs'+        , parseValue (S.length field `S.drop` bs') )+      ]+      (extractField b field parseValue $ S.drop 1 bs') -extractParent :: L.ByteString -> LbsPair+extractParent :: Monad m => Bs s -> LazyT s m (Bs s, Bs s) extractParent =-  extractField W._lf "\nparent " (L.span W.isHexDigit)+  extractField W._lf "\nparent " (pure . S.span W.isHexDigit) -extractAuthor :: LByteString -> LbsPair+extractAuthor :: Monad m => Bs s -> LazyT s m (Bs s, Bs s) extractAuthor =-  extractField W._lf "\nauthor " (L.span (/= W._less))+  extractField W._lf "\nauthor " (pure . S.span (/= W._less)) -extractCommitTs :: LByteString -> Maybe (Int64, LByteString)+extractCommitTs :: Monad m => Bs s -> LazyT s m (Maybe (Int64, Bs s)) extractCommitTs bs =-  case extractField W._greater "> " (L.span (/= W._lf)) bs of+  extractField W._greater "> " (pure . S.span (/= W._lf)) bs >>= \case     (tsBs, bs') ->-      case L8.readInt64 tsBs of-        Nothing -> Nothing+      unScope (bs2Scoped L8.readInt64 tsBs) >>= \case+        Nothing -> pure $ Nothing         Just (epoch', spcTzBs) ->-          case L8.readInt64 $ L.dropWhile W.isSpace spcTzBs of-            Nothing -> Nothing+          unScope (bs2Scoped L8.readInt64 $ S.dropWhile W.isSpace $ toBs spcTzBs) >>= \case+            Nothing -> pure $ Nothing             Just (tz, _) ->               let                 tzAbs = abs tz                 (tzH, tzM) = tzAbs `divMod` 100               in-                Just (epoch' + (tzH * 3600 + tzM * 60) * signum tz, bs')+                pure $ Just (epoch' + (tzH * 3600 + tzM * 60) * signum tz, bs') -extractMessage :: LByteString -> LByteString+extractMessage :: Monad m => Bs s -> LazyT s m (Bs s) extractMessage bs =-  case extractField W._lf "\n\n" (L.span (/= W._lf)) bs of-    (msgFirstLine, _) -> msgFirstLine+  extractField W._lf "\n\n" (pure . S.span (/= W._lf)) bs >>= \case+    (msgFirstLine, _) -> pure msgFirstLine -extractTreeHash :: LByteString -> LbsPair+extractTreeHash :: Monad m => Bs s -> LazyT s m (Bs s, Bs s) extractTreeHash =-  extractField 0 "\0tree " (L.span W.isHexDigit)+  extractField 0 "\0tree " (pure . S.span W.isHexDigit)  epoch :: UTCTime epoch = posixSecondsToUTCTime 0

@@ -16,6 +16,8 @@ import Text.Regex.TDFA.ByteString.Lazy import Text.Regex.TDFA ++ data CommitObject   = CommitObject     { message :: LByteString@@ -31,27 +33,29 @@   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+      extractAuthor bs >>= \case         ("", _) -> pure []-        (author, bs') ->-          case extractCommitTs bs' of+        (authorBs, bs') ->+          extractCommitTs bs' >>= \case             Nothing -> pure []             Just (commitTs, bs'') ->-              case extractMessage bs'' of-                message ->-                  let sha = gitPath2Bs . shaToPath . showDigest $ sha1 bs in-                    pure [CommitObject {message, sha, commitTs, author}]+              extractMessage bs'' >>= toLbs >>=+                \message -> do+                  author <- toLbs authorBs+                  sha <- unScope $ bs2Scoped (gitPath2Bs . shaToPath . showDigest . sha1) bs+                  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 []+      lr <-+        withCompressedH absGop $ \cbs bs ->+          classifyGitObject bs >>= \case+            Just BlobType -> pure $ Right []+            Just TreeType -> pure $ Right []+            Just CommitType -> Right <$> goCommit bs+            Just CollidedHash -> Left <$> sequenceA (fmap toLbs cbs)+            Nothing -> pure $ Right []       case lr of         Right cmt -> pure cmt         Left cbs -> do

@@ -2,51 +2,61 @@  import Data.ByteString.Lazy.Char8 qualified as L8 import Data.Git.Phoenix.App-import Data.Git.Phoenix.CmdArgs-import Data.Git.Phoenix.Commit+    ( PhoenixExtractConf(destGitDir, uberDir), PhoenixExtractM )+import Data.Git.Phoenix.CmdArgs ( ShaPrefix )+import Data.Git.Phoenix.Commit ( extractParent, extractTreeHash ) import Data.Git.Phoenix.Io+    ( writeBinaryFile,+      hPutLbs,+      saveCompressedBs,+      withCompressed,+      withCompressedH ) import Data.Git.Phoenix.Object+    ( classifyGitObject,+      toCommitSha,+      GitObjType(CommitType, BlobType, TreeType, CollidedHash),+      GitObjTypeG(Tree, Commit),+      GitPath(..) ) 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+import Data.Git.Phoenix.Repo ( initGitRepo )+import Data.Git.Phoenix.Sha ( shaToPath )+import Data.Git.Phoenix.ShaCollision ( uniqBs )+import Data.Git.Phoenix.Tree ( extractTree )  -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 gop = go . (</> toFp gop) . untag =<< asks uberDir   where+    goCommit :: forall s. Bs s -> LazyT s m (Maybe (GitPath Commit), GitPath Tree)     goCommit bs =-      case extractTreeHash $ $(tr "eee/bs") bs of+      extractTreeHash {- fix traceEmbrace to uncomment this snippet: $ $(tr "eee/bs") -} bs >>= \case         ("", _) -> 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-                            )+          saveCompressedBs (gitDir </> ".git" </> "objects" </> toFp gop) =<< toLbs bs+          extractParent bs' >>= \case+            ("", _) -> (Nothing, ) . shaToPath . L8.unpack <$> toLbs treeComit+            (!ph, _) -> (,)+                        <$> (Just . shaToPath . L8.unpack <$> toLbs ph)+                        <*> ( $(tr "/treeComit") . shaToPath . L8.unpack <$> toLbs 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"+      lr <-+        withCompressedH absGop $ \cbs bs ->+          classifyGitObject bs >>= \case+            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 -> Left <$> sequenceA (fmap toLbs 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+              classifyGitObject ubs >>= \case                 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")@@ -63,10 +73,10 @@       initGitRepo gitDir       let uc = GitPath . $(tw "/udr up") $ makeRelative udr up       extractCommit uc-      withBinaryFile+      writeBinaryFile         (gitDir </> ".git" </> "refs" </> "heads" </> "master")         WriteMode-        (`hPut` toCommitSha uc)+        (`hPutLbs` toCommitSha uc)     [] -> fail $ "No commit matching prefix: " <> show rootCommit     ambiP -> fail $ "Commit prefix is ambioguous:\n " <> intercalate "\n" ambiP 

@@ -16,6 +16,7 @@ import Data.Time.Format import Text.Regex.TDFA.ByteString.Lazy import Text.Regex.TDFA+import Lazy.Scope qualified as S  data CommitObject   = CommitObject@@ -36,30 +37,32 @@     Just gp -> fmap (gp,) <$> go gop   where     orphanCommit parent bs =-      case extractAuthor bs of+      extractAuthor bs >>= \case         ("", _) -> pure []-        (comAuthor, bs') ->-          case extractCommitTs bs' of+        (comAuthorBs, bs') ->+          extractCommitTs bs' >>= \case             Nothing -> pure []             Just (commitTs, bs'') ->-              case extractMessage bs'' of-                message ->-                    pure [CommitObject {message, commitTs, comAuthor, parent}]+              extractMessage bs'' >>= S.toLbs >>=+              \message -> do+                comAuthor <- S.toLbs comAuthorBs+                pure [CommitObject {message, commitTs, comAuthor, parent}]      goCommit bs =-      case extractParent bs of+      extractParent bs >>= \case         ("", bs') -> orphanCommit Nothing bs'-        (parent, bs') -> orphanCommit (Just $ hexToBin parent) bs'+        (parent, bs') -> (`orphanCommit` bs') =<< (Just . hexToBin <$> S.toLbs parent)      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 []+      lr <-+        withCompressedH absGop $ \cbs bs ->+          classifyGitObject bs >>= \case+            Just BlobType -> pure $ Right []+            Just TreeType -> pure $ Right []+            Just CommitType -> Right <$> goCommit bs+            Just CollidedHash -> Left <$> sequenceA (fmap S.toLbs cbs)+            Nothing -> pure $ Right []       case lr of         Right cmt -> pure cmt         Left cbs -> do

@@ -1,9 +1,10 @@ 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)+import System.IO qualified as IO+import Lazy.Scope as S+import UnliftIO.IO qualified as U  class HasInHandlesSem m where   getInHandlesSem :: m QSem@@ -14,49 +15,39 @@ data Compressed  withHandleX :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>-  IOMode -> FilePath -> (Handle -> m a) -> m a+  IOMode -> FilePath -> (forall s. Handle s -> LazyT s 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+    withBinaryFile fp mode a + withHandle :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>-  FilePath -> (Handle -> m a) -> m a+  FilePath -> (forall s. Handle s -> LazyT s m a) -> m a withHandle = withHandleX ReadMode  withCompressedH :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>   FilePath ->-  (Tagged Compressed LByteString -> LByteString -> m a) ->+  (forall s. Tagged Compressed (Bs s) -> Bs s -> LazyT s m a) ->   m a withCompressedH fp a =-  withHandle ($(tr "/fp") fp) $ \inH -> hGetContents inH >>= (\cbs -> a (Tagged cbs) $ decompress cbs)+  withHandle ($(tr "/fp") fp) $ \inH -> hGetContents inH >>= (\cbs -> a (Tagged cbs) $ mapLbs decompress cbs) -withCompressed :: (HasCallStack, NFData a, MonadUnliftIO m, HasInHandlesSem m) =>-  FilePath -> (HasCallStack => L.ByteString -> m a) -> m a+withCompressed :: (NFData a, MonadUnliftIO m, HasInHandlesSem m) =>+  FilePath -> (forall s. Bs s -> LazyT s 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+writeBinaryFile :: MonadUnliftIO m => FilePath -> IOMode -> (IO.Handle -> m ()) -> m ()+writeBinaryFile fp mode cb = U.withBinaryFile fp mode cb -hPut :: MonadIO m => Handle -> LByteString -> m ()-hPut h bs = liftIO $ L.hPut h bs+hPutLbs :: MonadIO m => IO.Handle -> LByteString -> m ()+hPutLbs 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+  withBinaryFile ($(tr "/fp") fp) WriteMode $ \h -> S.hPut h $ compress bs  readNumber :: MonadIO m => Int -> Int -> m Int readNumber minVal maxVal = go

@@ -1,10 +1,13 @@+{-# OPTIONS_GHC -Wno-orphans #-} 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+import Lazy.Scope qualified as S + data GitObjType = CommitType | TreeType | BlobType | CollidedHash deriving (Show, Eq)  data GitObjTypeG = Commit | Tree deriving (Show, Eq)@@ -15,32 +18,41 @@ 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+classifyGitObject :: Monad m => Bs s -> LazyT s m (Maybe GitObjType)+classifyGitObject bs =+  condM+    [ (blob `S.isPrefixOf` bs, pure $ pure BlobType)+    , (tree `S.isPrefixOf` bs, pure $ pure TreeType)+    , (commit `S.isPrefixOf` bs, pure $ pure CommitType)+    , (toBs disambiguate `S.isPrefixOf` bs, pure $ pure CollidedHash)+    ]+    (pure Nothing) -commit, tree, blob, disambiguate :: L.ByteString-disambiguate = "disambigate "+commit, tree, blob :: Bs s commit = "commit " blob = "blob " tree = "tree " -gitObjectP :: LByteString -> Bool+disambiguate :: LByteString+disambiguate = "disambigate "++gitObjectP :: Monad m => Bs s -> LazyT s m Bool gitObjectP bs =-  case classifyGitObject bs of+  classifyGitObject bs >>= pure . \case     Nothing -> False     Just CollidedHash -> False     Just _ -> True -compressedDisambiguate :: L.ByteString-compressedDisambiguate =-  compressWith-    (defaultCompressParams { compressLevel = CompressionLevel 0 })-    disambiguate+compressedDisambiguate :: LByteString+compressedDisambiguate = compressWith params disambiguate+  where+    params = defaultCompressParams { compressLevel = CompressionLevel 0 }++compressedDisambiguateBs :: Bs s+compressedDisambiguateBs = toBs compressedDisambiguate++compressedDisambiguateLen :: Int64+compressedDisambiguateLen = L.length compressedDisambiguate  encodedIntLen :: Int64 encodedIntLen = L.length . B.encode $ L.length ""

@@ -18,11 +18,11 @@ import Data.List as X ((!?)) import Data.Tagged as X (Tagged (..), untag) import Data.Word8 as X (isHexDigit)-import Relude as X+import Lazy.Scope as X (LazyT, Scoped, Bs, unScope, toLbs, condM, toBs, bs2Scoped)+import Relude as X hiding (Handle) 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

@@ -8,16 +8,16 @@ import Data.Git.Phoenix.Io import Data.Git.Phoenix.Object import Data.Git.Phoenix.Prelude-+import Lazy.Scope qualified as S  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)+    go l =+      withCompressed l $ \bs ->+        classifyGitObject bs >>= \case+          Just x | x == tt -> Just . (, l) <$> S.toLbs bs                  | otherwise -> pure Nothing           Nothing -> pure Nothing @@ -66,4 +66,4 @@               error $ "List of files with collided SHA is corrupted (error: "                 <> show e <> ") near: "  <> show bs -    cbs = L.drop (L.length compressedDisambiguate) preCbs+    cbs = L.drop compressedDisambiguateLen preCbs

@@ -7,9 +7,10 @@ import Data.Git.Phoenix.Sha import Data.Git.Phoenix.ShaCollision import Data.Git.Phoenix.Io+import Lazy.Scope as S -dropTreeHeader :: LByteString -> LByteString-dropTreeHeader = L.drop 1 . L.dropWhile (/= 0)+dropTreeHeader :: Bs s -> Bs s+dropTreeHeader = S.drop 1 . S.dropWhile (/= 0)  data DOF = Dir | File deriving (Eq, Show, Generic) @@ -57,16 +58,16 @@  parseTreeObject :: PhoenixExtractM m =>   FilePath ->-  Tagged Compressed LByteString ->-  LByteString ->-  m (Either (Tagged Compressed LByteString) [(DOF, LByteString)])+  Tagged Compressed (Bs s) ->+  Bs s ->+  LazyT s m (Either (Tagged Compressed LByteString) [(DOF, LByteString)]) parseTreeObject gop cbs bs =-  case classifyGitObject bs of+  classifyGitObject bs >>= \case     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+    Just TreeType ->+      Right <$> unScope (bs2Scoped readTreeShas (dropTreeHeader bs))+    Just CollidedHash -> Left <$> sequenceA (fmap toLbs cbs)     Nothing -> fail $ gop <> " is not a Git tree object"  onRight_ :: Monad m => (b -> m ()) -> Either a b -> m (Either a b)@@ -74,7 +75,9 @@   v@(Left _) -> pure v   r@(Right v) -> f v >> pure r -extractTree :: PhoenixExtractM m => GitPath Tree -> m ()+getDestDir :: MonadReader PhoenixExtractConf m => m FilePath+getDestDir = (\(Tagged r) -> r </> ".git" </> "objects") <$> asks destGitDir+extractTree :: forall m. PhoenixExtractM m => GitPath Tree -> m () extractTree treeHash = do   Tagged udr <- asks uberDir   dd <- getDestDir@@ -82,11 +85,14 @@     mapM_ (copyTreeLinks dd) . $(tw "len/")   where     copyTree treePath trH = do-      let save bs = do+      let+        save :: forall s. Bs s -> LazyT s m ()+        save bs = do             destDir <- getDestDir-            saveCompressedBs (destDir </> toFp trH) bs-      rl <- withCompressedH treePath $ \cTreeBs treeBs ->-        parseTreeObject treePath cTreeBs treeBs >>= onRight_ (\_ -> save treeBs)+            saveCompressedBs (destDir </> toFp trH) =<< toLbs bs+      rl <- withCompressedH treePath $+            \cTreeBs treeBs ->+              parseTreeObject treePath cTreeBs treeBs >>= onRight_ (\_ -> save treeBs)       shas <- case rl of         Right shas' -> pure shas'         Left cbs -> do@@ -94,41 +100,45 @@           withCompressed uniPath             (\ubs -> do                 save ubs-                pure . readTreeShas $ dropTreeHeader ubs+                unScope (bs2Scoped 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)+          saveBlob :: forall s. Bs s -> LazyT s m ()+          saveBlob = toLbs >=> saveCompressedBs (destDir </> toFp shaP)+          saveTree :: forall s. Bs s -> LazyT s m [(DOF, LByteString)]           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"+            unScope (bs2Scoped readTreeShas $ dropTreeHeader bs)+      nonRec <-+        withCompressedH absSha $ \cbs bs ->+          classifyGitObject bs >>= \case+            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 ->+              Collision <$> sequenceA (fmap toLbs 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"+          !lr <-+            withCompressed uniPath $ \ubs ->+              classifyGitObject ubs >>= \case+                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

@@ -13,6 +13,7 @@ import Data.Git.Phoenix.Sha import Data.List qualified as I import Data.Map.Strict qualified as M+import Lazy.Scope as S  type ShaDedupMap = M.Map ComHash Int @@ -28,25 +29,25 @@ 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+mkGitObject :: forall m. PhoenixM m => FilePath -> m (Maybe GitObject)+mkGitObject fp = go   where+    go :: m (Maybe GitObject)+    go =+      withHandle fp $ \inH -> unScope =<< do+        magicBs <- S.hGet inH 2+        if zlibP magicBs+          then do+            (`catch` skipCorruptedFile) $ do+              headerBs <- (toLazy magicBs <>) . toLazy <$> S.hGet inH 510+              ifM (gitObjectP . toBs $ decompress headerBs)+                (S.bs2Scoped (Just . (`GitObject` fp) . sha1 . decompress) . (toBs headerBs <>) <$> S.hGetContents inH)+                (pure (pure Nothing))+          else pure (pure Nothing)+     skipCorruptedFile (_ :: DecompressError) = do       liftIO $ $(trIo "Skip corrupted file/fp")-      pure Nothing+      pure (pure Nothing)      zlibNoCompression = "\x0078\x0001"     zlibDefaultCompression = "\x0078\x009C"@@ -70,20 +71,20 @@ 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-                        ]+  S.withBinaryFile uberGob WriteMode $ \oh ->+    hPutBs oh . mconcat $ (compressedDisambiguateBs : fmap toBs [+                            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+  writeBinaryFile uberGob AppendMode $ \oh ->+    hPutLbs oh $ gobLen <> gobPacked   where     gobPacked = L8.pack $ gobOrigin gob     gobLen = B.encode $ L.length gobPacked

@@ -7,7 +7,7 @@ import Data.Git.Phoenix.Prelude import Test.QuickCheck as QC import UnliftIO.Directory-import UnliftIO.IO (hSeek, SeekMode (..))+import UnliftIO.IO ( SeekMode(AbsoluteSeek), hSeek, withBinaryFile ) import UnliftIO.Temporary  currentHead :: String