diff --git a/BuildBox/Build.hs b/BuildBox/Build.hs --- a/BuildBox/Build.hs +++ b/BuildBox/Build.hs @@ -36,19 +36,25 @@ import BuildBox.Build.BuildState import BuildBox.Build.BuildError import Control.Monad.State +import Control.Monad.Catch import System.IO import Prelude +-- | Alias for 'throwM' from Control.Monad.Catch. +throw :: (MonadThrow m, Exception e) => e -> m a +throw = throwM + + -- | Log a system command to the handle in our `BuildConfig`, if any. logSystem :: String -> Build () logSystem cmd = do mHandle <- gets buildStateLogSystem case mHandle of Nothing -> return () - Just handle - -> do io $ hPutStr handle "buildbox system: " - io $ hPutStrLn handle cmd + Just h + -> do io $ hPutStr h "buildbox system: " + io $ hPutStrLn h cmd return () diff --git a/BuildBox/Build/Base.hs b/BuildBox/Build/Base.hs --- a/BuildBox/Build/Base.hs +++ b/BuildBox/Build/Base.hs @@ -4,16 +4,15 @@ import BuildBox.Pretty import BuildBox.Build.BuildError import BuildBox.Build.BuildState -import Control.Monad.Error +import Control.Monad.Catch import Control.Monad.State -import Control.Exception (try) import System.IO -import System.Random import System.Directory + -- | The builder monad encapsulates and IO action that can fail with an error, -- and also read some global configuration info. -type Build a = ErrorT BuildError (StateT BuildState IO) a +type Build a = StateT BuildState IO a -- Build ------------------------------------------------------------------------------------------ @@ -21,26 +20,24 @@ -- temporary files (like \"/tmp\") runBuild :: FilePath -> Build a -> IO (Either BuildError a) runBuild scratchDir build - = do uid <- getUniqueId - let s = buildStateDefault uid scratchDir - evalStateT (runErrorT build) s + = do let s = buildStateDefault scratchDir + try $ evalStateT build s -- | Like 'runBuild`, but report whether it succeeded to the console. -- If it succeeded then return Just the result, else Nothing. runBuildPrint :: FilePath -> Build a -> IO (Maybe a) runBuildPrint scratchDir build - = do uid <- getUniqueId - let s = buildStateDefault uid scratchDir + = do let s = buildStateDefault scratchDir runBuildPrintWithState s build -- | Like `runBuild` but also takes a `BuildState`. runBuildWithState :: BuildState -> Build a -> IO (Maybe a) runBuildWithState s build - = do result <- evalStateT (runErrorT build) s + = do result <- try $ evalStateT build s case result of - Left err + Left (err :: BuildError) -> do putStrLn $ render $ ppr err return $ Nothing @@ -51,9 +48,9 @@ -- | Like `runBuildPrint` but also takes a `BuildState`. runBuildPrintWithState :: BuildState -> Build a -> IO (Maybe a) runBuildPrintWithState s build - = do result <- evalStateT (runErrorT build) s + = do result <- try $ evalStateT build s case result of - Left err + Left (err :: BuildError) -> do putStrLn "\nBuild failed" putStr " due to " putStrLn $ render $ ppr err @@ -70,29 +67,7 @@ successfully f = f >> return () --- | Get a unique(ish) id for this process. --- The random seeds the global generator with the cpu time in psecs, which should be good enough. -getUniqueId :: IO Integer -getUniqueId - = randomRIO (0, 1000000000) - -- Errors ----------------------------------------------------------------------------------------- --- | Throw an error in the build monad. -throw :: BuildError -> Build a -throw = throwError - - --- | Run a build command, catching any exceptions it sends. -catch :: Build a -> (BuildError -> Build a) -> Build a -catch build handle - = do s <- get - (result, s') <- io $ runStateT (runErrorT build) s - case result of - Left err -> handle err - Right x - -> do put s' - return x - -- | Throw a needs error saying we needs the given file. -- A catcher could then usefully create the file, or defer the compuation until it has been -- created. @@ -103,7 +78,7 @@ if isFile || isDir then return () - else throw $ ErrorNeeds filePath + else throwM $ ErrorNeeds filePath -- Utils ------------------------------------------------------------------------------------------ @@ -116,7 +91,7 @@ result <- liftIO $ try x case result of - Left err -> throw $ ErrorIOError err + Left err -> throwM $ ErrorIOError err Right res -> return res diff --git a/BuildBox/Build/BuildError.hs b/BuildBox/Build/BuildError.hs --- a/BuildBox/Build/BuildError.hs +++ b/BuildBox/Build/BuildError.hs @@ -5,8 +5,9 @@ (BuildError(..)) where import BuildBox.Pretty +import Control.Monad.Catch +import Data.Typeable import System.Exit -import Control.Monad.Error import BuildBox.Data.Log (Log) import qualified BuildBox.Data.Log as Log @@ -33,10 +34,11 @@ -- | A build command needs the following file to continue. -- This can be used for writing make-like bots. | ErrorNeeds FilePath + deriving Typeable + +instance Exception BuildError -instance Error BuildError where - strMsg s = ErrorOther s instance Pretty BuildError where ppr err diff --git a/BuildBox/Build/BuildState.hs b/BuildBox/Build/BuildState.hs --- a/BuildBox/Build/BuildState.hs +++ b/BuildBox/Build/BuildState.hs @@ -12,12 +12,7 @@ = BuildState { -- | Log all system commands executed to this file handle. buildStateLogSystem :: Maybe Handle - - -- | Uniqueish id for this build process. - -- On POSIX we'd use the PID, but that doesn't work on Windows. - -- The id is initialised by the Haskell random number generator on startup. - , buildStateId :: Integer - + -- | Sequence number for generating fresh file names. , buildStateSeq :: Integer @@ -26,11 +21,10 @@ -- | The default build config. -buildStateDefault :: Integer -> FilePath -> BuildState -buildStateDefault uniqId scratchDir +buildStateDefault :: FilePath -> BuildState +buildStateDefault scratchDir = BuildState { buildStateLogSystem = Nothing - , buildStateId = uniqId , buildStateSeq = 0 , buildStateScratchDir = scratchDir } diff --git a/BuildBox/Build/Testable.hs b/BuildBox/Build/Testable.hs --- a/BuildBox/Build/Testable.hs +++ b/BuildBox/Build/Testable.hs @@ -11,13 +11,14 @@ where import BuildBox.Build.Base import BuildBox.Build.BuildError -import Control.Monad.Error +import Control.Monad.Catch -- | Some testable property. class Testable prop where test :: prop -> Build Bool + -- | Testable properties are checkable. -- If the check returns false then throw an error. check :: (Show prop, Testable prop) => prop -> Build () @@ -25,7 +26,7 @@ = do result <- test prop if result then return () - else throwError $ ErrorCheckFailed True prop + else throwM $ ErrorCheckFailed True prop -- | Testable properties are checkable. @@ -34,7 +35,7 @@ checkFalse prop = do result <- test prop if result - then throwError $ ErrorCheckFailed False prop + then throwM $ ErrorCheckFailed False prop else return () diff --git a/BuildBox/Command/Darcs.hs b/BuildBox/Command/Darcs.hs --- a/BuildBox/Command/Darcs.hs +++ b/BuildBox/Command/Darcs.hs @@ -83,7 +83,10 @@ in DarcsPatch { - darcsTimestamp = readTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" (unwords time) + darcsTimestamp = parseTimeOrError True + defaultTimeLocale + "%a %b %e %H:%M:%S %Z %Y" + (unwords time) , darcsAuthor = unwords author , darcsComment = Seq.drop 1 p } diff --git a/BuildBox/Command/File.hs b/BuildBox/Command/File.hs --- a/BuildBox/Command/File.hs +++ b/BuildBox/Command/File.hs @@ -12,9 +12,12 @@ where import BuildBox.Build import System.Directory -import Control.Exception +-- import Control.Exception import Control.Monad.State +import Control.Monad.Catch import System.Info +import qualified System.IO.Temp as System +import qualified System.IO as System -- | Properties of the file system we can test for. data PropFile @@ -103,55 +106,34 @@ -- | Create a temp file, pass it to some command, then delete the file after the command finishes. withTempFile :: (FilePath -> Build a) -> Build a withTempFile build - = do fileName <- newTempFile - - -- run the real command - result <- build fileName - - -- cleanup - io $ removeFile fileName - - return result - - --- | Allocate a new temporary file name -newTempFile :: Build FilePath -newTempFile = do buildDir <- gets buildStateScratchDir - buildId <- gets buildStateId buildSeq <- gets buildStateSeq - -- Increment the sequence number. - modify $ \s -> s { buildStateSeq = buildStateSeq s + 1 } - - -- Ensure the build directory exists, or canonicalizePath will fail - ensureDir buildDir - - -- Build the file name we'll try to use. - -- We need to account for a blank scratch directory, otherwise there is - -- no way to use the CD as a scratch on Windows. - let fileName = (if (null buildDir) then "" else (buildDir ++ "/")) - ++ "buildbox-" ++ show buildId ++ "-" ++ show buildSeq - -- TODO: normalise path - - -- If it already exists then something has gone badly wrong. - -- Maybe the unique Id for the process wasn't as unique as we thought. - exists <- io $ doesFileExist fileName - when exists - $ error "buildbox: panic, supposedly fresh file already exists." - - -- Touch the file for good measure. - -- If the unique id wasn't then we want to detect this. - io $ writeFile fileName "" + -- File name template. + let sTemplate = "buildbox-" ++ show buildSeq ++ ".tmp" - io $ canonicalizePath fileName + System.withTempFile + buildDir sTemplate + (\ fileName h + -> do io $ System.hClose h + build fileName) -- | Atomically write a file by first writing it to a tmp file then renaming it. -- This prevents concurrent processes from reading half-written files. atomicWriteFile :: FilePath -> String -> Build () atomicWriteFile filePath str - = do tmp <- newTempFile + = do buildDir <- gets buildStateScratchDir + buildSeq <- gets buildStateSeq + + -- File name template. + let sTemplate = "buildbox-" ++ show buildSeq ++ ".tmp" + + -- Create a new temp file. + (tmp, h) <- io $ System.openBinaryTempFile buildDir sTemplate + io $ System.hClose h + + -- Write the data to the temp file. io $ writeFile tmp str e <- io $ try $ renameFile tmp filePath diff --git a/BuildBox/Control/Gang.hs b/BuildBox/Control/Gang.hs --- a/BuildBox/Control/Gang.hs +++ b/BuildBox/Control/Gang.hs @@ -16,18 +16,25 @@ , waitForGangState) where import Control.Concurrent +import Control.Exception import Data.IORef import qualified Data.Set as Set import Data.Set (Set) + -- Gang ----------------------------------------------------------------------- -- | Abstract gang of threads. data Gang = Gang { gangThreads :: Int + + -- | Number of worker threads currently waiting. , gangThreadsAvailable :: QSemN + , gangState :: IORef GangState + , gangActionsRunning :: IORef Int + , gangThreadsRunning :: IORef (Set ThreadId) } @@ -60,20 +67,37 @@ -- | Block until all actions have finished executing, -- or the gang is killed. joinGang :: Gang -> IO () -joinGang gang - = do state <- readIORef (gangState gang) +joinGang !gang + = do + -- Wait for all the threads to become available. + waitQSemN (gangThreadsAvailable gang) + (gangThreads gang) + + -- See what state the gang is now in. + state <- readIORef (gangState gang) + if state == GangFinished || state == GangKilled + -- The gang is done. then return () + + -- Hmm. We're holding all the threads but the gang is still + -- running. Maybe the controller hasn't started the first + -- one yet. Just put them all back and try again. + -- We delay for a moment to allow the controller to run. else do threadDelay 1000 + + signalQSemN (gangThreadsAvailable gang) + (gangThreads gang) + joinGang gang -- | Block until already started actions have completed, but don't start any more. -- Gang state changes to `GangFlushing`. flushGang :: Gang -> IO () -flushGang gang - = do writeIORef (gangState gang) GangFlushing +flushGang !gang + = do atomicWriteIORef (gangState gang) GangFlushing waitForGangState gang GangFinished @@ -81,34 +105,60 @@ -- but no more will be started until a `resumeGang` command is issued. -- Gang state changes to `GangPaused`. pauseGang :: Gang -> IO () -pauseGang gang - = writeIORef (gangState gang) GangPaused +pauseGang !gang + = do -- Set the gang to paused mode. + -- This will prevent any new threads from being started. + atomicWriteIORef (gangState gang) GangPaused -- | Resume a paused gang, which allows it to continue starting new actions. --- Gang state changes to `GangRunning`. +-- If the gang was paused it now changes to `GangRunning`, +-- otherwise nothing happens. resumeGang :: Gang -> IO () -resumeGang gang - = writeIORef (gangState gang) GangRunning +resumeGang !gang + = atomicModifyIORef' (gangState gang) $ \state + -> do case state of + GangPaused -> (GangRunning, ()) + _ -> (state, ()) -- | Kill all the threads in a gang. -- Gang stage changes to `GangKilled`. killGang :: Gang -> IO () -killGang gang - = do writeIORef (gangState gang) GangKilled +killGang !gang + = do + atomicWriteIORef (gangState gang) GangKilled + tids <- readIORef (gangThreadsRunning gang) mapM_ killThread $ Set.toList tids + -- Signal that all the threads are available. + -- + -- NOTE: There is a race here where a thread might have terminated + -- cleanly and already bumped the QSemN just before were to add + -- to it, but we've killed the gang anyway so nothing more will + -- be run. + signalQSemN (gangThreadsAvailable gang) (length tids) + -- | Block until the gang is in the given state. waitForGangState :: Gang -> GangState -> IO () -waitForGangState gang waitState - = do state <- readIORef (gangState gang) +waitForGangState !gang !waitState + = do + -- Wait for all the threads to become available. + waitQSemN (gangThreadsAvailable gang) + (gangThreads gang) + + state <- readIORef (gangState gang) + if state == waitState then return () else do threadDelay 1000 + + signalQSemN (gangThreadsAvailable gang) + (gangThreads gang) + waitForGangState gang waitState @@ -117,13 +167,13 @@ -- Gang state starts as `GangRunning` then transitions to `GangFinished`. -- To block until all the actions are finished use `joinGang`. forkGangActions - :: Int -- ^ Number of worker threads in the gang \/ maximum number - -- of actions to execute concurrenty. - -> [IO ()] -- ^ Actions to run. They are started in-order, but may finish - -- out-of-order depending on the run time of the individual action. + :: Int -- ^ Number of worker threads in the gang \/ maximum number + -- of actions to execute concurrenty. + -> [IO ()] -- ^ Actions to run. They are started in-order, but may finish + -- out-of-order depending on the run time of the individual action. -> IO Gang -forkGangActions threads actions +forkGangActions !threads !actions = do semThreads <- newQSemN threads refState <- newIORef GangRunning refActionsRunning <- newIORef 0 @@ -142,70 +192,52 @@ -- | Run actions on a gang. gangLoop :: Gang -> [IO ()] -> IO () -gangLoop gang [] - = do -- Wait for all the threads to finish. - waitQSemN - (gangThreadsAvailable gang) - (gangThreads gang) - - -- Signal that the gang is finished running actions. + +gangLoop !gang [] + = do -- Signal that the gang is finished running actions. writeIORef (gangState gang) GangFinished +gangLoop !gang actions@(action:actionsRest) + = do + -- Wait for a worker thread to become available. + waitQSemN (gangThreadsAvailable gang) 1 + + -- See what state the gang is in. + state <- readIORef (gangState gang) -gangLoop gang actions@(action:actionsRest) - = do state <- readIORef (gangState gang) case state of GangRunning - -> do -- Wait for a worker thread to become available. - waitQSemN (gangThreadsAvailable gang) 1 - gangLoop_withWorker gang action actionsRest - - GangPaused - -> do threadDelay 1000 - gangLoop gang actions - - GangFlushing - -> do actionsRunning <- readIORef (gangActionsRunning gang) - if actionsRunning == 0 - then writeIORef (gangState gang) GangFinished - else do - threadDelay 1000 - gangLoop gang [] - - GangFinished -> return () - GangKilled -> return () - --- we have an available worker -gangLoop_withWorker :: Gang -> IO () -> [IO ()] -> IO () -gangLoop_withWorker gang action actionsRest - = do -- See if we're supposed to be starting actions or not. - state <- readIORef (gangState gang) - case state of - GangRunning - -> do -- fork off the first action - tid <- forkOS $ do - -- run the action (and wait for it to complete) - action + -> do -- Fork off the next action. + -- We need to use the 'finally' to release the thread + -- in the case that the action throws an exception. + tid <- forkOS + $ finally action + $ do -- Remove our ThreadId from the set of + -- running ThreadIds. + tid <- myThreadId + atomicModifyIORef' (gangThreadsRunning gang) + (\tids -> (Set.delete tid tids, ())) - -- signal that a new worker is available - signalQSemN (gangThreadsAvailable gang) 1 - - -- remove our ThreadId from the set of running ThreadIds. - tid <- myThreadId - atomicModifyIORef (gangThreadsRunning gang) - (\tids -> (Set.delete tid tids, ())) + -- Signal that the worker is now available. + signalQSemN (gangThreadsAvailable gang) 1 -- Add the ThreadId of the freshly forked thread to the set -- of running ThreadIds. We'll need this set if we want to kill -- the gang. - atomicModifyIORef (gangThreadsRunning gang) + atomicModifyIORef' (gangThreadsRunning gang) (\tids -> (Set.insert tid tids, ())) - -- handle the rest of the actions. + -- Handle the rest of the actions. gangLoop gang actionsRest - -- someone issued flush or pause command while we - -- were waiting for a worker, so don't start next action. - _ -> do - signalQSemN (gangThreadsAvailable gang) 1 - gangLoop gang (action:actionsRest) + -- TODO: avoid spinning on pause. + GangPaused + -> do signalQSemN (gangThreadsAvailable gang) 1 + threadDelay 1000 + gangLoop gang actions + + GangFlushing -> return () + GangFinished -> return () + GangKilled -> return () + + diff --git a/buildbox.cabal b/buildbox.cabal --- a/buildbox.cabal +++ b/buildbox.cabal @@ -1,5 +1,5 @@ Name: buildbox -Version: 2.1.7.1 +Version: 2.1.8.1 License: BSD3 License-file: LICENSE Author: Ben Lippmeier @@ -29,7 +29,8 @@ mtl >= 2.2 && < 2.3, old-locale >= 1.0 && < 1.1, process >= 1.2 && < 1.3, - random >= 1.0 && < 1.2, + temporary >= 1.2 && < 1.3, + exceptions >= 0.8 && < 0.9, pretty >= 1.1 && < 1.2, stm >= 2.4 && < 2.5, text >= 1.2 && < 1.3 @@ -71,3 +72,6 @@ Extensions: ExistentialQuantification + ScopedTypeVariables + TypeSynonymInstances + BangPatterns