diff options
Diffstat (limited to 'Git/UpdateIndex.hs')
| -rw-r--r-- | Git/UpdateIndex.hs | 94 |
1 files changed, 56 insertions, 38 deletions
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 9f07cf5..f56bc86 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2019 Joey Hess <id@joeyh.name> + - Copyright 2011-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,8 +12,7 @@ module Git.UpdateIndex ( pureStreamer, streamUpdateIndex, streamUpdateIndex', - startUpdateIndex, - stopUpdateIndex, + withUpdateIndex, lsTree, lsSubTree, updateIndexLine, @@ -32,7 +31,9 @@ import Git.FilePath import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Control.Monad.IO.Class {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} @@ -44,28 +45,32 @@ pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO () -streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $ - (\h -> forM_ as $ streamUpdateIndex' h) +streamUpdateIndex repo as = withUpdateIndex repo $ \h -> + forM_ as $ streamUpdateIndex' h -data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle +data UpdateIndexHandle = UpdateIndexHandle Handle streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () -streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do +streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do L.hPutStr h s L.hPutStr h "\0" -startUpdateIndex :: Repo -> IO UpdateIndexHandle -startUpdateIndex repo = do - (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) - { std_in = CreatePipe } - return $ UpdateIndexHandle p h +withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a +withUpdateIndex repo a = bracket setup cleanup go where params = map Param ["update-index", "-z", "--index-info"] - -stopUpdateIndex :: UpdateIndexHandle -> IO Bool -stopUpdateIndex (UpdateIndexHandle p h) = do - hClose h - checkSuccessProcess p + + setup = liftIO $ createProcess $ + (gitCreateProcess params repo) + { std_in = CreatePipe } + go p = do + r <- a (UpdateIndexHandle (stdinHandle p)) + liftIO $ do + hClose (stdinHandle p) + void $ checkSuccessProcess (processHandle p) + return r + + cleanup = liftIO . cleanupProcess {- A streamer that adds the current tree for a ref. Useful for eg, copying - and modifying branches. -} @@ -75,14 +80,14 @@ lsTree (Ref x) repo streamer = do mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x] lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree (Ref x) p repo streamer = do (s, cleanup) <- pipeNullSplit params repo mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} @@ -90,35 +95,35 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString updateIndexLine sha treeitemtype file = L.fromStrict $ fmtTreeItemType treeitemtype <> " blob " - <> encodeBS (fromRef sha) + <> fromRef' sha <> "\t" <> indexPath file -stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer +stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} -unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile :: RawFilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 " - <> encodeBS' (fromRef nullSha) + <> fromRef' deleteSha <> "\t" <> indexPath p {- A streamer that adds a symlink to the index. -} -stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha <*> pure TreeSymlink - <*> toTopFilePath (toRawFilePath file) repo + <*> toTopFilePath file repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} @@ -130,17 +135,17 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath -{- Refreshes the index, by checking file stat information. -} -refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool -refreshIndex repo feeder = do - (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) - { std_in = CreatePipe } - feeder $ \f -> do - hPutStr h f - hPutStr h "\0" - hFlush h - hClose h - checkSuccessProcess p +{- Refreshes the index, by checking file stat information. + - + - The action is passed a callback that it can use to send filenames to + - update-index. Sending Nothing will wait for update-index to finish + - updating the index. + -} +refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m () +refreshIndex repo feeder = bracket + (liftIO $ createProcess p) + (liftIO . cleanupProcess) + go where params = [ Param "update-index" @@ -149,3 +154,16 @@ refreshIndex repo feeder = do , Param "-z" , Param "--stdin" ] + + p = (gitCreateProcess params repo) + { std_in = CreatePipe } + + go (Just h, _, _, pid) = do + let closer = do + hClose h + forceSuccessProcess p pid + feeder $ \case + Just f -> S.hPut h (S.snoc f 0) + Nothing -> closer + liftIO $ closer + go _ = error "internal" |