buildbox 1.0.0.1 → 1.0.1.0

raw patch · 5 files changed

+169/−63 lines, 5 filesdep +bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• BuildBox/Build/Base.hs +12/−6
• BuildBox/Command/System.hs +54/−44
• BuildBox/Command/System/Internals.hs +20/−11
• BuildBox/Data/Log.hs +79/−0
• buildbox.cabal +4/−2

@@ -8,7 +8,10 @@ import System.IO import System.IO.Error import System.Exit+import BuildBox.Data.Log		(Log)+import qualified BuildBox.Data.Log	as Log + -- | 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 (ReaderT BuildConfig IO) a@@ -23,8 +26,8 @@ 	| ErrorSystemCmdFailed 		{ buildErrorCmd 	:: String 		, buildErrorCode	:: ExitCode-		, buildErrorStdout	:: String-		, buildErrorStderr	:: String }+		, buildErrorStdout	:: Log+		, buildErrorStderr	:: Log } 		 	-- | Some other IO action failed. 	| ErrorIOError IOError@@ -47,14 +50,14 @@ 		, text "    command: " <> (text $ buildErrorCmd err) 		, text "  exit code: " <> (text $ show $ buildErrorCode err) 		, blank-		, if (not $ null $ buildErrorStdout err)+		, if (not $ Log.null $ buildErrorStdout err) 		   then vcat 	[ text "-- stdout (last 10 lines) ------------------------------------------------------"-				, vcat $ map text $ reverse $ take 10 $ reverse $ lines $ buildErrorStdout err]+				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStdout err] 		   else text "" 		, blank-		, if (not $ null $ buildErrorStderr err)+		, if (not $ Log.null $ buildErrorStderr err) 		   then vcat	[ text "-- stderr (last 10 lines) ------------------------------------------------------"-				, vcat $ map text $ reverse $ take 10 $ reverse $ lines $ buildErrorStderr err]+				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStderr err] 		   else text "" 		 		, 		  text "--------------------------------------------------------------------------------" ]@@ -64,6 +67,9 @@  	ErrorCheckFailed expected prop 	 -> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)++instance Show BuildError where+ show err = render $ ppr err   -- BuildConfig ------------------------------------------------------------------------------------

