diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Add.hs | 17 | ||||
| -rw-r--r-- | Command/Direct.hs | 5 | ||||
| -rw-r--r-- | Command/FuzzTest.hs | 3 | ||||
| -rw-r--r-- | Command/Indirect.hs | 7 | ||||
| -rw-r--r-- | Command/Map.hs | 3 | ||||
| -rw-r--r-- | Command/Move.hs | 10 | ||||
| -rw-r--r-- | Command/PreCommit.hs | 1 | ||||
| -rw-r--r-- | Command/TestRemote.hs | 1 | ||||
| -rw-r--r-- | Command/Vicfg.hs | 4 |
9 files changed, 21 insertions, 30 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index ae895464e..5c7054543 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -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 diff --git a/Command/Direct.hs b/Command/Direct.hs index a5165a4a2..c64ef6e56 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -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 diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index d673541fb..7075aeddc 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -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 diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 4ce4c2c38..e146f13b7 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -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 diff --git a/Command/Map.hs b/Command/Map.hs index 5a32d7f52..a62c3e1ad 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -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' diff --git a/Command/Move.hs b/Command/Move.hs index 396ea4afc..3d9646dea 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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 diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 412b9ae08..09ff042aa 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -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 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 463c4d359..cb36b66ba 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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 diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 5ec6bbf72..1f1695536 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -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 -> |