buildbox 2.1.7.1 → 2.1.8.1

raw patch · 9 files changed

+168/−169 lines, 9 filesdep +exceptionsdep +temporarydep −randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions, temporary

Dependencies removed: random

API changes (from Hackage documentation)

Files

• BuildBox/Build.hs +9/−3
• BuildBox/Build/Base.hs +12/−37
• BuildBox/Build/BuildError.hs +5/−3
• BuildBox/Build/BuildState.hs +3/−9
• BuildBox/Build/Testable.hs +4/−3
• BuildBox/Command/Darcs.hs +4/−1
• BuildBox/Command/File.hs +22/−40
• BuildBox/Control/Gang.hs +103/−71
• buildbox.cabal +6/−2

@@ -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 ()  

@@ -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  

@@ -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

@@ -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 } 

@@ -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 ()          

@@ -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         }

@@ -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 

@@ -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 ()++

@@ -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