@@ -18,18 +18,23 @@ 	, ssystemOut 	, qssystemOut 	, systemTee+	, systemTeeLog 	, ssystemTee+	, systemTeeIO  	-- * The real function-	, systemTeeIO)+	, systemTeeLogIO) where import BuildBox.Command.System.Internals import BuildBox.Build import Control.Concurrent-import System.Process	hiding (system) import System.Exit import System.IO import Control.Monad+import Data.ByteString.Char8		(ByteString)+import BuildBox.Data.Log		(Log)+import System.Process			hiding (system)+import qualified BuildBox.Data.Log	as Log  debug :: Bool debug	= False@@ -42,7 +47,7 @@ -- | Run a system command, returning its exit code. system :: String -> Build ExitCode system cmd- = do	(code, _, _)		<- systemTee True cmd ""+ = do	(code, _, _)		<- systemTeeLog True cmd Log.empty 	return code  @@ -50,16 +55,16 @@ --   If the exit code is `ExitFailure` then throw an error in the `Build` monad. ssystem :: String -> Build () ssystem cmd- = do	(code, strOut, strErr)	<- systemTee True cmd ""+ = do	(code, logOut, logErr)	<- systemTeeLog True cmd Log.empty  	when (code /= ExitSuccess)-	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+	 $ throw $ ErrorSystemCmdFailed cmd code logOut logErr   -- | Quietly run a system command, returning its exit code. qsystem :: String -> Build ExitCode qsystem cmd- = do	(code, _, _)		<- systemTee False cmd ""+ = do	(code, _, _)		<- systemTeeLog False cmd Log.empty 	return code  @@ -67,10 +72,10 @@ --   If the exit code is `ExitFailure` then throw an error in the `Build` monad. qssystem :: String -> Build () qssystem cmd- = do	(code, strOut, strErr)	<- systemTee False cmd ""+ = do	(code, logOut, logErr)	<- systemTeeLog False cmd Log.empty  	when (code /= ExitSuccess)-	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+	 $ throw $ ErrorSystemCmdFailed cmd code logOut logErr 	  -- | Run a successful system command, returning what it wrote to its @stdout@.@@ -79,11 +84,11 @@ --   then throw an error in the `Build` monad. ssystemOut :: String -> Build String ssystemOut cmd- = do	(code, strOut, strErr)	<- systemTee True cmd ""-	when (code /= ExitSuccess || (not $ null strErr))-	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+ = do	(code, logOut, logErr)	<- systemTeeLog True cmd Log.empty+	when (code /= ExitSuccess || (not $ Log.null logErr))+	 $ throw $ ErrorSystemCmdFailed cmd code logOut logErr -	return strOut+	return $ Log.toString logOut  -- | Quietly run a successful system command, returning what it wrote to its @stdout@. --   If anything was written to @stderr@ then treat that as failure. @@ -91,46 +96,53 @@ --   then throw an error in the `Build` monad. qssystemOut :: String -> Build String qssystemOut cmd- = do	(code, strOut, strErr)	<- systemTee False cmd ""-	when (code /= ExitSuccess || (not $ null strErr))-	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+ = do	(code, logOut, logErr)	<- systemTeeLog False cmd Log.empty+	when (code /= ExitSuccess || (not $ Log.null logErr))+	 $ throw $ ErrorSystemCmdFailed cmd code logOut logErr -	return strOut+	return $ Log.toString logOut    -- Tee versions -----------------------------------------------------------------------------------  -- | Like `systemTeeIO`, but in the `Build` monad.-systemTee -	:: Bool 	-	-> String	-	-> String	-	-> Build (ExitCode, String, String)-+systemTee :: Bool -> String -> String -> Build (ExitCode, String, String) systemTee tee cmd strIn  = do	logSystem cmd 	io $ systemTeeIO tee cmd strIn +-- | Like `systemTeeLogIO`, but in the `Build` monad.+systemTeeLog :: Bool -> String -> Log -> Build (ExitCode, Log, Log)+systemTeeLog tee cmd logIn+ = do	logSystem cmd+	io $ systemTeeLogIO tee cmd logIn + -- | Like `systemTeeIO`, but in the `Build` monad and throw an error if it returns `ExitFailure`. ssystemTee  :: Bool -> String -> String -> Build () ssystemTee tee cmd strIn  = do	logSystem cmd-	(code, strOut, strErr)	<- systemTee tee cmd strIn+	(code, logOut, logErr)	<- systemTeeLog tee cmd (Log.fromString strIn) 	when (code /= ExitSuccess)-	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+	 $ throw $ ErrorSystemCmdFailed cmd code logOut logErr -	 +-- | Like `systemTeeLogIO`, but with strings.+systemTeeIO :: Bool -> String -> String -> IO (ExitCode, String, String)+systemTeeIO tee cmd strIn+ = do	(code, logOut, logErr)	<- systemTeeLogIO tee cmd $ Log.fromString strIn+	return	(code, Log.toString logOut, Log.toString logErr)++ -- | Run a system command, returning its `ExitCode` and what was written to @stdout@ and @stderr@.-systemTeeIO +systemTeeLogIO 	:: Bool 	-- ^ Whether @stdout@ and @stderr@ should be forwarded to the parent process. 	-> String 	-- ^ Command to run.-	-> String	-- ^ What to pass to the command's @stdin@.-	-> IO (ExitCode, String, String)+	-> Log		-- ^ What to pass to the command's @stdin@.+	-> IO (ExitCode, Log, Log) -systemTeeIO tee cmd strIn+systemTeeLogIO tee cmd logIn  = do	trace $ "systemTeeIO " ++ show tee ++ ": " ++ cmd  	-- Create some new pipes for the process to write its stdout and stderr to.@@ -147,7 +159,7 @@ 			, close_fds	= False }  	-- Push input into in handle-	hPutStr hInWrite strIn+	hPutStr hInWrite $ Log.toString logIn 			 	-- To implement the tee-like behavior we'll fork some threads that read lines from the 	-- processes stdout and stderr and write them to these channels. @@ -186,22 +198,20 @@ 	-- Get what was written to its stdout and stderr. 	--	getChanContents is a lazy read, so don't pull from the channel after 	--	seeing a Nothing else we'll block forever.-	strOut		<- liftM (concat . slurpUntilNothing) $ getChanContents chanOutAcc-	strErr		<- liftM (concat . slurpUntilNothing) $ getChanContents chanErrAcc+	logOut		<- slurpChan chanOutAcc Log.empty+	logErr		<- slurpChan chanErrAcc Log.empty -	trace $ "systemTeeIO stdout: " ++ strOut-	trace $ "systemTeeIO stderr: " ++ strErr+	trace $ "systemTeeIO stdout: " ++ Log.toString logOut+	trace $ "systemTeeIO stderr: " ++ Log.toString logErr  	trace $ "systemTeeIO: All done"-	code `seq` strOut `seq` strErr `seq` -		return	(code, strOut, strErr)--+	code `seq` logOut `seq` logErr `seq` +		return	(code, logOut, logErr) -slurpUntilNothing :: [Maybe a] -> [a]-slurpUntilNothing xx- = case xx of-	[]		-> []-	Nothing : _	-> []-	Just x  : xs	-> x : slurpUntilNothing xs+slurpChan :: Chan (Maybe ByteString) -> Log -> IO Log+slurpChan !chan !ll+ = do	mStr	<- readChan chan+	case mStr of+	 Nothing	-> return ll+	 Just str	-> slurpChan chan (ll Log.|> str) 

