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.
67 lines
1.4 KiB
Haskell
67 lines
1.4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Direct where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Git
|
|
import qualified Git.LsFiles
|
|
import qualified Git.Branch
|
|
import Config
|
|
import Annex.Direct
|
|
|
|
def :: [Command]
|
|
def = [notBareRepo $ noDaemonRunning $
|
|
command "direct" paramNothing seek
|
|
SectionSetup "switch repository to direct mode"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = ifM isDirect ( stop , next perform )
|
|
|
|
perform :: CommandPerform
|
|
perform = do
|
|
showStart "commit" ""
|
|
showOutput
|
|
_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
|
|
[ Param "-a"
|
|
, Param "-m"
|
|
, Param "commit before switching to direct mode"
|
|
]
|
|
showEndOk
|
|
|
|
top <- fromRepo Git.repoPath
|
|
(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
|
|
forM_ l go
|
|
void $ liftIO clean
|
|
next cleanup
|
|
where
|
|
go = whenAnnexed $ \f k -> do
|
|
r <- toDirectGen k f
|
|
case r of
|
|
Nothing -> noop
|
|
Just a -> do
|
|
showStart "direct" f
|
|
r' <- tryNonAsync a
|
|
case r' of
|
|
Left e -> warnlocked e
|
|
Right _ -> showEndOk
|
|
return Nothing
|
|
|
|
warnlocked :: SomeException -> Annex ()
|
|
warnlocked e = do
|
|
warning $ show e
|
|
warning "leaving this file as-is; correct this problem and run git annex fsck on it"
|
|
|
|
cleanup :: CommandCleanup
|
|
cleanup = do
|
|
showStart "direct" ""
|
|
setDirect True
|
|
return True
|