factored out some useful error catching methods

Annex/Branch.hs

@@ -295,10 +295,8 @@ setJournalFile file content = do
 
 {- Gets any journalled content for a file in the branch. -}
 getJournalFile :: FilePath -> Annex (Maybe String)
-getJournalFile file = do
+getJournalFile file = inRepo $ \g -> catchMaybeIO $
-	g <- gitRepo
+	readFileStrict $ journalFile g file
-	liftIO $ catch (liftM Just . readFileStrict $ journalFile g file)
-		(const $ return Nothing)
 
 {- List of files that have updated content in the journal. -}
 getJournalledFiles :: Annex [FilePath]
@@ -308,8 +306,8 @@ getJournalledFiles = map fileJournal <$> getJournalFiles
 getJournalFiles :: Annex [FilePath]
 getJournalFiles = do
 	g <- gitRepo
-	fs <- liftIO $ catch (getDirectoryContents $ gitAnnexJournalDir g)
+	fs <- liftIO $
-		(const $ return [])
+		catchDefaultIO (getDirectoryContents $ gitAnnexJournalDir g) []
 	return $ filter (`notElem` [".", ".."]) fs
 
 {- Stages the specified journalfiles. -}

Annex/Content.hs

@@ -83,19 +83,17 @@ lockContent key a = do
 		unlock (Just l) = closeFd l
 
 openForLock :: FilePath -> Bool -> IO (Maybe Fd)
-openForLock file writelock = bracket_ prep cleanup $
+openForLock file writelock = bracket_ prep cleanup go
-	catch (Just <$> openFd file mode Nothing defaultFileFlags)
-		(const $ return Nothing)
 	where
+		go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
 		mode = if writelock then ReadWrite else ReadOnly
 		{- Since files are stored with the write bit disabled,
 		 - have to fiddle with permissions to open for an
-		 - exclusive lock. flock locking would avoid this,
+		 - exclusive lock. -}
-		 - but -}
-		prep = forwritelock $ allowWrite file
-		cleanup = forwritelock $ preventWrite file
 		forwritelock a = 
 			when writelock $ whenM (doesFileExist file) $ a
+		prep = forwritelock $ allowWrite file
+		cleanup = forwritelock $ preventWrite file
 
 {- Calculates the relative path to use to link a file to a key. -}
 calcGitLink :: FilePath -> Key -> Annex FilePath

Crypto.hs

@@ -173,7 +173,7 @@ gpgParams :: [CommandParam] -> IO [String]
 gpgParams params = do
 	-- Enable batch mode if GPG_AGENT_INFO is set, to avoid extraneous
 	-- gpg output about password prompts.
-	e <- catch (getEnv "GPG_AGENT_INFO") (const $ return "")
+	e <- catchDefaultIO (getEnv "GPG_AGENT_INFO") ""
 	let batch = if null e then [] else ["--batch"]
 	return $ batch ++ defaults ++ toCommand params
 	where

Git.hs

@@ -414,7 +414,7 @@ pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$>
 reap :: IO ()
 reap = do
 	-- throws an exception when there are no child processes