@@ -1,15 +1,18 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, BangPatterns #-} module BuildBox.Command.System.Internals 	( streamIn 	, streamOuts) where import System.IO-import Control.Concurrent	+import Control.Concurrent+import Data.ByteString.Char8		(ByteString)+import qualified Data.ByteString.Char8	as BS	 + -- | Continually read lines from a handle and write them to this channel. --   When the handle hits EOF then write `Nothing` to the channel.-streamIn  :: Handle -> Chan (Maybe String) -> IO ()-streamIn hRead chan+streamIn  :: Handle -> Chan (Maybe ByteString) -> IO ()+streamIn !hRead !chan  = do	eof	<- hIsEOF hRead 	if eof 	 then do@@ -17,18 +20,23 @@ 		return () 		 	 else do-		str	<- hGetLine hRead-		writeChan chan (Just (str ++ "\n"))+		str	<- BS.hGetLine hRead+		writeChan chan (Just str) 		streamIn hRead chan   -- | Continually read lines from some channels and write them to handles. --   When all the channels return `Nothing` then we're done. --   When we're done, signal this fact on the semaphore.-streamOuts :: [(Chan (Maybe String), (Maybe Handle), QSem)] -> IO ()-streamOuts chans +streamOuts :: [(Chan (Maybe ByteString), (Maybe Handle), QSem)] -> IO ()+streamOuts !chans   = streamOuts' False [] chans +	-- There doesn't seem to be a way to perform a unix-style "select" on channels.+	-- We want to wait until any of the channels becomes available for reading.+	-- We're doing this just by polling them each in turn, and waiting a bit+	--	if none of them had any data.+		  where	-- we're done. 	streamOuts' _ []   []	 		= return ()@@ -38,11 +46,11 @@ 	 = 	streamOuts' False [] prev  	streamOuts' False prev []-	 = do	yield+	 = do	threadDelay 100000 		streamOuts' False [] prev  	-- try to read from the current chan.-	streamOuts' active prev (x@(chan, mHandle, qsem) : rest)+	streamOuts' !active !prev (!x@(!chan, !mHandle, !qsem) : rest) 	 = isEmptyChan chan >>= \empty ->  	   if empty  	    then streamOuts' active (prev ++ [x]) rest@@ -55,7 +63,8 @@  		 Just str  		  | Just h	<- mHandle-		  -> do	hPutStr h str+		  -> do	BS.hPutStr h str+			hPutChar   h '\n' 			streamOuts' True (prev ++ [x]) rest  		  | otherwise

@@ -0,0 +1,79 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | When the output of a command is long, keeping it as a `String` is a bad idea.+module BuildBox.Data.Log+	( Log+	, Line+	, empty+	, null+	, toString+	, fromString+	, (<|)+	, (|>)+	, (><)+	, firstLines+	, lastLines)+where+import Data.ByteString.Char8		(ByteString)+import Data.Sequence			(Seq)+import qualified Data.ByteString.Char8 	as BS+import qualified Data.Sequence		as Seq+import qualified Data.Foldable		as F+import Prelude				hiding (null)++-- | A sequence of lines, without newline charaters on the end.+type Log 	= Seq Line+type Line	= ByteString++instance Show Log where+ show	= toString+	++-- | O(1) No logs here.+empty :: Log+empty = Seq.empty++-- | O(1) Check if the log is empty.+null :: Log -> Bool+null  = Seq.null++-- | O(n) Convert a `Log` to a `String`.+toString :: Log -> String+toString ll	+	= BS.unpack +	$ BS.intercalate (BS.pack "\n") +	$ F.toList (ll Seq.>< Seq.singleton BS.empty) +		-- hack to get the last "\n" on the end.+++-- | O(n) Convert a `String` to a `Log`.+fromString :: String -> Log+fromString str	+	= Seq.fromList +	$ BS.splitWith (== '\n')+	$ BS.pack str+++-- | O(1) Add a `Line` to the start of a `Log`.+(<|):: Line -> Log -> Log+(<|)	= (Seq.<|)++-- | O(1) Add a `Line` to the end of a `Log`.+(|>)	:: Log -> Line -> Log+(|>)	= (Seq.|>)++-- | O(log(min(n1,n2))) Concatenate two `Log`s.+(><)	:: Log -> Log -> Log+(><)	= (Seq.><)+++-- | O(n) Take the first m lines from a log+firstLines :: Int -> Log -> Log+firstLines m ll+	= Seq.take m ll++-- | O(n) Take the last m lines from a log+lastLines :: Int -> Log -> Log+lastLines m ll+	= Seq.drop (Seq.length ll - m) ll+	

@@ -1,5 +1,5 @@ Name:                buildbox-Version:             1.0.0.1+Version:             1.0.1.0 License:             BSD3 License-file:        LICENSE Author:              Ben Lippmeier@@ -32,12 +32,14 @@         unix                 == 2.4.*,         pretty               == 1.0.*,         old-locale           == 1.0.*,-        containers           == 0.3.*+        containers           == 0.3.*,+        bytestring           == 0.9.*    ghc-options:         -Wall    Exposed-modules:+        BuildBox.Data.Log         BuildBox.Benchmark.Base         BuildBox.Benchmark.Compare         BuildBox.Benchmark.Pretty