diff --git a/CSVUploader/Main.hs b/CSVUploader/Main.hs new file mode 100644 --- /dev/null +++ b/CSVUploader/Main.hs @@ -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 diff --git a/CriterionUploader/Main.hs b/CriterionUploader/Main.hs new file mode 100644 --- /dev/null +++ b/CriterionUploader/Main.hs @@ -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 diff --git a/HSBencher/Backend/Fusion.hs b/HSBencher/Backend/Fusion.hs --- a/HSBencher/Backend/Fusion.hs +++ b/HSBencher/Backend/Fusion.hs @@ -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]) diff --git a/hsbencher-fusion.cabal b/hsbencher-fusion.cabal --- a/hsbencher-fusion.cabal +++ b/hsbencher-fusion.cabal @@ -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