diff options
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) |