c784ef4586
Removed old extensible-exceptions, only needed for very old ghc. Made webdav use Utility.Exception, to work after some changes in DAV's exception handling. Removed Annex.Exception. Mostly this was trivial, but note that tryAnnex is replaced with tryNonAsync and catchAnnex replaced with catchNonAsync. In theory that could be a behavior change, since the former caught all exceptions, and the latter don't catch async exceptions. However, in practice, nothing in the Annex monad uses async exceptions. Grepping for throwTo and killThread only find stuff in the assistant, which does not seem related. Command.Add.undo is changed to accept a SomeException, and things that use it for rollback now catch non-async exceptions, rather than only IOExceptions.
110 lines
3.2 KiB
Haskell
110 lines
3.2 KiB
Haskell
{- git-update-index library
|
|
-
|
|
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns, CPP #-}
|
|
|
|
module Git.UpdateIndex (
|
|
Streamer,
|
|
pureStreamer,
|
|
streamUpdateIndex,
|
|
streamUpdateIndex',
|
|
startUpdateIndex,
|
|
stopUpdateIndex,
|
|
lsTree,
|
|
lsSubTree,
|
|
updateIndexLine,
|
|
stageFile,
|
|
unstageFile,
|
|
stageSymlink
|
|
) where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Types
|
|
import Git.Command
|
|
import Git.FilePath
|
|
import Git.Sha
|
|
|
|
{- Streamers are passed a callback and should feed it lines in the form
|
|
- read by update-index, and generated by ls-tree. -}
|
|
type Streamer = (String -> IO ()) -> IO ()
|
|
|
|
{- A streamer with a precalculated value. -}
|
|
pureStreamer :: String -> Streamer
|
|
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)
|
|
|
|
data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
|
|
|
|
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
|
|
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
|
|
hPutStr h s
|
|
hPutStr h "\0"
|
|
|
|
startUpdateIndex :: Repo -> IO UpdateIndexHandle
|
|
startUpdateIndex repo = do
|
|
(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
|
|
{ std_in = CreatePipe }
|
|
fileEncoding h
|
|
return $ UpdateIndexHandle p h
|
|
where
|
|
params = map Param ["update-index", "-z", "--index-info"]
|
|
|
|
stopUpdateIndex :: UpdateIndexHandle -> IO Bool
|
|
stopUpdateIndex (UpdateIndexHandle p h) = do
|
|
hClose h
|
|
checkSuccessProcess p
|
|
|
|
{- A streamer that adds the current tree for a ref. Useful for eg, copying
|
|
- and modifying branches. -}
|
|
lsTree :: Ref -> Repo -> Streamer
|
|
lsTree (Ref x) repo streamer = do
|
|
(s, cleanup) <- pipeNullSplit params repo
|
|
mapM_ streamer s
|
|
void $ cleanup
|
|
where
|
|
params = map Param ["ls-tree", "-z", "-r", "--full-tree", 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]
|
|
|
|
{- Generates a line suitable to be fed into update-index, to add
|
|
- a given file with a given sha. -}
|
|
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
|
|
updateIndexLine sha filetype file =
|
|
show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
|
|
|
|
stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
|
|
stageFile sha filetype file repo = do
|
|
p <- toTopFilePath file repo
|
|
return $ pureStreamer $ updateIndexLine sha filetype p
|
|
|
|
{- A streamer that removes a file from the index. -}
|
|
unstageFile :: FilePath -> Repo -> IO Streamer
|
|
unstageFile file repo = do
|
|
p <- toTopFilePath file repo
|
|
return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
|
|
|
|
{- A streamer that adds a symlink to the index. -}
|
|
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
|
|
stageSymlink file sha repo = do
|
|
!line <- updateIndexLine
|
|
<$> pure sha
|
|
<*> pure SymlinkBlob
|
|
<*> toTopFilePath file repo
|
|
return $ pureStreamer line
|
|
|
|
indexPath :: TopFilePath -> InternalGitPath
|
|
indexPath = toInternalGitPath . getTopFilePath
|