-	r <- catch (getAnyProcessStatus False True) (\_ -> return Nothing)
+	r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
 	maybe (return ()) (const reap) r
 
 {- Forces git to use the specified index file.

Remote/Bup.hs

@@ -110,21 +110,21 @@ storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool
 storeEncrypted r buprepo (cipher, enck) k = do
 	src <- fromRepo $ gitAnnexLocation k
 	params <- bupSplitParams r buprepo enck (Param "-")
-	liftIO $ catchBool $
+	liftIO $ catchBoolIO $
 		withEncryptedHandle cipher (L.readFile src) $ \h ->
 			pipeBup params (Just h) Nothing
 
 retrieve :: BupRepo -> Key -> FilePath -> Annex Bool
 retrieve buprepo k f = do
 	let params = bupParams "join" buprepo [Param $ show k]
-	liftIO $ catchBool $ do
+	liftIO $ catchBoolIO $ do
 		tofile <- openFile f WriteMode
 		pipeBup params Nothing (Just tofile)
 
 retrieveEncrypted :: BupRepo -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted buprepo (cipher, enck) f = do
 	let params = bupParams "join" buprepo [Param $ show enck]
-	liftIO $ catchBool $ do
+	liftIO $ catchBoolIO $ do
 		(pid, h) <- hPipeFrom "bup" $ toCommand params
 		withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
 		forceSuccess pid
@@ -145,15 +145,12 @@ checkPresent r bupr k
 		showAction $ "checking " ++ Git.repoDescribe r
 		ok <- onBupRemote bupr boolSystem "git" params
 		return $ Right ok
-	| otherwise = dispatch <$> localcheck
+	| otherwise = liftIO $ catchMsgIO $
+		boolSystem "git" $ Git.gitCommandLine params bupr
 	where
 		params = 
 			[ Params "show-ref --quiet --verify"
 			, Param $ "refs/heads/" ++ show k]
-		localcheck = liftIO $ try $
-			boolSystem "git" $ Git.gitCommandLine params bupr
-		dispatch (Left e) = Left $ show e
-		dispatch (Right v) = Right v
 
 {- Store UUID in the annex.uuid setting of the bup repository. -}
 storeBupUUID :: UUID -> BupRepo -> Annex ()

Remote/Directory.hs

@@ -8,7 +8,6 @@
 module Remote.Directory (remote) where
 
 import qualified Data.ByteString.Lazy.Char8 as L
-import System.IO.Error
 import qualified Data.Map as M
 
 import Common.Annex
@@ -72,13 +71,13 @@ store :: FilePath -> Key -> Annex Bool
 store d k = do
 	src <- fromRepo $ gitAnnexLocation k
 	let dest = dirKey d k
-	liftIO $ catchBool $ storeHelper dest $ copyFileExternal src dest
+	liftIO $ catchBoolIO $ storeHelper dest $ copyFileExternal src dest
 
 storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool
 storeEncrypted d (cipher, enck) k = do
 	src <- fromRepo $ gitAnnexLocation k
 	let dest = dirKey d enck
-	liftIO $ catchBool $ storeHelper dest $ encrypt src dest
+	liftIO $ catchBoolIO $ storeHelper dest $ encrypt src dest
 	where
 		encrypt src dest = do
 			withEncryptedContent cipher (L.readFile src) $ L.writeFile dest
@@ -100,12 +99,12 @@ retrieve d k f = liftIO $ copyFileExternal (dirKey d k) f
 
 retrieveEncrypted :: FilePath -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted d (cipher, enck) f =
-	liftIO $ catchBool $ do
+	liftIO $ catchBoolIO $ do
 		withDecryptedContent cipher (L.readFile (dirKey d enck)) $ L.writeFile f
 		return True
 
 remove :: FilePath -> Key -> Annex Bool
-remove d k = liftIO $ catchBool $ do
+remove d k = liftIO $ catchBoolIO $ do
 	allowWrite dir
 	removeFile file
 	removeDirectory dir
@@ -115,8 +114,4 @@ remove d k = liftIO $ catchBool $ do
 		dir = parentDir file
 
 checkPresent :: FilePath -> Key -> Annex (Either String Bool)
-checkPresent d k = dispatch <$> check
+checkPresent d k = liftIO $ catchMsgIO $ doesFileExist (dirKey d k)
-	where
-		check = liftIO $ try $ doesFileExist (dirKey d k)
-		dispatch (Left e) = Left $ show e
-		dispatch (Right v) = Right v

Remote/Git.hs

@@ -134,11 +134,7 @@ inAnnex r key
 	| Git.repoIsUrl r = checkremote
 	| otherwise = checklocal
 	where
-		checkhttp = dispatch <$> check
+		checkhttp = liftIO $ catchMsgIO $ Url.exists $ keyUrl r key
-			where
-				check = safely $ Url.exists $ keyUrl r key
-				dispatch (Left e) = Left $ show e
-				dispatch (Right v) = Right v
 		checkremote = do
 			showAction $ "checking " ++ Git.repoDescribe r
 			onRemote r (check, unknown) "inannex" [Param (show key)]
@@ -149,13 +145,11 @@ inAnnex r key
 				dispatch _ = unknown
 		checklocal = dispatch <$> check
 			where
-				check = safely $ onLocal r $
+				check = liftIO $ catchMsgIO $ onLocal r $
 					Annex.Content.inAnnexSafe key
-				dispatch (Left e) = Left $ show e
+				dispatch (Left e) = Left e
 				dispatch (Right (Just b)) = Right b
 				dispatch (Right Nothing) = unknown
-		safely :: IO a -> Annex (Either IOException a)
-		safely a = liftIO $ try a
 		unknown = Left $ "unable to check " ++ Git.repoDescribe r
 
 {- Runs an action on a local repository inexpensively, by making an annex

Remote/Hook.hs

@@ -9,7 +9,6 @@ module Remote.Hook (remote) where
 
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
-import System.IO.Error (try)
 import System.Exit
 
 import Common.Annex
@@ -112,7 +111,7 @@ retrieve h k f = runHook h "retrieve" k (Just f) $ return True
 
 retrieveEncrypted :: String -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted h (cipher, enck) f = withTmp enck $ \tmp ->
-	runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBool $ do
+	runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBoolIO $ do
 		withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
 		return True
 
@@ -123,12 +122,10 @@ checkPresent :: Git.Repo -> String -> Key -> Annex (Either String Bool)
 checkPresent r h k = do
 	showAction $ "checking " ++ Git.repoDescribe r
 	v <- lookupHook h "checkpresent"
-	dispatch <$> liftIO (try (check v) ::IO (Either IOException Bool))
+	liftIO $ catchMsgIO $ check v
 	where
 		findkey s = show k `elem` lines s
 		env = hookEnv k Nothing
-		dispatch (Left e) = Left $ show e
-		dispatch (Right v) = Right v
 		check Nothing = error "checkpresent hook misconfigured"
 		check (Just hook) = do
 			(frompipe, topipe) <- createPipe

Remote/Rsync.hs

@@ -110,7 +110,7 @@ retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted o (cipher, enck) f = withTmp enck $ \tmp -> do
 	res <- retrieve o enck tmp
 	if res
-		then liftIO $ catchBool $ do
+		then liftIO $ catchBoolIO $ do
 			withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
 			return True
 		else return res

Remote/S3real.hs

@@ -286,7 +286,7 @@ s3GetCreds c = do
 				_ -> return Nothing
 		else return $ Just (ak, sk)
 	where
-		getEnvKey s = liftIO $ catch (getEnv s) (const $ return "")
+		getEnvKey s = liftIO $ catchDefaultIO (getEnv s) ""
 
 {- Stores S3 creds encrypted in the remote's config if possible. -}
 s3SetCreds :: RemoteConfig -> Annex RemoteConfig

Upgrade/V1.hs

@@ -179,7 +179,7 @@ writeLog1 :: FilePath -> [LogLine] -> IO ()
 writeLog1 file ls = viaTmp writeFile file (showLog ls)
 
 readLog1 :: FilePath -> IO [LogLine]
-readLog1 file = catch (parseLog <$> readFileStrict file) (const $ return [])
+readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) []
 
 lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
 lookupFile1 file = do

Upgrade/V2.hs

@@ -69,7 +69,7 @@ locationLogs = do
 		files <- mapM tryDirContents (concat levelb)
 		return $ mapMaybe islogfile (concat files)
 	where
-		tryDirContents d = catch (dirContents d) (return . const [])
+		tryDirContents d = catchDefaultIO (dirContents d) []
 		islogfile f = maybe Nothing (\k -> Just (k, f)) $
 				logFileKey $ takeFileName f
 

Utility/Misc.hs

@@ -8,7 +8,9 @@
 module Utility.Misc where
 
 import System.IO
+import System.IO.Error (try)
 import Control.Monad
+import Control.Applicative
 
 {- A version of hgetContents that is not lazy. Ensures file is 
  - all read before it gets closed. -}
@@ -26,5 +28,20 @@ readMaybe s = case reads s of
 	_ -> Nothing
 
 {- Catches IO errors and returns a Bool -}
-catchBool :: IO Bool -> IO Bool
+catchBoolIO :: IO Bool -> IO Bool
-catchBool = flip catch (const $ return False)
+catchBoolIO a = catchDefaultIO a False
+
+{- Catches IO errors and returns a Maybe -}
+catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing
+
+{- Catches IO errors and returns a default value. -}
+catchDefaultIO :: IO a -> a -> IO a
+catchDefaultIO a def = catch a (const $ return def)
+
+{- Catches IO errors and returns the error message. -}
+catchMsgIO :: IO a -> IO (Either String a)
+catchMsgIO a = dispatch <$> try a
+	where
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v

Utility/TempFile.hs

@@ -31,9 +31,9 @@ withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a
 withTempFile template a = bracket create remove use
 	where
 		create = do
-			tmpdir <- catch getTemporaryDirectory (const $ return ".")
+			tmpdir <- catchDefaultIO getTemporaryDirectory "."
 			openTempFile tmpdir template
 		remove (name, handle) = do
 			hClose handle
-			catchBool (removeFile name >> return True)
+			catchBoolIO (removeFile name >> return True)
 		use (name, handle) = a name handle

git-annex-shell.hs

@@ -104,9 +104,6 @@ checkNotReadOnly cmd
 	| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"
 
 checkEnv :: String -> IO ()
-checkEnv var = catch check (const $ return ())
+checkEnv var =
-	where
+	whenM (not . null <$> catchDefaultIO (getEnv var) "") $
-		check = do
+		error $ "Action blocked by " ++ var
-			val <- getEnv var
-			when (not $ null val) $
-				error $ "Action blocked by " ++ var