diff options
| author |  Joey Hess <joey@kitenet.net> | 2014-08-07 21:55:44 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2014-08-07 22:03:29 -0400 |
| commit | 69ef3f1025fb32a19f03517d072c1e64dcb326b7 (patch) | |
| tree | 12e38dfaa613171522309534645382ced65c485d | |
| parent | f94f5fc8d4f567ee8a72aa4ae457d3a6b3a9e22f (diff) | |
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.
60 files changed, 142 insertions, 237 deletions
@@ -64,14 +64,16 @@ import Utility.Quvi (QuviVersion) import Utility.InodeCache import "mtl" Control.Monad.Reader -import Control.Monad.Catch import Control.Concurrent import qualified Data.Map as M import qualified Data.Set as S {- git-annex's monad is a ReaderT around an AnnexState stored in a MVar. - - This allows modifying the state in an exception-safe fashion. - The MVar is not exposed outside this module. + - + - Note that when an Annex action fails and the exception is caught, + - ny changes the action has made to the AnnexState are retained, + - due to the use of the MVar to store the state. -} newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a } deriving ( diff --git a/Annex/Content.hs b/Annex/Content.hs index eb84f2fe9..b51e15827 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -56,7 +56,6 @@ import Annex.Perms import Annex.Link import Annex.Content.Direct import Annex.ReplaceFile -import Annex.Exception #ifdef mingw32_HOST_OS import Utility.WinLock @@ -167,7 +166,7 @@ lockContent key a = do contentfile <- calcRepo $ gitAnnexLocation key lockfile <- contentLockFile key maybe noop setuplockfile lockfile - bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a) + bracket (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a) where alreadylocked = error "content is locked" setuplockfile lockfile = modifyContent lockfile $ @@ -420,7 +419,7 @@ withObjectLoc key indirect direct = ifM isDirect cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do file <- calcRepo $ gitAnnexLocation key - void $ tryAnnexIO $ thawContentDir file + void $ tryIO $ thawContentDir file cleaner liftIO $ removeparents file (3 :: Int) where diff --git a/Annex/Direct.hs b/Annex/Direct.hs index e6b941e0f..374599369 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -32,7 +32,6 @@ import Utility.InodeCache import Utility.CopyFile import Annex.Perms import Annex.ReplaceFile -import Annex.Exception import Annex.VariantFile import Git.Index import Annex.Index @@ -252,7 +251,7 @@ mergeDirectCleanup d oldref = do go makeabs getsha getmode a araw (f, item) | getsha item == nullSha = noop | otherwise = void $ - tryAnnex . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f) + tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f) =<< catKey (getsha item) (getmode item) moveout _ _ = removeDirect diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 71263dc61..c5a3fbe5f 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -16,7 +16,6 @@ import qualified Remote import qualified Command.Drop import Command import Annex.Wanted -import Annex.Exception import Config import Annex.Content.Direct @@ -120,5 +119,5 @@ handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do slocs = S.fromList locs - safely a = either (const False) id <$> tryAnnex a + safely a = either (const False) id <$> tryNonAsync a diff --git a/Annex/Environment.hs b/Annex/Environment.hs index 4b8d38464..bc97c17b7 100644 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -13,7 +13,6 @@ import Common.Annex import Utility.UserInfo import qualified Git.Config import Config -import Annex.Exception #ifndef mingw32_HOST_OS import Utility.Env @@ -58,7 +57,7 @@ checkEnvironmentIO = {- Runs an action that commits to the repository, and if it fails, - sets user.email and user.name to a dummy value and tries the action again. -} ensureCommit :: Annex a -> Annex a -ensureCommit a = either retry return =<< tryAnnex a +ensureCommit a = either retry return =<< tryNonAsync a where retry _ = do name <- liftIO myUserName diff --git a/Annex/Exception.hs b/Annex/Exception.hs deleted file mode 100644 index 5ecbd28a0..000000000 --- a/Annex/Exception.hs +++ /dev/null @@ -1,63 +0,0 @@ -{- exception handling in the git-annex monad - - - - Note that when an Annex action fails and the exception is handled - - by these functions, any changes the action has made to the - - AnnexState are retained. This works because the Annex monad - - internally stores the AnnexState in a MVar. - - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Annex.Exception ( - bracketIO, - bracketAnnex, - tryAnnex, - tryAnnexIO, - throwAnnex, - catchAnnex, - catchNonAsyncAnnex, - tryNonAsyncAnnex, -) where - -import qualified Control.Monad.Catch as M -import Control.Exception - -import Common.Annex - -{- Runs an Annex action, with setup and cleanup both in the IO monad. -} -bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a -bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup) - -bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a -bracketAnnex = M.bracket - -{- try in the Annex monad -} -tryAnnex :: Annex a -> Annex (Either SomeException a) -tryAnnex = M.try - -{- try in the Annex monad, but only catching IO exceptions -} -tryAnnexIO :: Annex a -> Annex (Either IOException a) -tryAnnexIO = M.try - -{- throw in the Annex monad -} -throwAnnex :: Exception e => e -> Annex a -throwAnnex = M.throwM - -{- catch in the Annex monad -} -catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a -catchAnnex = M.catch - -{- catchs all exceptions except for async exceptions -} -catchNonAsyncAnnex :: Annex a -> (SomeException -> Annex a) -> Annex a -catchNonAsyncAnnex a onerr = a `M.catches` - [ M.Handler (\ (e :: AsyncException) -> throwAnnex e) - , M.Handler (\ (e :: SomeException) -> onerr e) - ] - -tryNonAsyncAnnex :: Annex a -> Annex (Either SomeException a) -tryNonAsyncAnnex a = (Right <$> a) `catchNonAsyncAnnex` (return . Left) diff --git a/Annex/Index.hs b/Annex/Index.hs index af0cab45e..7757a412b 100644 --- a/Annex/Index.hs +++ b/Annex/Index.hs @@ -18,7 +18,6 @@ import Common.Annex import Git.Types import qualified Annex import Utility.Env -import Annex.Exception {- Runs an action using a different git index file. -} withIndexFile :: FilePath -> Annex a -> Annex a @@ -26,7 +25,7 @@ withIndexFile f a = do g <- gitRepo g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f - r <- tryAnnex $ do + r <- tryNonAsync $ do Annex.changeState $ \s -> s { Annex.repo = g' } a Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} } diff --git a/Annex/Journal.hs b/Annex/Journal.hs index f34a7be1b..798bcba29 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -14,7 +14,6 @@ module Annex.Journal where import Common.Annex -import Annex.Exception import qualified Git import Annex.Perms import Annex.LockFile diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs index 8114e94f2..dc4f82f98 100644 --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -18,7 +18,6 @@ import Common.Annex import Annex import Types.LockPool import qualified Git -import Annex.Exception import Annex.Perms import qualified Data.Map as M diff --git a/Annex/Perms.hs b/Annex/Perms.hs index e3a2fa65a..3430554c7 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -21,7 +21,6 @@ import Common.Annex import Utility.FileMode import Git.SharedRepository import qualified Annex -import Annex.Exception import Config import System.Posix.Types @@ -120,6 +119,6 @@ createContentDir dest = do modifyContent :: FilePath -> Annex a -> Annex a modifyContent f a = do createContentDir f -- also thaws it - v <- tryAnnex a + v <- tryNonAsync a freezeContentDir f - either throwAnnex return v + either throwM return v diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs index e734c4d64..8776762e9 100644 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -9,7 +9,6 @@ module Annex.ReplaceFile where import Common.Annex import Annex.Perms -import Annex.Exception {- Replaces a possibly already existing file with a new version, - atomically, by running an action. @@ -31,7 +30,7 @@ replaceFileOr :: FilePath -> (FilePath -> Annex ()) -> (FilePath -> Annex ()) -> replaceFileOr file action rollback = do tmpdir <- fromRepo gitAnnexTmpMiscDir void $ createAnnexDirectory tmpdir - bracketAnnex (liftIO $ setup tmpdir) rollback $ \tmpfile -> do + bracket (liftIO $ setup tmpdir) rollback $ \tmpfile -> do action tmpfile liftIO $ catchIO (rename tmpfile file) (fallback tmpfile) where diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 001539adc..ebc8e8b89 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -20,7 +20,6 @@ import Common.Annex import Logs.Transfer as X import Annex.Notification as X import Annex.Perms -import Annex.Exception import Utility.Metered #ifdef mingw32_HOST_OS import Utility.WinLock @@ -103,7 +102,7 @@ runTransfer t file shouldretry a = do void $ tryIO $ removeFile $ transferLockFile tfile #endif retry oldinfo metervar run = do - v <- tryAnnex run + v <- tryNonAsync run case v of Right b -> return b Left e -> do diff --git a/Annex/View.hs b/Annex/View.hs index b96981612..a1d873f50 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -410,19 +410,19 @@ withViewChanges addmeta removemeta = do where handleremovals item | DiffTree.srcsha item /= nullSha = - handle item removemeta + handlechange item removemeta =<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item) | otherwise = noop handleadds makeabs item | DiffTree.dstsha item /= nullSha = - handle item addmeta + handlechange item addmeta =<< ifM isDirect ( catKey (DiffTree.dstsha item) (DiffTree.dstmode item) -- optimisation , isAnnexLink $ makeabs $ DiffTree.file item ) | otherwise = noop - handle item a = maybe noop + handlechange item a = maybe noop (void . commandAction . a (getTopFilePath $ DiffTree.file item)) {- Generates a branch for a view. This is done using a different index diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 6c625f881..4bb6088b1 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -20,7 +20,6 @@ import Utility.Verifiable import Network.Multicast import Network.Info import Network.Socket -import Control.Exception (bracket) import qualified Data.Map as M import Control.Concurrent diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index afe4aa144..4a47a9e2c 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -27,7 +27,6 @@ import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher import Types.KeySource import Config -import Annex.Exception import Annex.Content import Annex.Link import Annex.CatFile @@ -217,7 +216,7 @@ commitStaged :: Annex Bool commitStaged = do {- This could fail if there's another commit being made by - something else. -} - v <- tryAnnex Annex.Queue.flush + v <- tryNonAsync Annex.Queue.flush case v of Left _ -> return False Right _ -> do diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index 55b3ca2f1..0fe7f58f4 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -191,10 +191,10 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) where reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download -runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (remoteFromUUID u) +runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u) where - handle Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] - handle (Just rmt) = void $ case Remote.remoteFsck rmt of + dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] + dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of Nothing -> go rmt $ do program <- readProgramFile void $ batchCommand program $ diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index b62318382..dce2c2db7 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -40,7 +40,6 @@ import Logs.Transfer import Config.Files import Utility.DiskFree import qualified Annex -import Annex.Exception #ifdef WITH_WEBAPP import Assistant.WebApp.Types #endif @@ -85,7 +84,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta liftIO $ fixUpSshRemotes {- Clean up old temp files. -} - void $ liftAnnex $ tryAnnex $ do + void $ liftAnnex $ tryNonAsync $ do cleanOldTmpMisc cleanReallyOldTmp diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 91e0fc619..fe9a95471 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -104,13 +104,13 @@ runWatcher = do , errHook = errhook } scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig - handle <- liftIO $ watchDir "." ignored scanevents hooks startup + h <- liftIO $ watchDir "." ignored scanevents hooks startup debug [ "watching", "."] {- Let the DirWatcher thread run until signalled to pause it, - then wait for a resume signal, and restart. -} waitFor PauseWatcher $ do - liftIO $ stopWatchDir handle + liftIO $ stopWatchDir h waitFor ResumeWatcher runWatcher where hook a = Just <$> asIO2 (runHandler a) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 39b0459b7..2f70b508f 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -117,7 +117,7 @@ xmppClient urlrenderer d creds xmppuuid = void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime inAssistant $ debug ["received:", show $ map logXMPPEvent l] - mapM_ (handle selfjid) l + mapM_ (handlemsg selfjid) l sendpings selfjid lasttraffic = forever $ do putStanza pingstanza @@ -133,21 +133,21 @@ xmppClient urlrenderer d creds xmppuuid = - cause traffic, so good enough. -} pingstanza = xmppPing selfjid - handle selfjid (PresenceMessage p) = do + handlemsg selfjid (PresenceMessage p) = do void $ inAssistant $ updateBuddyList (updateBuddies p) <<~ buddyList resendImportantMessages selfjid p - handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature - handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us - handle selfjid (GotNetMessage (PairingNotification stage c u)) = + handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature + handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us + handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) = maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) - handle _ (GotNetMessage m@(Pushing _ pushstage)) + handlemsg _ (GotNetMessage m@(Pushing _ pushstage)) | isPushNotice pushstage = inAssistant $ handlePushNotice m | isPushInitiation pushstage = inAssistant $ queuePushInitiation m | otherwise = inAssistant $ storeInbox m - handle _ (Ignorable _) = noop - handle _ (Unknown _) = noop - handle _ (ProtocolError _) = noop + handlemsg _ (Ignorable _) = noop + handlemsg _ (Unknown _) = noop + handlemsg _ (ProtocolError _) = noop resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do let c = formatJID jid diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs index 677bb2ff3..314ace64a 100644 --- a/Assistant/XMPP/Client.hs +++ b/Assistant/XMPP/Client.hs @@ -15,7 +15,6 @@ import Network.Protocol.XMPP import Network import Control.Concurrent import qualified Data.Text as T -import Control.Exception (SomeException) {- Everything we need to know to connect to an XMPP server. -} data XMPPCreds = XMPPCreds @@ -34,18 +33,18 @@ connectXMPP c a = case parseJID (xmppJID c) of {- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP' jid c a = reverse <$> (handle =<< lookupSRV srvrecord) +connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord) where srvrecord = mkSRVTcp "xmpp-client" $ T.unpack $ strDomain $ jidDomain jid serverjid = JID Nothing (jidDomain jid) Nothing - handle [] = do + handlesrv [] = do let h = xmppHostname c let p = PortNumber $ fromIntegral $ xmppPort c r <- run h p $ a jid return [r] - handle srvs = go [] srvs + handlesrv srvs = go [] srvs go l [] = return l go l ((h,p):rest) = do diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 301aa7185..19050c7d0 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -150,16 +150,16 @@ xmppPush cid gitpush = do SendPackOutput seqnum' b toxmpp seqnum' inh - fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handle + fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg where - handle (Just (Pushing _ (ReceivePackOutput _ b))) = + handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = liftIO $ writeChunk outh b - handle (Just (Pushing _ (ReceivePackDone exitcode))) = + handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) = liftIO $ do hPrint controlh exitcode hFlush controlh - handle (Just _) = noop - handle Nothing = do + handlemsg (Just _) = noop + handlemsg Nothing = do debug ["timeout waiting for git receive-pack output via XMPP"] -- Send a synthetic exit code to git-annex -- xmppgit, which will exit and cause git push @@ -264,12 +264,12 @@ xmppReceivePack cid = do let seqnum' = succ seqnum sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b relaytoxmpp seqnum' outh - relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handle + relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg where - handle (Just (Pushing _ (SendPackOutput _ b))) = + handlemsg (Just (Pushing _ (SendPackOutput _ b))) = liftIO $ writeChunk inh b - handle (Just _) = noop - handle Nothing = do + handlemsg (Just _) = noop + handlemsg Nothing = do debug ["timeout waiting for git send-pack output via XMPP"] -- closing the handle will make git receive-pack exit liftIO $ do diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 247c658bc..db4f768ac 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -13,7 +13,6 @@ import Common.Annex import qualified Annex import Types.Command import qualified Annex.Queue -import Annex.Exception type CommandActionRunner = CommandStart -> CommandCleanup @@ -37,14 +36,14 @@ performCommandAction Command { cmdseek = seek, cmdcheck = c, cmdname = name } pa - - This should only be run in the seek stage. -} commandAction :: CommandActionRunner -commandAction a = handle =<< tryAnnexIO go +commandAction a = account =<< tryIO go where go = do Annex.Queue.flushWhenFull callCommandAction a - handle (Right True) = return True - handle (Right False) = incerr - handle (Left err) = do + account (Right True) = return True + account (Right False) = incerr + account (Left err) = do showErr err showEndFail incerr 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 -> @@ -6,7 +6,6 @@ import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO) -import Control.Exception.Extensible as X (IOException) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) @@ -38,7 +38,6 @@ import Data.ByteString.Lazy.UTF8 (fromString) import Control.Applicative import qualified Data.Map as M import Control.Monad.IO.Class -import Control.Monad.Catch (MonadMask) import Common.Annex import qualified Utility.Gpg as Gpg diff --git a/Git/Config.hs b/Git/Config.hs index d998fd1e2..171c3e6c6 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,7 +9,6 @@ module Git.Config where import qualified Data.Map as M import Data.Char -import Control.Exception.Extensible import Common import Git diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 7de2f1be3..ecd154aa0 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -29,8 +29,6 @@ import Git.Command import Git.FilePath import Git.Sha -import Control.Exception (bracket) - {- 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 () @@ -152,8 +152,8 @@ limitCopies want = case split ":" want of go num good = case readish num of Nothing -> Left "bad number for copies" Just n -> Right $ \notpresent -> checkKey $ - handle n good notpresent - handle n good notpresent key = do + go' n good notpresent + go' n good notpresent key = do us <- filter (`S.notMember` notpresent) <$> (filterM good =<< Remote.keyLocations key) return $ length us >= n @@ -170,10 +170,10 @@ addLackingCopies approx = addLimit . limitLackingCopies approx limitLackingCopies :: Bool -> MkLimit Annex limitLackingCopies approx want = case readish want of Just needed -> Right $ \notpresent mi -> flip checkKey mi $ - handle mi needed notpresent + go mi needed notpresent Nothing -> Left "bad value for number of lacking copies" where - handle mi needed notpresent key = do + go mi needed notpresent key = do NumCopies numcopies <- if approx then approxNumCopies else case mi of diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index c96d9cd1e..b6279ccba 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -11,7 +11,6 @@ module Logs.Transfer where import Common.Annex import Annex.Perms -import Annex.Exception import qualified Git import Types.Key import Utility.Metered @@ -94,7 +93,7 @@ percentComplete (Transfer { transferKey = key }) info = mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath, MVar Integer) mkProgressUpdater t info = do tfile <- fromRepo $ transferFile t - _ <- tryAnnex $ createAnnexDirectory $ takeDirectory tfile + _ <- tryNonAsync $ createAnnexDirectory $ takeDirectory tfile mvar <- liftIO $ newMVar 0 return (liftIO . updater tfile mvar, tfile, mvar) where diff --git a/Messages.hs b/Messages.hs index 9f473110a..f27755f3a 100644 --- a/Messages.hs +++ b/Messages.hs @@ -47,7 +47,7 @@ import System.Log.Handler (setFormatter, LogHandler) import System.Log.Handler.Simple import qualified Data.Set as S -import Common +import Common hiding (handle) import Types import Types.Messages import qualified Messages.JSON as JSON @@ -56,7 +56,6 @@ import Data.Ord import Common.Annex import Types.Remote import qualified Annex -import Annex.Exception import Annex.UUID import Logs.UUID import Logs.Trust @@ -114,10 +113,10 @@ byNameWithUUID = checkuuid <=< byName byName' :: RemoteName -> Annex (Either String Remote) byName' "" = return $ Left "no remote specified" -byName' n = handle . filter matching <$> remoteList +byName' n = go . filter matching <$> remoteList where - handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" - handle (match:_) = Right match + go [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" + go (match:_) = Right match matching r = n == name r || toUUID n == uuid r {- Only matches remote name, not UUID -} @@ -315,8 +314,7 @@ isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r = repo remote hasKey :: Remote -> Key -> Annex (Either String Bool) -hasKey r k = either (Left . show) Right - <$> tryNonAsyncAnnex (checkPresent r k) +hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k) hasKeyCheap :: Remote -> Bool hasKeyCheap = checkPresentCheap diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index fba05312b..beeb4d7cc 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -8,7 +8,6 @@ module Remote.Ddar (remote) where -import Control.Exception import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import System.IO.Error diff --git a/Remote/External.hs b/Remote/External.hs index f326f26ba..4fb760afd 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -21,7 +21,6 @@ import Logs.PreferredContent.Raw import Logs.RemoteState import Config.Cost import Annex.UUID -import Annex.Exception import Creds import Control.Concurrent.STM @@ -137,7 +136,7 @@ checkKey external k = either error id <$> go _ -> Nothing safely :: Annex Bool -> Annex Bool -safely a = go =<< tryAnnex a +safely a = go =<< tryNonAsync a where go (Right r) = return r go (Left e) = do diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 983764f70..3a69ae9ea 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -32,7 +32,6 @@ module Remote.External.Types ( ) where import Common.Annex -import Annex.Exception import Types.Key (file2key, key2file) import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 55a775811..8891977f7 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -15,7 +15,7 @@ module Remote.GCrypt ( import qualified Data.Map as M import qualified Data.ByteString.Lazy as L -import Control.Exception.Extensible +import Control.Exception import Common.Annex import Types.Remote diff --git a/Remote/Git.hs b/Remote/Git.hs index da5ca4c4a..34c60d98f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -27,7 +27,6 @@ import qualified Annex import Logs.Presence import Annex.Transfer import Annex.UUID -import Annex.Exception import qualified Annex.Content import qualified Annex.BranchState import qualified Annex.Branch @@ -56,7 +55,6 @@ import Creds import Control.Concurrent import Control.Concurrent.MSampleVar import qualified Data.Map as M -import Control.Exception.Extensible remote :: RemoteType remote = RemoteType { @@ -281,7 +279,7 @@ tryGitConfigRead r s <- Annex.new r Annex.eval s $ do Annex.BranchState.disableUpdate - void $ tryAnnex $ ensureInitialized + void $ tryNonAsync $ ensureInitialized Annex.getState Annex.repo {- Checks if a given remote has the content for a key in its annex. -} diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 953c533b6..5e4ea111f 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -24,7 +24,6 @@ import Logs.Chunk import Utility.Metered import Crypto (EncKey) import Backend (isStableKey) -import Annex.Exception import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -172,7 +171,7 @@ seekResume h chunkkeys checker = do liftIO $ hSeek h AbsoluteSeek sz return (cks, toBytesProcessed sz) | otherwise = do - v <- tryNonAsyncAnnex (checker k) + v <- tryNonAsync (checker k) case v of Right True -> check pos' cks' sz @@ -231,7 +230,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink -- Optimisation: Try the unchunked key first, to avoid -- looking in the git-annex branch for chunk counts -- that are likely not there. - getunchunked `catchNonAsyncAnnex` + getunchunked `catchNonAsync` const (go =<< chunkKeysOnly u basek) | otherwise = go =<< chunkKeys u chunkconfig basek where @@ -241,7 +240,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink let ls' = maybe ls (setupResume ls) currsize if any null ls' then return True -- dest is already complete - else firstavail currsize ls' `catchNonAsyncAnnex` giveup + else firstavail currsize ls' `catchNonAsync` giveup giveup e = do warning (show e) @@ -251,20 +250,20 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink firstavail currsize ([]:ls) = firstavail currsize ls firstavail currsize ((k:ks):ls) | k == basek = getunchunked - `catchNonAsyncAnnex` (const $ firstavail currsize ls) + `catchNonAsync` (const $ firstavail currsize ls) | otherwise = do let offset = resumeOffset currsize k let p = maybe basep (offsetMeterUpdate basep . toBytesProcessed) offset - v <- tryNonAsyncAnnex $ + v <- tryNonAsync $ retriever (encryptor k) p $ \content -> bracketIO (maybe opennew openresume offset) hClose $ \h -> do void $ tosink (Just h) p content let sz = toBytesProcessed $ fromMaybe 0 $ keyChunkSize k getrest p h sz sz ks - `catchNonAsyncAnnex` giveup + `catchNonAsync` giveup case v of Left e | null ls -> giveup e @@ -372,7 +371,7 @@ checkPresentChunks checker u chunkconfig encryptor basek Right False -> return $ Right False Left e -> return $ Left $ show e - check = tryNonAsyncAnnex . checker . encryptor + check = tryNonAsync . checker . encryptor {- A key can be stored in a remote unchunked, or as a list of chunked keys. - This can be the case whether or not the remote is currently configured diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index fc0e11d2f..ba9ff4fb4 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -42,13 +42,11 @@ import Remote.Helper.Chunked as X import Remote.Helper.Encryptable as X import Remote.Helper.Messages import Annex.Content -import Annex.Exception import qualified Git import qualified Git.Command import qualified Git.Construct import qualified Data.ByteString.Lazy as L -import Control.Exception (bracket) import qualified Data.Map as M {- Special remotes don't have a configured url, so Git.Repo does not @@ -174,7 +172,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp cip = cipherKey c gpgopts = getGpgEncParams encr - safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False) + safely a = catchNonAsync a (\e -> warning (show e) >> return False) -- chunk, then encrypt, then feed to the storer storeKeyGen k p enc = safely $ preparestorer k $ safely . go diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index b70001ddb..4caebaf21 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -14,10 +14,10 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as L8 -import qualified Control.Exception.Lifted as EL import Network.HTTP.Client (HttpException(..)) import Network.HTTP.Types import System.IO.Error +import Control.Monad.Catch import Common.Annex import Types.Remote @@ -31,7 +31,6 @@ import Creds import Utility.Metered import Utility.Url (URLString) import Annex.UUID -import Annex.Exception import Remote.WebDAV.DavLocation remote :: RemoteType @@ -301,11 +300,11 @@ moveDAV baseurl src dest = inLocation src $ moveContentM newurl newurl = B8.fromString (locationUrl baseurl dest) existsDAV :: DavLocation -> DAVT IO (Either String Bool) -existsDAV l = inLocation l check `EL.catch` (\(e :: EL.SomeException) -> return (Left $ show e)) +existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) where check = do setDepth Nothing - EL.catchJust + catchJust (matchStatusCodeException notFound404) (getPropsM >> ispresent True) (const $ ispresent False) @@ -319,8 +318,7 @@ matchStatusCodeException _ _ = Nothing -- Ignores any exceptions when performing a DAV action. safely :: DAVT IO a -> DAVT IO (Maybe a) -safely a = (Just <$> a) - `EL.catch` (\(_ :: EL.SomeException) -> return Nothing) +safely = eitherToMaybe <$$> tryNonAsync choke :: IO (Either String a) -> IO a choke f = do @@ -336,7 +334,7 @@ withDAVHandle r a = do mcreds <- getCreds (config r) (uuid r) case (mcreds, configUrl r) of (Just (user, pass), Just baseurl) -> - bracketIO (mkDAVContext baseurl) closeDAVContext $ \ctx -> + withDAVContext baseurl $ \ctx -> a (Just (DavHandle ctx (toDavUser user) (toDavPass pass) baseurl)) _ -> a Nothing diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs index 65c313852..db6b6127c 100644 --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -108,10 +108,10 @@ data Status = Stopping | ConnectionClosed {- Make connection robustly, with exponentioal backoff on failure. -} robustly :: Int -> IO Status -> IO () -robustly backoff a = handle =<< catchDefaultIO ConnectionClosed a +robustly backoff a = caught =<< catchDefaultIO ConnectionClosed a where - handle Stopping = return () - handle ConnectionClosed = do + caught Stopping = return () + caught ConnectionClosed = do threadDelaySeconds (Seconds backoff) robustly increasedbackoff a @@ -20,7 +20,6 @@ import Options.Applicative hiding (command) #if MIN_VERSION_optparse_applicative(0,8,0) import qualified Options.Applicative.Types as Opt #endif -import Control.Exception.Extensible import qualified Data.Map as M import qualified Text.JSON @@ -1444,7 +1443,7 @@ indir testenv dir a = do (try a::IO (Either SomeException ())) case r of Right () -> return () - Left e -> throw e + Left e -> throwM e setuprepo :: TestEnv -> FilePath -> IO FilePath setuprepo testenv dir = do diff --git a/Utility/Directory.hs b/Utility/Directory.hs index ade5ef811..a4429d5b9 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -11,7 +11,6 @@ module Utility.Directory where import System.IO.Error import System.Directory -import Control.Exception (throw, bracket) import Control.Monad import Control.Monad.IfElse import System.FilePath @@ -114,7 +113,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename whenM (isdir dest) rethrow viaTmp mv dest undefined where - rethrow = throw e + rethrow = throwM e mv tmp _ = do ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] unless ok $ do diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 13c9d508a..802e9e24b 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -7,11 +7,25 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, +) where +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) -import Control.Monad.Catch import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data @@ -44,14 +58,20 @@ catchIO = catch tryIO :: MonadCatch m => m a -> m (Either IOException a) tryIO = try +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) + {- Catches all exceptions except for async exceptions. - This is often better to use than catching them all, so that - ThreadKilled and UserInterrupt get through. -} catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` - [ Handler (\ (e :: AsyncException) -> throwM e) - , Handler (\ (e :: SomeException) -> onerr e) + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) ] tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index c2ef683a8..832250bde 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -11,7 +11,6 @@ module Utility.FileMode where import System.IO import Control.Monad -import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 410259b11..dfca82778 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -13,7 +13,6 @@ import Control.Applicative import Control.Concurrent import Control.Monad.IO.Class import qualified Data.Map as M -import Control.Monad.Catch (bracket, MonadMask) import Common import qualified Build.SysConfig as SysConfig diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index 1ee224ffc..76f8903f5 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -102,13 +102,13 @@ findClose l = in (Group (reverse g), rest) where go c [] = (c, []) -- not picky about extra Close - go c (t:ts) = handle t + go c (t:ts) = dispatch t where - handle Close = (c, ts) - handle Open = + dispatch Close = (c, ts) + dispatch Open = let (c', ts') = go [] ts in go (Group (reverse c') : c) ts' - handle _ = go (One t:c) ts + dispatch _ = go (One t:c) ts {- Checks if a Matcher matches, using a supplied function to check - the value of Operations. -} diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs index 239c81e7b..7966811ab 100644 --- a/Utility/Parallel.hs +++ b/Utility/Parallel.hs @@ -10,7 +10,6 @@ module Utility.Parallel where import Common import Control.Concurrent -import Control.Exception {- Runs an action in parallel with a set of values, in a set of threads. - In order for the actions to truely run in parallel, requires GHC's diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 7da5cc284..edd82f5ac 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -14,7 +14,6 @@ import System.Directory import Control.Monad.IfElse import System.FilePath import Control.Monad.IO.Class -import Control.Monad.Catch (bracket, MonadMask) import Utility.Exception import Utility.FileSystemEncoding @@ -33,11 +32,11 @@ viaTmp a file content = bracket setup cleanup use setup = do createDirectoryIfMissing True dir openTempFile dir template - cleanup (tmpfile, handle) = do - _ <- tryIO $ hClose handle + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h tryIO $ removeFile tmpfile - use (tmpfile, handle) = do - hClose handle + use (tmpfile, h) = do + hClose h a tmpfile content rename tmpfile file @@ -54,10 +53,10 @@ withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath - withTmpFileIn tmpdir template a = bracket create remove use where create = liftIO $ openTempFile tmpdir template - remove (name, handle) = liftIO $ do - hClose handle + remove (name, h) = liftIO $ do + hClose h catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle + use (name, h) = a name h {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp diff --git a/Utility/Url.hs b/Utility/Url.hs index bf2d3859c..4137a5d8b 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -51,11 +51,11 @@ checkBoth url expected_size uo = do v <- check url expected_size uo return (fst v && snd v) check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) -check url expected_size = handle <$$> exists url +check url expected_size = go <$$> exists url where - handle (False, _) = (False, False) - handle (True, Nothing) = (True, True) - handle (True, s) = case expected_size of + go (False, _) = (False, False) + go (True, Nothing) = (True, True) + go (True, s) = case expected_size of Just _ -> (True, expected_size == s) Nothing -> (True, True) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 0f3378a15..6bcfce919 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -38,10 +38,6 @@ import Data.Byteable #ifdef __ANDROID__ import Data.Endian #endif -#if defined(__ANDROID__) || defined (mingw32_HOST_OS) -#else -import Control.Exception (bracketOnError) -#endif localhost :: HostName localhost = "localhost" diff --git a/debian/control b/debian/control index 66d340e3c..821629297 100644 --- a/debian/control +++ b/debian/control @@ -26,7 +26,6 @@ Build-Depends: libghc-ifelse-dev, libghc-bloomfilter-dev, libghc-edit-distance-dev, - libghc-extensible-exceptions-dev, libghc-hinotify-dev [linux-any], libghc-stm-dev (>= 2.3), libghc-dbus-dev (>= 0.10.3) [linux-any], diff --git a/git-annex.cabal b/git-annex.cabal index 8f36bfe48..8dd42ee2f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -96,8 +96,7 @@ Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, containers, utf8-string, network (>= 2.0), mtl (>= 2), - bytestring, old-locale, time, HTTP, - extensible-exceptions, dataenc, SHA, process, json, + bytestring, old-locale, time, HTTP, dataenc, SHA, process, json, base (>= 4.5 && < 4.9), monad-control, exceptions (>= 0.5), IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process, SafeSemaphore, uuid, random, dlist, unix-compat, async, stm (>= 2.3), @@ -143,7 +142,7 @@ Executable git-annex if flag(WebDAV) Build-Depends: DAV (>= 0.8), - http-client, http-conduit, http-types, lifted-base, transformers + http-client, http-conduit, http-types CPP-Options: -DWITH_WEBDAV if flag(Assistant) && ! os(solaris) |