summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2015-09-13 13:39:18 -0400
committerJoey Hess2015-09-13 13:39:31 -0400
commit4125916b67126a0cf17fe5b382a1f37cceec2760 (patch)
treef9128e91a5eef2819676ba14a247667c4fa1d8bd /src/Utility
parentf256b24aa87409a599b388f0a7848aa9abecaa7f (diff)
merge from git-annex
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/Exception.hs16
-rw-r--r--src/Utility/Process.hs40
2 files changed, 39 insertions, 17 deletions
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index a1f96615..13000e03 100644
--- a/src/Utility/Exception.hs
+++ b/src/Utility/Exception.hs
@@ -1,6 +1,6 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -20,6 +20,7 @@ module Utility.Exception (
catchNonAsync,
tryNonAsync,
tryWhenExists,
+ catchHardwareFault,
) where
import Control.Monad.Catch as X hiding (Handler)
@@ -27,7 +28,9 @@ import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
-import System.IO.Error (isDoesNotExistError)
+import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
+import GHC.IO.Exception (IOErrorType(..))
+
import Utility.Data
{- Catches IO errors and returns a Bool -}
@@ -84,3 +87,12 @@ tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
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
+ where
+ onlyhw e
+ | ioeGetErrorType e == HardwareFault = onhardwareerr e
+ | otherwise = throwM e
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index bd179d09..c4882a01 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -31,6 +31,7 @@ module Utility.Process (
withQuietOutput,
feedWithQuietOutput,
createProcess,
+ waitForProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
@@ -42,7 +43,7 @@ module Utility.Process (
import qualified System.Process
import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
-import System.Process hiding (createProcess, readProcess)
+import System.Process hiding (createProcess, readProcess, waitForProcess)
import System.Exit
import System.IO
import System.Log.Logger
@@ -345,18 +346,6 @@ oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
--- | Debugging trace for a CreateProcess.
-debugProcess :: CreateProcess -> IO ()
-debugProcess p = debugM "Utility.Process" $ unwords [action ++ ":", showCmd p]
- where
- action
- | piped (std_in p) && piped (std_out p) = "chat"
- | piped (std_in p) = "feed"
- | piped (std_out p) = "read"
- | otherwise = "call"
- piped Inherit = False
- piped _ = True
-
-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
@@ -381,9 +370,30 @@ startInteractiveProcess cmd args environ = do
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
--- | Wrapper around 'System.Process.createProcess' from System.Process,
--- that does debug logging.
+-- | Wrapper around 'System.Process.createProcess' that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p
System.Process.createProcess p
+
+-- | Debugging trace for a CreateProcess.
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.
+waitForProcess :: ProcessHandle -> IO ExitCode
+waitForProcess h = do
+ r <- System.Process.waitForProcess h
+ debugM "Utility.Process" ("process done " ++ show r)
+ return r