diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 78d527920d..da29c4ae46 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -7,7 +7,7 @@ module Assistant.Threads.XMPPClient where -import Assistant.Common +import Assistant.Common hiding (ProtocolError) import Assistant.XMPP import Assistant.XMPP.Client import Assistant.NetMessager diff --git a/Assistant/WebApp/Common.hs b/Assistant/WebApp/Common.hs index eb5adfd7f1..a148dcabdb 100644 --- a/Assistant/WebApp/Common.hs +++ b/Assistant/WebApp/Common.hs @@ -13,5 +13,5 @@ import Assistant.WebApp.Page as X import Assistant.WebApp.Form as X import Assistant.WebApp.Types as X import Assistant.WebApp.RepoId as X -import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option) +import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option, PermissionDenied) import Data.Text as X (Text) diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 7f61c4f3eb..7967b17141 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -108,17 +108,16 @@ selectExtension f {- A key's checksum is checked during fsck. -} checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool -checkKeyChecksum hash key file = go `catchHardwareFault` hwfault +checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do + fast <- Annex.getState Annex.fast + mstat <- liftIO $ catchMaybeIO $ getFileStatus file + case (mstat, fast) of + (Just stat, False) -> do + filesize <- liftIO $ getFileSize' file stat + showAction "checksum" + check <$> hashFile hash file filesize + _ -> return True where - go = do - fast <- Annex.getState Annex.fast - mstat <- liftIO $ catchMaybeIO $ getFileStatus file - case (mstat, fast) of - (Just stat, False) -> do - filesize <- liftIO $ getFileSize' file stat - showAction "checksum" - check <$> hashFile hash file filesize - _ -> return True expected = keyHash key check s | s == expected = True diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 13000e033f..8b110ae6de 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -20,7 +20,8 @@ module Utility.Exception ( catchNonAsync, tryNonAsync, tryWhenExists, - catchHardwareFault, + catchIOErrorType, + IOErrorType(..) ) where import Control.Monad.Catch as X hiding (Handler) @@ -88,11 +89,11 @@ tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a return (eitherToMaybe v) -{- Catches only exceptions caused by hardware faults. - - Ie, disk IO error. -} -catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a -catchHardwareFault a onhardwareerr = catchIO a onlyhw +{- Catches only IO exceptions of a particular type. + - Ie, use HardwareFault to catch disk IO errors. -} +catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a +catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching where - onlyhw e - | ioeGetErrorType e == HardwareFault = onhardwareerr e + onlymatching e + | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e