module HSBencher.Internal.Utils
( defaultTimeout, backupResults,
runLogged, runSL, runLines,
trim, fetchBaseName, echoStream,
my_name, main_threadid,
)
where
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.Char (isSpace)
import Data.IORef
import Prelude hiding (log)
import System.Directory
import System.FilePath (dropTrailingPathSeparator, takeBaseName)
import System.IO (hGetContents)
import qualified System.IO.Streams as Strm
import qualified System.IO.Streams.Concurrent as Strm
import System.IO.Unsafe (unsafePerformIO)
import System.Process (waitForProcess, getProcessExitCode, createProcess, CreateProcess(..), CmdSpec(..), StdStream(..))
import HSBencher.Types
import HSBencher.Internal.Logging (log,logOn, LogDest(StdOut, LogFile))
import HSBencher.Internal.MeasureProcess
my_name :: String
my_name = "hsbencher"
defaultTimeout :: Double
defaultTimeout = 150
main_threadid :: IORef ThreadId
main_threadid = unsafePerformIO$ newIORef (error "main_threadid uninitialized")
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
echoStream :: Bool -> Strm.InputStream B.ByteString -> BenchM (A.Async ())
echoStream echoStdout outS = do
conf <- ask
lift$ A.async (runReaderT echoloop conf)
where
echoloop =
do x <- lift$ Strm.read outS
case x of
Nothing -> return ()
Just ln -> do
logOn (if echoStdout then [LogFile, StdOut] else [LogFile]) (B.unpack ln)
echoloop
runLogged :: String -> String -> [(String,String)]-> BenchM (RunResult, [B.ByteString])
runLogged tag cmd env = do
log$ " * Executing command: " ++ cmd
Config{ harvesters } <- ask
SubProcess {wait,process_out,process_err} <-
lift$ measureProcess Nothing harvesters
CommandDescr{ command=ShellCommand cmd, envVars=env, timeout=Nothing,
workingDir=Nothing, tolerateError=False }
err2 <- lift$ Strm.map (B.append (B.pack "[stderr] ")) process_err
both <- lift$ Strm.concurrentMerge [process_out, err2]
both' <- lift$ Strm.map (B.append$ B.pack tag) both
let loop acc = do
x <- lift$ Strm.read both'
case x of
Nothing -> return (reverse acc)
Just ln -> do log (B.unpack ln)
loop (ln:acc)
lnes <- loop []
res <- lift$ wait
log$ " * Command completed with "++show(length lnes)++" lines of output."
return (res,lnes)
runLines :: String -> IO [String]
runLines cmd = do
putStr$ " * Executing: " ++ cmd
(Nothing, Just outH, Just _, ph) <- createProcess
CreateProcess {
cmdspec = ShellCommand cmd,
env = Nothing,
std_in = Inherit,
std_out = CreatePipe,
std_err = CreatePipe,
cwd = Nothing,
close_fds = False,
create_group = False,
delegate_ctlc = False
}
_ <- waitForProcess ph
Just _code <- getProcessExitCode ph
str <- hGetContents outH
let lns = lines str
putStrLn$ " --> "++show (length lns)++" line(s)"
return (lines str)
runSL :: String -> IO String
runSL cmd = do
lns <- runLines cmd
case lns of
h:_ -> return h
[] -> return ""
_getCPULoad :: IO (Maybe Double)
_getCPULoad = do
cmd <- fmap trim $ runSL "which mpstat"
fmap loop $ runLines cmd
where
loop [] = Nothing
loop [_] = Nothing
loop (ln:nxt:tl)
| "%idle" `elem` words ln = parseLine ln nxt
| otherwise = loop (nxt:tl)
parseLine ln nxt =
let w1 = words ln
w2 = words nxt
in if length w1 /= length w2
then Nothing
else case lookup "%idle" (zip w1 w2) of
Nothing -> Nothing
Just num ->
case reads num of
(n,_):_ -> Just (100 n)
_ -> Nothing
fetchBaseName :: FilePath -> FilePath
fetchBaseName path =
takeBaseName $ dropTrailingPathSeparator path
backupResults :: String -> String -> IO ()
backupResults resultsFile logFile = do
e <- doesFileExist resultsFile
date <- runSL "date +%Y%m%d_%s"
when e $ do
renameFile resultsFile (resultsFile ++"."++date++".bak")
e2 <- doesFileExist logFile
when e2 $ do
renameFile logFile (logFile ++"."++date++".bak")