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.
106 lines
2.6 KiB
Haskell
106 lines
2.6 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Indirect where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Git
|
|
import qualified Git.Branch
|
|
import qualified Git.LsFiles
|
|
import Git.FileMode
|
|
import Config
|
|
import qualified Annex
|
|
import Annex.Direct
|
|
import Annex.Content
|
|
import Annex.Content.Direct
|
|
import Annex.CatFile
|
|
import Annex.Init
|
|
import qualified Command.Add
|
|
|
|
def :: [Command]
|
|
def = [notBareRepo $ noDaemonRunning $
|
|
command "indirect" paramNothing seek
|
|
SectionSetup "switch repository to indirect mode"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = ifM isDirect
|
|
( do
|
|
unlessM (coreSymlinks <$> Annex.getGitConfig) $
|
|
error "Git is configured to not use symlinks, so you must use direct mode."
|
|
whenM probeCrippledFileSystem $
|
|
error "This repository seems to be on a crippled filesystem, you must use direct mode."
|
|
next perform
|
|
, stop
|
|
)
|
|
|
|
perform :: CommandPerform
|
|
perform = do
|
|
showStart "commit" ""
|
|
whenM stageDirect $ do
|
|
showOutput
|
|
void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
|
|
[ Param "-m"
|
|
, Param "commit before switching to indirect mode"
|
|
]
|
|
showEndOk
|
|
|
|
-- Note that we set indirect mode early, so that we can use
|
|
-- moveAnnex in indirect mode.
|
|
setDirect False
|
|
|
|
top <- fromRepo Git.repoPath
|
|
(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
|
|
forM_ l go
|
|
void $ liftIO clean
|
|
next cleanup
|
|
where
|
|
{- Walk tree from top and move all present direct mode files into
|
|
- the annex, replacing with symlinks. Also delete direct mode
|
|
- caches and mappings. -}
|
|
go (f, Just sha, Just mode) | isSymLink mode = do
|
|
r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
|
|
case r of
|
|
Just s
|
|
| isSymbolicLink s -> void $ flip whenAnnexed f $
|
|
\_ k -> do
|
|
removeInodeCache k
|
|
removeAssociatedFiles k
|
|
return Nothing
|
|
| otherwise ->
|
|
maybe noop (fromdirect f)
|
|
=<< catKey sha mode
|
|
_ -> noop
|
|
go _ = noop
|
|
|
|
fromdirect f k = do
|
|
showStart "indirect" f
|
|
removeInodeCache k
|
|
removeAssociatedFiles k
|
|
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
|
|
v <- tryNonAsync (moveAnnex k f)
|
|
case v of
|
|
Right _ -> do
|
|
l <- inRepo $ gitAnnexLink f k
|
|
liftIO $ createSymbolicLink l f
|
|
Left e -> catchNonAsync (Command.Add.undo f k e)
|
|
warnlocked
|
|
showEndOk
|
|
|
|
warnlocked :: SomeException -> Annex ()
|
|
warnlocked e = do
|
|
warning $ show e
|
|
warning "leaving this file as-is; correct this problem and run git annex add on it"
|
|
|
|
cleanup :: CommandCleanup
|
|
cleanup = do
|
|
showStart "indirect" ""
|
|
showEndOk
|
|
return True
|