hsbencher-fusion 0.3 → 0.3.2
raw patch · 4 files changed
+301/−25 lines, 4 filesdep +criteriondep +csvdep +hsbencher-fusiondep ~hsbenchernew-component:exe:hsbencher-fusion-upload-criterionnew-component:exe:hsbencher-fusion-upload-csv
Dependencies added: criterion, csv, hsbencher-fusion, statistics, text
Dependency ranges changed: hsbencher
Files
- CSVUploader/Main.hs +108/−0
- CriterionUploader/Main.hs +152/−0
- HSBencher/Backend/Fusion.hs +18/−23
- hsbencher-fusion.cabal +23/−2
+ CSVUploader/Main.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NamedFieldPuns #-}+-- |+-- Seeded from code by:+-- Copyright : [2014] Trevor L. McDonell++module Main where++-- Friends:+import HSBencher+import HSBencher.Internal.Config (augmentResultWithConfig, getConfig)+import HSBencher.Backend.Fusion++-- Standard:+import Control.Monad.Reader+import Data.List as L+import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)+import System.Environment (getArgs)+import System.Exit+import qualified Data.Map as Map++import Text.CSV++this_progname = "hsbencher-fusion-upload-csv"++----------------------------------------------------------------------------------------------------++data ExtraFlag = TableName String+ | PrintHelp+ deriving (Eq,Ord,Show,Read)++extra_cli_options :: [OptDescr ExtraFlag]+extra_cli_options = [ Option ['h'] ["help"] (NoArg PrintHelp)+ "Show this help message and exit."+ , Option [] ["name"] (ReqArg TableName "NAME")+ "Name for the fusion table to which we upload (discovered or created)." ]+plug :: FusionPlug+plug = defaultFusionPlugin++main :: IO ()+main = do+ cli_args <- getArgs+ let (help,fusion_cli_options) = plugCmdOpts plug++ let (opts1,plainargs,unrec,errs1) = getOpt' Permute extra_cli_options cli_args+ let (opts2,_,errs2) = getOpt Permute fusion_cli_options unrec+ let errs = errs1 ++ errs2 + when (L.elem PrintHelp opts1 || not (null errs)) $ do + putStrLn $+ "USAGE: "++this_progname++" [options] CSVFILE\n\n"+++ "Upload a pre-existing CSV data as gathered by the 'dribble' plugin.\n"+++ "\n"+++ (usageInfo "Options:" extra_cli_options)++"\n"+++ (usageInfo help fusion_cli_options)+ if null errs then exitSuccess else exitFailure++ let name = case [ n | TableName n <- opts1 ] of+ [] -> error "Must supply a table name!"+ [n] -> n+ ls -> error $ "Multiple table names supplied!: "++show ls++ -- This bit could be abstracted nicely by the HSBencher lib:+ ------------------------------------------------------------+ -- Gather info about the benchmark platform:+ gconf0 <- getConfig [] []+ let gconf1 = gconf0 { benchsetName = Just name }+ gconf2 <- plugInitialize plug gconf1+ let fconf0 = getMyConf plug gconf2+ let fconf1 = foldFlags plug opts2 fconf0+ let gconf3 = setMyConf plug fconf1 gconf2+ + ------------------------------------------------------------+ case plainargs of+ [] -> error "No file given to upload!"+ reports -> forM_ reports (doupload gconf3)++doupload :: Config -> FilePath -> IO ()+doupload confs file = do+ x <- parseCSVFromFile file+ case x of+ Left err -> error $ "Failed to read CSV file: \n"++show err+ Right [] -> error $ "Bad CSV file, not even a header line: "++file+ Right (hdr:rst) -> do+ checkHeader hdr+ let len = length rst+ putStrLn$ " ["++this_progname++"] Beginning upload of "++show len++" rows of CSV data..." + mapM_ (uprow len confs) (zip [1..] (map (zip hdr) rst))++checkHeader :: Record -> IO ()+checkHeader hdr+ | L.elem "PROGNAME" hdr = return ()+ | otherwise = error $ "Bad HEADER line on CSV file: "++show hdr++-- TODO: Add checking to see if the rows are already there. However+-- that would be expensive if we do one query per row. The ideal+-- implementation would examine the structure of the rowset and make+-- fewer queries.+uprow :: Int -> Config -> (Int,[(String,String)]) -> IO ()+uprow total gconf (ix,tuple) = do+ putStrLn $ "\n\n ["++this_progname++"] Begin upload of row "++show ix++" of "++show total+ putStrLn "================================================================================"+ let br = tupleToResult tuple+ runReaderT (uploadBenchResult br) gconf
+ CriterionUploader/Main.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NamedFieldPuns #-}+-- |+-- Seeded from code by:+-- Copyright : [2014] Trevor L. McDonell++module Main where++-- Friends:+import HSBencher+import HSBencher.Internal.Config (augmentResultWithConfig, getConfig)+import HSBencher.Backend.Fusion++import Criterion.Types ( Report(..), SampleAnalysis(..), Regression(..) )+import Criterion.IO ( readReports )+import Statistics.Resampling.Bootstrap ( Estimate(..) )++-- Standard:+import Control.Monad.Reader+import Data.List as L+import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)+import System.Environment (getArgs)+import System.Exit+import qualified Data.Map as Map++----------------------------------------------------------------------------------------------------++data ExtraFlag = TableName String+ | PrintHelp+ deriving (Eq,Ord,Show,Read)++extra_cli_options :: [OptDescr ExtraFlag]+extra_cli_options = [ Option ['h'] ["help"] (NoArg PrintHelp)+ "Show this help message and exit."+ , Option [] ["name"] (ReqArg TableName "NAME")+ "Name for the fusion table to which we upload (discovered or created)." ]+plug :: FusionPlug+plug = defaultFusionPlugin++main :: IO ()+main = do+ cli_args <- getArgs+ let (help,fusion_cli_options) = plugCmdOpts plug++ let (opts1,plainargs,unrec,errs1) = getOpt' Permute extra_cli_options cli_args+ let (opts2,_,errs2) = getOpt Permute fusion_cli_options unrec+ let errs = errs1 ++ errs2 + when (L.elem PrintHelp opts1 || not (null errs)) $ do + putStrLn $+ "USAGE: fusion-upload-criterion [options] REPORTFILE\n\n"+++ "Upload a pre-existing Criterion report benchmarked on the CURRENT machine.\n"+++ "This restriction is due to the Report not containing system information. Rather,\n"+++ "'fusion-upload-criterion' gathers information about the platform at the time of upload.\n"+++ "\n"+++ (usageInfo "Options:" extra_cli_options)++"\n"+++ (usageInfo help fusion_cli_options)+ if null errs then exitSuccess else exitFailure++ let name = case [ n | TableName n <- opts1 ] of+ [] -> error "Must supply a table name!"+ [n] -> n+ ls -> error $ "Multiple table names supplied!: "++show ls++ -- This bit could be abstracted nicely by the HSBencher lib:+ ------------------------------------------------------------+ -- Gather info about the benchmark platform:+ gconf0 <- getConfig [] []+ let gconf1 = gconf0 { benchsetName = Just name }+ gconf2 <- plugInitialize plug gconf1+ let fconf0 = getMyConf plug gconf2+ let fconf1 = foldFlags plug opts2 fconf0+ let gconf3 = setMyConf plug fconf1 gconf2+ + ------------------------------------------------------------+ case plainargs of+ [] -> error "No file given to upload!"+ reports -> forM_ reports (doupload gconf3)++doupload :: Config -> FilePath -> IO ()+doupload confs file = do+ x <- readReports file+ case x of+ Left err -> error $ "Failed to read report file: \n"++err+ Right reports -> forM_ reports (upreport confs)++upreport :: Config -> Report -> IO ()+upreport gconf report = do+ let br = emptyBenchmarkResult+ printReport report -- TEMP + br' <- augmentResultWithConfig gconf (addReport report br)+ runReaderT (uploadBenchResult br') gconf++printReport :: Report -> IO ()+printReport Report{..} = do + putStrLn ("Found report with keys: "++show reportKeys)+ let SampleAnalysis{..} = reportAnalysis+ forM_ anRegress $ \Regression{..} -> do+ putStrLn$ " Regression: "++ show (regResponder, Map.keys regCoeffs)++addReport :: Report -> BenchmarkResult -> BenchmarkResult+addReport rep@Report{..} BenchmarkResult{..} =+ BenchmarkResult+ { _PROGNAME = reportName+ , _VARIANT = if null _VARIANT+ then "criterion" -- This is just helpful for filtering down the fusion table.+ else _VARIANT+ , _MEDIANTIME = medtime+ , _MINTIME = estLowerBound $ fetch "time" "iters"+ , _MAXTIME = estUpperBound $ fetch "time" "iters"++ , _MEDIANTIME_PRODUCTIVITY =+ do ms <- Map.lookup ("mutatorWallSeconds","iters") ests+ gs <- Map.lookup ("gcWallSeconds","iters") ests + return (estPoint ms / (estPoint ms + estPoint gs))+ + , _MEDIANTIME_ALLOCRATE =+ do e <- Map.lookup ("allocated","iters") ests+ -- Use time to extrapolate the alloc rate / second:+ return (round(estPoint e * (1.0 / medtime)))++ , _CUSTOM =+ (maybe [] (\ e -> [("BYTES_ALLOC",DoubleResult (estPoint e))])+ (Map.lookup ("allocated","iters") ests)) ++++ (maybe [] (\ e -> [("BYTES_COPIED",DoubleResult (estPoint e))])+ (Map.lookup ("bytesCopied","iters") ests)) ++ ++ (maybe [] (\ e -> [("NUMGC",DoubleResult (estPoint e))])+ (Map.lookup ("numGcs","iters") ests)) ++ ++ (maybe [] (\ e -> [("CPUTIME",DoubleResult (estPoint e))])+ (Map.lookup ("cpuTime","iters") ests)) ++ + + (maybe [] (\ e -> [("CYCLES",DoubleResult (estPoint e))])+ (Map.lookup ("cycles","iters") ests))+ , ..+ }+ where+ medtime = estPoint $ fetch "time" "iters"+ + SampleAnalysis{..} = reportAnalysis+ ests = Map.fromList $+ [ ((regResponder,p), e) | Regression{..} <- anRegress+ , (p,e) <- Map.toList regCoeffs ]+ fetch r p = case Map.lookup (r,p) ests of+ Nothing -> error $ "Expected regression with responder/predictor:"++r++"/"++p+ Just x -> x
HSBencher/Backend/Fusion.hs view
@@ -22,7 +22,7 @@ import Control.Monad.Reader import Control.Concurrent (threadDelay) import qualified Control.Exception as E-import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)+import Data.Maybe (fromJust, fromMaybe) import Data.Dynamic import Data.Default (Default(..)) import qualified Data.Set as S@@ -30,28 +30,17 @@ import qualified Data.List as L import qualified Data.ByteString.Char8 as B import Data.Time.Clock-import Data.Time.Calendar import Data.Time.Format ()--- import Network.Google (retryIORequest) import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) import Network.Google.FusionTables (createTable, createColumn, listTables, listColumns,- bulkImportRows, insertRows,+ bulkImportRows, TableId, CellType(..), TableMetadata(..), ColumnMetadata(..)) import Network.HTTP.Conduit (HttpException) import HSBencher.Types import HSBencher.Internal.Logging (log) import HSBencher.Internal.Fusion import Prelude hiding (log)-import System.IO (hPutStrLn, stderr)-import System.IO.Unsafe (unsafePerformIO)-import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)-import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory,- createDirectory, renameFile, removeFile)-import System.FilePath ((</>),(<.>), splitExtension)-import System.IO.Unsafe (unsafePerformIO)-import System.Environment (getEnvironment)-import System.Exit-import Control.Concurrent.MVar+import System.Console.GetOpt (OptDescr(Option), ArgDescr(..)) -- | A default plugin. This binding provides future-proof way to get -- a default instance of the plugin, in the eventuality that more@@ -125,6 +114,7 @@ threadDelay (round$ delay * 1000 * 1000) -- Microseconds loop (num+1) tl +fromJustErr :: String -> Maybe t -> t fromJustErr msg Nothing = error msg fromJustErr _ (Just x) = x @@ -171,7 +161,8 @@ unless (S.null missing) $ do log$ "WARNING: These fields are missing server-side, creating them: "++show misslist forM_ misslist $ \ colname -> do- ColumnMetadata{col_name, col_columnId} <- liftIO$ createColumn atok tid (colname, STRING)+ Just ColumnMetadata{col_name, col_columnId} <- stdRetry "createColumn" auth toks $+ createColumn atok tid (colname, STRING) log$ " -> Created column with name,id: "++show (col_name, col_columnId) unless (S.null extra) $ do log$ "WARNING: The fusion table has extra fields that HSBencher does not know about: "++@@ -184,6 +175,11 @@ +-- | Upload the raw data, which had better be in the right format.+-- uploadRawTuple :: [(String,String)] -> BenchM ()+-- uploadRawTuple tuple = do+ + -- | Push the results from a single benchmark to the server. uploadBenchResult :: BenchmarkResult -> BenchM () uploadBenchResult br@BenchmarkResult{..} = do@@ -214,7 +210,8 @@ log$ " [fusiontable] There were " ++ show (length misslist) ++ " columns missing" unless (S.null missing) $ do forM_ misslist $ \ colname -> do- liftIO$ createColumn atok tid (colname, STRING)+ stdRetry "createColumn" authclient toks $+ createColumn atok tid (colname, STRING) -- Create with the correct type !? Above just states STRING. --- ////// END@@ -296,6 +293,7 @@ -- length as fusionSchema. +benchmarkResultToSchema :: BenchmarkResult -> [(String, CellType)] benchmarkResultToSchema bm = fusionSchema ++ map custom (_CUSTOM bm) where custom (tag, IntResult _) = (tag,NUMBER)@@ -318,7 +316,7 @@ plugCmdOpts _ = fusion_cli_options - plugUploadRow p cfg row = runReaderT (uploadBenchResult row) cfg+ plugUploadRow _ cfg row = runReaderT (uploadBenchResult row) cfg plugInitialize p gconf = do putStrLn " [fusiontable] Fusion table plugin initializing.. First, find config."@@ -326,7 +324,7 @@ getMyConf p gconf in case (benchsetName gconf, fusionTableID) of (Nothing,Nothing) -> error "No way to find which fusion table to use! No name given and no explicit table ID."- (_, Just tid) -> return gconf+ (_, Just _tid) -> return gconf (Just name,_) -> do case (fusionClientID, fusionClientSecret) of (Just cid, Just sec ) -> do@@ -339,7 +337,7 @@ let (Just cid, Just sec) = (fusionClientID fc2, fusionClientSecret fc2) authclient = OAuth2Client { clientId = cid, clientSecret = sec } putStrLn " [fusiontable] Second, lets retrieved cached auth tokens on the file system..."- toks <- getCachedTokens authclient+ _toks <- getCachedTokens authclient -- TEMP: This should become another command line flag: --fusion-list to list the tables. {-@@ -349,7 +347,7 @@ -} return gc2 - foldFlags p flgs cnf0 = + foldFlags _p flgs cnf0 = foldr ($) cnf0 (map doFlag flgs) where -- TODO: Move this one to the global config@@ -362,9 +360,6 @@ Just tid -> r { fusionTableID = Just tid } Nothing -> r --theEnv :: [(String,String)] -theEnv = unsafePerformIO getEnvironment -- | All the command line options understood by this plugin. fusion_cli_options :: (String, [OptDescr FusionCmdLnFlag])
hsbencher-fusion.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hsbencher-fusion-version: 0.3+version: 0.3.2 synopsis: Backend for uploading benchmark data to Google Fusion Tables. description: Google Fusion tables are a type of Google Doc that resembles a@@ -41,10 +41,31 @@ -- mtl >=2.1 && <2.2, mtl, handa-gdata >= 0.6.9.3 && <0.7, - hsbencher >=1.11 && <2.0+ hsbencher >=1.15 && <2.0 -- hs-source-dirs: default-language: Haskell2010 -- FIXME: cpp-options: -DFUSION_TABLES +Executable hsbencher-fusion-upload-criterion+ main-is: Main.hs+ hs-source-dirs: ./CriterionUploader+ + build-depends: base >=4.5 && < 4.8,+ text >= 1.1, bytestring >= 0.10, containers >= 0.5,+ criterion >= 1.0, statistics,+ mtl+ build-depends: hsbencher-fusion, hsbencher >=1.15 && <2.0+ default-language: Haskell2010+++Executable hsbencher-fusion-upload-csv+ main-is: Main.hs+ hs-source-dirs: ./CSVUploader+ + build-depends: base >=4.5 && < 4.8,+ text >= 1.1, bytestring >= 0.10, containers >= 0.5,+ mtl, csv >= 0.1+ build-depends: hsbencher-fusion, hsbencher >=1.15 && <2.0+ default-language: Haskell2010