summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/Branch.hs10
-rw-r--r--Annex/Content.hs12
-rw-r--r--Crypto.hs2
-rw-r--r--Git.hs2
-rw-r--r--Remote/Bup.hs13
-rw-r--r--Remote/Directory.hs15
-rw-r--r--Remote/Git.hs12
-rw-r--r--Remote/Hook.hs7
-rw-r--r--Remote/Rsync.hs2
-rw-r--r--Remote/S3real.hs2
-rw-r--r--Upgrade/V1.hs2
-rw-r--r--Upgrade/V2.hs2
-rw-r--r--Utility/Misc.hs21
-rw-r--r--Utility/TempFile.hs4
-rw-r--r--git-annex-shell.hs9
15 files changed, 54 insertions, 61 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index 189289ad3..6c28a0c84 100644
--- a/Annex/Branch.hs
+++ b/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
- g <- gitRepo
- liftIO $ catch (liftM Just . readFileStrict $ journalFile g file)
- (const $ return Nothing)
+getJournalFile file = inRepo $ \g -> catchMaybeIO $
+ readFileStrict $ journalFile g file
{- 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)
- (const $ return [])
+ fs <- liftIO $
+ catchDefaultIO (getDirectoryContents $ gitAnnexJournalDir g) []
return $ filter (`notElem` [".", ".."]) fs
{- Stages the specified journalfiles. -}
diff --git a/Annex/Content.hs b/Annex/Content.hs
index f50616af9..7586bb96f 100644
--- a/Annex/Content.hs
+++ b/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 $
- catch (Just <$> openFd file mode Nothing defaultFileFlags)
- (const $ return Nothing)
+openForLock file writelock = bracket_ prep cleanup go
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,
- - but -}
- prep = forwritelock $ allowWrite file
- cleanup = forwritelock $ preventWrite file
+ - exclusive lock. -}
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
diff --git a/Crypto.hs b/Crypto.hs
index b3acb30a6..24bb79ba0 100644
--- a/Crypto.hs
+++ b/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
diff --git a/Git.hs b/Git.hs
index 6fb6e8361..5ceaa67f7 100644
--- a/Git.hs
+++ b/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.
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 866d4b42d..4c826498d 100644
--- a/Remote/Bup.hs
+++ b/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 ()
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 6d3a5da7d..b592f41ff 100644
--- a/Remote/Directory.hs
+++ b/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
- where
- check = liftIO $ try $ doesFileExist (dirKey d k)
- dispatch (Left e) = Left $ show e
- dispatch (Right v) = Right v
+checkPresent d k = liftIO $ catchMsgIO $ doesFileExist (dirKey d k)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index b63a8f124..30d992e8c 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -134,11 +134,7 @@ inAnnex r key
| Git.repoIsUrl r = checkremote
| otherwise = checklocal
where
- checkhttp = dispatch <$> check
- where
- check = safely $ Url.exists $ keyUrl r key
- dispatch (Left e) = Left $ show e
- dispatch (Right v) = Right v
+ checkhttp = liftIO $ catchMsgIO $ Url.exists $ keyUrl r key
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
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 9f9250e41..03976fc70 100644
--- a/Remote/Hook.hs
+++ b/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
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 54834be13..86ff2ea5b 100644
--- a/Remote/Rsync.hs
+++ b/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
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index 29117b3a4..97ac64821 100644
--- a/Remote/S3real.hs
+++ b/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
diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs
index fe59ad3da..377e4b21b 100644
--- a/Upgrade/V1.hs
+++ b/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
diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs
index 7ef2a4d18..6a46ad8a1 100644
--- a/Upgrade/V2.hs
+++ b/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
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 4c4aa4c93..728598723 100644
--- a/Utility/Misc.hs
+++ b/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
-catchBool = flip catch (const $ return False)
+catchBoolIO :: IO Bool -> IO Bool
+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
diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs
index 1e823c10e..8d50dd8b2 100644
--- a/Utility/TempFile.hs
+++ b/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
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index 12cc65e4d..57f6b2916 100644
--- a/git-annex-shell.hs
+++ b/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 ())
- where
- check = do
- val <- getEnv var
- when (not $ null val) $
- error $ "Action blocked by " ++ var
+checkEnv var =
+ whenM (not . null <$> catchDefaultIO (getEnv var) "") $
+ error $ "Action blocked by " ++ var
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-24 22:10:51 +0000