Merge branch 'joeyconfig'

5 files changed, 44 insertions, 29 deletions

diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index 9d4236c4..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 -}
@@ -36,10 +39,7 @@ catchBoolIO = catchDefaultIO False
 
 {- Catches IO errors and returns a Maybe -}
 catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
-catchMaybeIO a = do
-	catchDefaultIO Nothing $ do
-		v <- a
-		return (Just v)
+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)
 
 {- Catches IO errors and returns a default value. -}
 catchDefaultIO :: MonadCatch m => a -> m a -> m a
@@ -87,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/Misc.hs b/src/Utility/Misc.hs
index 45d5a063..ebb42576 100644
--- a/src/Utility/Misc.hs
+++ b/src/Utility/Misc.hs
@@ -136,7 +136,7 @@ hGetSomeString h sz = do
  - if this reap gets there first. -}
 reapZombies :: IO ()
 #ifndef mingw32_HOST_OS
-reapZombies = do
+reapZombies =
 	-- throws an exception when there are no child processes
 	catchDefaultIO Nothing (getAnyProcessStatus False True)
 		>>= maybe (return ()) (const reapZombies)
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 469f7659..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
@@ -171,7 +172,7 @@ createBackgroundProcess p a = a =<< createProcess p
 -- returns a transcript combining its stdout and stderr, and
 -- whether it succeeded or failed.
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+processTranscript cmd opts = processTranscript' cmd opts Nothing
 
 processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
 processTranscript' cmd opts environ input = do
@@ -345,22 +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 = do
-	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
@@ -385,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
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index b3813323..5e813d4a 100644
--- a/src/Utility/Scheduled.hs
+++ b/src/Utility/Scheduled.hs
@@ -286,7 +286,7 @@ fromScheduledTime AnyTime = "any time"
 fromScheduledTime (SpecificTime h m) = 
 	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
   where
-	pad n s = take (n - length s) (repeat '0') ++ s
+	pad n s = replicate (n - length s) '0' ++ s
 	(h', ampm)
 		| h == 0 = (12, "AM")
 		| h < 12 = (h, "AM")
diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs
index 20adf40d..6d4c045b 100644
--- a/src/Utility/Table.hs
+++ b/src/Utility/Table.hs
@@ -26,4 +26,4 @@ formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table
 		sumcols (map (map length) table)
 	sumcols [] = repeat 0
 	sumcols [r] = r
-	sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs
+	sumcols (r1:r2:rs) = sumcols $ zipWith max r1 r2 : rs