unify exception handling into Utility.Exception

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.
This commit is contained in:
Joey Hess 2014-08-07 21:55:44 -04:00
parent 8e3d62dd5d
commit c784ef4586
60 changed files with 142 additions and 237 deletions

View file

@ -10,7 +10,6 @@
module Command.Add where
import Common.Annex
import Annex.Exception
import Command
import Types.KeySource
import Backend
@ -33,6 +32,8 @@ import Annex.FileMatcher
import Annex.ReplaceFile
import Utility.Tmp
import Control.Exception (IOException)
def :: [Command]
def = [notBareRepo $ withOptions [includeDotFilesOption] $
command "add" paramPaths seek SectionCommon
@ -103,7 +104,7 @@ lockDown = either (\e -> showErr e >> return Nothing) (return . Just) <=< lockDo
lockDown' :: FilePath -> Annex (Either IOException KeySource)
lockDown' file = ifM crippledFileSystem
( withTSDelta $ liftIO . tryIO . nohardlink
, tryAnnexIO $ do
, tryIO $ do
tmp <- fromRepo gitAnnexTmpMiscDir
createAnnexDirectory tmp
go tmp
@ -167,7 +168,7 @@ ingest (Just source) = withTSDelta $ \delta -> do
)
goindirect (Just (key, _)) mcache ms = do
catchAnnex (moveAnnex key $ contentLocation source)
catchNonAsync (moveAnnex key $ contentLocation source)
(undo (keyFilename source) key)
maybe noop (genMetaData key (keyFilename source)) ms
liftIO $ nukeFile $ keyFilename source
@ -206,23 +207,23 @@ perform file = lockDown file >>= ingest >>= go
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
undo :: FilePath -> Key -> IOException -> Annex a
undo :: FilePath -> Key -> SomeException -> Annex a
undo file key e = do
whenM (inAnnex key) $ do
liftIO $ nukeFile file
catchAnnex (fromAnnex key file) tryharder
catchNonAsync (fromAnnex key file) tryharder
logStatus key InfoMissing
throwAnnex e
throwM e
where
-- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex ()
tryharder :: SomeException -> Annex ()
tryharder _ = do
src <- calcRepo $ gitAnnexLocation key
liftIO $ moveFile src file
{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Maybe InodeCache -> Annex String
link file key mcache = flip catchAnnex (undo file key) $ do
link file key mcache = flip catchNonAsync (undo file key) $ do
l <- inRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l

View file

@ -7,8 +7,6 @@
module Command.Direct where
import Control.Exception.Extensible
import Common.Annex
import Command
import qualified Git
@ -16,7 +14,6 @@ import qualified Git.LsFiles
import qualified Git.Branch
import Config
import Annex.Direct
import Annex.Exception
def :: [Command]
def = [notBareRepo $ noDaemonRunning $
@ -52,7 +49,7 @@ perform = do
Nothing -> noop
Just a -> do
showStart "direct" f
r' <- tryAnnex a
r' <- tryNonAsync a
case r' of
Left e -> warnlocked e
Right _ -> showEndOk

View file

@ -13,7 +13,6 @@ import Command
import qualified Git.Config
import Config
import Utility.ThreadScheduler
import Annex.Exception
import Utility.DiskFree
import Data.Time.Clock
@ -56,7 +55,7 @@ fuzz :: Handle -> Annex ()
fuzz logh = do
action <- genFuzzAction
record logh $ flip Started action
result <- tryAnnex $ runFuzzAction action
result <- tryNonAsync $ runFuzzAction action
record logh $ flip Finished $
either (const False) (const True) result

View file

@ -7,8 +7,6 @@
module Command.Indirect where
import Control.Exception.Extensible
import Common.Annex
import Command
import qualified Git
@ -21,7 +19,6 @@ import Annex.Direct
import Annex.Content
import Annex.Content.Direct
import Annex.CatFile
import Annex.Exception
import Annex.Init
import qualified Command.Add
@ -88,12 +85,12 @@ perform = do
removeInodeCache k
removeAssociatedFiles k
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
v <-tryAnnexIO (moveAnnex k f)
v <- tryNonAsync (moveAnnex k f)
case v of
Right _ -> do
l <- inRepo $ gitAnnexLink f k
liftIO $ createSymbolicLink l f
Left e -> catchAnnex (Command.Add.undo f k e)
Left e -> catchNonAsync (Command.Add.undo f k e)
warnlocked
showEndOk

View file

@ -7,7 +7,6 @@
module Command.Map where
import Control.Exception.Extensible
import qualified Data.Map as M
import Common.Annex
@ -247,7 +246,7 @@ combineSame = map snd . nubBy sameuuid . map pair
safely :: IO Git.Repo -> IO (Maybe Git.Repo)
safely a = do
result <- try a :: IO (Either SomeException Git.Repo)
result <- tryNonAsync a
case result of
Left _ -> return Nothing
Right r' -> return $ Just r'

View file

@ -152,17 +152,17 @@ fromOk src key = go =<< Annex.getState Annex.force
fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
fromPerform src move key afile = moveLock move key $
ifM (inAnnex key)
( handle move True
, handle move =<< go
( dispatch move True
, dispatch move =<< go
)
where
go = notifyTransfer Download afile $
download (Remote.uuid src) key afile noRetry $ \p -> do
showAction $ "from " ++ Remote.name src
getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
handle _ False = stop -- failed
handle False True = next $ return True -- copy complete
handle True True = do -- finish moving
dispatch _ False = stop -- failed
dispatch False True = next $ return True -- copy complete
dispatch True True = do -- finish moving
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok

View file

@ -19,7 +19,6 @@ import Annex.Hook
import Annex.View
import Annex.View.ViewedFile
import Annex.Perms
import Annex.Exception
import Logs.View
import Logs.MetaData
import Types.View

View file

@ -31,7 +31,6 @@ import Locations
import Test.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
import Control.Exception
import "crypto-api" Crypto.Random
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L

View file

@ -217,7 +217,7 @@ parseCfg curcfg = go [] curcfg . lines
| null l = Right cfg
| "#" `isPrefixOf` l = Right cfg
| null setting || null f = Left "missing field"
| otherwise = handle cfg f setting value'
| otherwise = parsed cfg f setting value'
where
(setting, rest) = separate isSpace l
(r, value) = separate (== '=') rest
@ -225,7 +225,7 @@ parseCfg curcfg = go [] curcfg . lines
f = reverse $ trimspace $ reverse $ trimspace r
trimspace = dropWhile isSpace
handle cfg f setting value
parsed cfg f setting value
| setting == "trust" = case readTrustLevel value of
Nothing -> badval "trust value" value
Just t ->