From 4125916b67126a0cf17fe5b382a1f37cceec2760 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 13 Sep 2015 13:39:18 -0400
Subject: merge from git-annex

---
 src/Utility/Exception.hs | 16 ++++++++++++++--
 src/Utility/Process.hs   | 40 +++++++++++++++++++++++++---------------
 2 files changed, 39 insertions(+), 17 deletions(-)

(limited to 'src')

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
-- 
cgit v1.3-2-g0d8e