hsbencher-fusion 0.3.4 → 0.3.15.1
raw patch · 5 files changed
+545/−186 lines, 5 filesdep +splitdep ~basedep ~handa-gdataPVP ok
version bump matches the API change (PVP)
Dependencies added: split
Dependency ranges changed: base, handa-gdata
API changes (from Hackage documentation)
+ HSBencher.Backend.Fusion: authenticate :: BenchM (OAuth2Tokens, OAuth2Client, TableId)
+ HSBencher.Backend.Fusion: ensureColumns :: OAuth2Client -> TableId -> [(String, CellType)] -> BenchM [String]
+ HSBencher.Backend.Fusion: findTableId :: OAuth2Client -> String -> BenchM (Maybe TableId)
+ HSBencher.Backend.Fusion: makeTable :: OAuth2Client -> String -> BenchM TableId
+ HSBencher.Backend.Fusion: prepBenchResult :: Schema -> BenchmarkResult -> PreppedTuple
+ HSBencher.Backend.Fusion: type PreppedTuple = [(String, String)]
+ HSBencher.Backend.Fusion: type Schema = [String]
+ HSBencher.Backend.Fusion: uploadRows :: [PreppedTuple] -> BenchM Bool
Files
- CSVUploader/Main.hs +178/−57
- CriterionUploader/Main.hs +136/−20
- HSBencher/Backend/Fusion.hs +188/−72
- HSBencher/Internal/Fusion.hs +10/−16
- hsbencher-fusion.cabal +33/−21
CSVUploader/Main.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NamedFieldPuns #-} -- |@@ -15,32 +13,51 @@ import HSBencher import HSBencher.Internal.Config (augmentResultWithConfig, getConfig) import HSBencher.Backend.Fusion+import Network.Google.OAuth2 (OAuth2Client(..))+import Network.Google.FusionTables(CellType(..)) -- Standard:+import Control.Monad import Control.Monad.Reader import Data.List as L+import Data.Maybe (fromJust) import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) import System.Environment (getArgs) import System.Exit-import System.IO.Unsafe (unsafePerformIO) import qualified Data.Map as M import qualified Data.Set as S +import Data.Version (showVersion)+import Paths_hsbencher_fusion (version)+ import Text.CSV +this_progname :: String this_progname = "hsbencher-fusion-upload-csv" ---------------------------------------------------------------------------------------------------- data ExtraFlag = TableName String | PrintHelp+ | NoUpload+ | MatchServerOrder+ | OutFile FilePath 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)." ]+ "Name for the fusion table to which we upload (discovered or created)."++ , Option ['o'] ["out"] (ReqArg OutFile "FILE")+ "Write the augmented CSV data out to FILE."+ + , Option [] ["noupload"] (NoArg NoUpload)+ "Don't actually upload to the fusion table (but still possible write to disk)."+ , Option [] ["matchserver"] (NoArg MatchServerOrder)+ "Even if not uploading, retrieve the order of columns from the server and use it." + ] plug :: FusionPlug plug = defaultFusionPlugin @@ -54,8 +71,9 @@ let errs = errs1 ++ errs2 when (L.elem PrintHelp opts1 || not (null errs)) $ do putStrLn $+ this_progname++": "++showVersion version++"\n"++ "USAGE: "++this_progname++" [options] CSVFILE\n\n"++- "Upload a pre-existing CSV data as gathered by the 'dribble' plugin.\n"+++ "Upload pre-existing CSV, e.g. data as gathered by the 'dribble' plugin.\n"++ "\n"++ (usageInfo "Options:" extra_cli_options)++"\n"++ (usageInfo help fusion_cli_options)@@ -71,73 +89,176 @@ -- Gather info about the benchmark platform: gconf0 <- getConfig [] [] let gconf1 = gconf0 { benchsetName = Just name }- gconf2 <- plugInitialize plug gconf1- let fconf0 = getMyConf plug gconf2+ let fconf0 = getMyConf plug gconf1 let fconf1 = foldFlags plug opts2 fconf0- let gconf3 = setMyConf plug fconf1 gconf2- + let gconf2 = setMyConf plug fconf1 gconf1 + gconf3 <- if L.elem NoUpload opts1 &&+ not (L.elem MatchServerOrder opts1)+ then return gconf2+ else plugInitialize plug gconf2 ++ let outFiles = [ f | OutFile f <- opts1 ]+ ------------------------------------------------------------ case plainargs of [] -> error "No file given to upload!"- reports -> forM_ reports (doupload gconf3)+ reports -> do+ allFiles <- fmap (L.map (L.filter goodLine)) $+ mapM loadCSV reports+ let headers = map head allFiles+ distinctHeaders = S.fromList headers+ combined = head headers : (L.concatMap tail allFiles)+ unless (S.size distinctHeaders == 1) $+ error $ unlines ("Not all the headers in CSV files matched: " : + (L.map show (S.toList distinctHeaders))) -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))+ putStrLn$ " ["++this_progname++"] File lengths: "++show (map length allFiles)+-- putStrLn$ " ["++this_progname++"] File headers:\n"++unlines (map show headers)+-- putStrLn$ "DEBUG:\n "++unlines (map show combined) -checkHeader :: Record -> IO ()-checkHeader hdr- | L.elem "PROGNAME" hdr = return ()- | otherwise = error $ "Bad HEADER line on CSV file: "++show hdr+ unless (null outFiles) $ do+ putStrLn$ " ["++this_progname++"] First, write out CSVs to disk: "++show outFiles+ putStrLn$ " ["++this_progname++"] Match server side schema?: "++ show(L.elem MatchServerOrder opts1)+ let hdr = head combined+ serverSchema <-+ if L.elem MatchServerOrder opts1+ then do s <- ensureMyColumns gconf3 hdr+ putStrLn$ " ["++this_progname++"] Retrieved schema from server, using for CSV output:\n "++show s+ return s+ else return hdr+ forM_ outFiles $ \f ->+ writeOutFile gconf3 serverSchema f combined+ if L.elem NoUpload opts1+ then putStrLn$ " ["++this_progname++"] Skipping fusion table upload due to --noupload "+ else doupload gconf3 combined+ + -- case (reports, outFiles) of+ -- (_,[]) -> forM_ reports $ \f -> loadCSV f >>= doupload gconf3 + -- ([inp],[out]) ->+ -- do c <- loadCSV inp+ -- writeOutFile gconf3 out c+ -- doupload gconf3 c+ -- ([inp],ls) -> error $ "Given multiple CSV output files: "++show ls+ -- (ls1,ls2) -> error $ "Given multiple input files but also asked to output to a CSV file." --- | Get config data about the benchmark platform, but only if needed-{--{-# NOINLINE gconf #-}-gconf :: Config-gconf = unsafePerformIO $ do- putStrLn $ "\n\n ["++this_progname++"] WARNING: tuple incomplete, gathering environmental data from current platform..."- getConfig [] []--}+writeOutFile :: Config -> [String] -> FilePath -> CSV -> IO ()+writeOutFile _ _ _ [] = error $ "Bad CSV file, not even a header line."+writeOutFile confs serverSchema path (hdr:rst) = do+ augmented <- augmentRows confs serverSchema hdr rst + putStrLn$ " ["++this_progname++"] Writing out CSV with schema:\n "++show serverSchema+ let untuple :: [[(String,String)]] -> [[String]]+-- untuple tups = map fst (head tups) : map (map snd) tups + -- Convert while using the ordering from serverSchema:+ untuple tups = serverSchema : + [ [ fJ (lookup k tup)+ | k <- serverSchema+ , let fJ (Just x) = x+ fJ Nothing = "" -- Custom fields!+ -- error$ "field "++k++" in server schema missing in tuple:\n"++unlines (map show tup)+ ]+ | tup <- tups ] + writeFile path $ printCSV $ + untuple $ map resultToTuple augmented+ putStrLn$ " ["++this_progname++"] Successfully wrote file: "++path++goodLine :: [String] -> Bool+goodLine [] = False+goodLine [""] = False -- Why does Text.CSV produce these?+goodLine _ = True++loadCSV :: FilePath -> IO CSV+loadCSV f = do+ x <- parseCSVFromFile f + case x of + Left err -> error $ "Failed to read CSV file: \n"++show err+ Right [] -> error $ "Bad CSV file, not even a header line: "++ f+ Right v -> return v ++doupload :: Config -> CSV -> IO ()+doupload confs x = do+ case x of+ [] -> error $ "Bad CSV file, not even a header line."+ (hdr:rst) -> do+ checkHeader hdr+ putStrLn$ " ["++this_progname++"] Beginning upload CSV data with Schema: "++show hdr+ serverSchema <- ensureMyColumns confs hdr -- FIXUP server schema.+ putStrLn$ " ["++this_progname++"] Uploading "++show (length rst)++" rows of CSV data..."+ putStrLn "================================================================================"+-- uprows confs serverSchema hdr rst fusionUploader+ augmented <- augmentRows confs serverSchema hdr rst+ prepped <- prepRows serverSchema augmented+ fusionUploader prepped confs+ -- 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 tup0 = resultToTuple emptyBenchmarkResult- schema0 = S.fromList (map fst tup0)- schema1 = S.fromList (map fst tuple)- br1 = tupleToResult tuple- missing = S.difference schema0 schema1- - -- Case 1: EVERYTHING is present in the uploaded tuple.- br <- if S.null missing then- return (tupleToResult tuple)- else do- putStrLn $ "\n\n ["++this_progname++"] Fields missing: "++show (S.toList missing)- -- Otherwise something is missing.- -- Start with the empty tuple, augmented with environmental info:- br1 <- augmentResultWithConfig gconf emptyBenchmarkResult- -- Layer on what we have.- return $ - tupleToResult (M.toList (M.union (M.fromList tuple)- (M.fromList (resultToTuple br1))))- - runReaderT (uploadBenchResult br) gconf+-- | Perform the actual upload of N rows+-- uprows :: Config -> [String] -> [String] -> [[String]] -> Uploader -> IO ()+augmentRows :: Config -> [String] -> [String] -> [[String]] -> IO [BenchmarkResult]+augmentRows confs serverSchema hdr rst = do+ let missing = S.difference (S.fromList serverSchema) (S.fromList hdr) + -- Compute a base benchResult to fill in our missing fields:+ base <- if S.null missing then+ return emptyBenchmarkResult -- Don't bother computing it, nothing missing.+ else do+ putStrLn $ "\n\n ["++this_progname++"] Fields missing, filling in defaults: "++show (S.toList missing)+ -- Start with the empty tuple, augmented with environmental info:+ x <- augmentResultWithConfig confs emptyBenchmarkResult+ return $ x { _WHO = "" } -- Don't use who output from the point in time where we run THIS command. + let tuples = map (zip hdr) rst+ augmented = map (`unionBR` base) tuples+ return augmented +prepRows :: Schema -> [BenchmarkResult] -> IO [PreppedTuple]+prepRows serverSchema augmented = do+ let prepped = map (prepBenchResult serverSchema) augmented+ putStrLn$ " ["++this_progname++"] Tuples prepped. Here's the first one: "++ show (head prepped)+ -- Layer on what we have.+ return prepped +fusionUploader :: [PreppedTuple] -> Config -> IO ()+fusionUploader prepped confs = do + flg <- runReaderT (uploadRows prepped) confs+ unless flg $ error $ this_progname++"/uprows: failed to upload rows." +-- | Union a tuple with a BenchmarkResult. Any unmentioned keys in+-- the tuple retain their value from the input BenchmarkResult.+unionBR :: [(String,String)] -> BenchmarkResult -> BenchmarkResult+unionBR tuple br1 =+ tupleToResult (M.toList (M.union (M.fromList tuple)+ (M.fromList (resultToTuple br1))))+++-- FIXUP: FusionConfig doesn't document our additional CUSTOM columns.+-- During initialization it ensures the table has the core schema, but that's it.+-- Thus we need to make sure ALL columns are present.+ensureMyColumns :: Config -> [String] -> IO Schema+ensureMyColumns confs hdr = do+ let FusionConfig{fusionTableID,fusionClientID,fusionClientSecret,serverColumns} = getMyConf plug confs+ (Just tid, Just cid, Just sec) = (fusionTableID, fusionClientID, fusionClientSecret)+ auth = OAuth2Client { clientId=cid, clientSecret=sec }+ missing = S.difference (S.fromList hdr) (S.fromList serverColumns)+ -- HACK: we pretend everything in a STRING here... we should probably look at the data in the CSV+ -- and guess if its a number. However, if columns already exist we DONT change their type, so it+ -- can always be done manually on the server.+ schema = [ case lookup nm fusionSchema of+ Nothing -> (nm,STRING)+ Just t -> (nm,t)+ | nm <- serverColumns ++ S.toList missing ]+ if S.null missing+ then putStrLn$ " ["++this_progname++"] Server has all the columns appearing in the CSV file. Good."+ else putStrLn$ " ["++this_progname++"] Adding missing columns: "++show missing+ res <- runReaderT (ensureColumns auth tid schema) confs+ putStrLn$ " ["++this_progname++"] Done adding, final server schema:"++show res+ return res+++checkHeader :: Record -> IO ()+checkHeader hdr+ | L.elem "PROGNAME" hdr = return ()+ | otherwise = error $ "Bad HEADER line on CSV file. Expecting at least PROGNAME to be present: "++show hdr
CriterionUploader/Main.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE NamedFieldPuns #-} -- | -- Seeded from code by: -- Copyright : [2014] Trevor L. McDonell@@ -15,6 +16,7 @@ import HSBencher import HSBencher.Internal.Config (augmentResultWithConfig, getConfig) import HSBencher.Backend.Fusion+import HSBencher.Backend.Dribble (defaultDribblePlugin, DribbleConf (..)) import Criterion.Types ( Report(..), SampleAnalysis(..), Regression(..) ) import Criterion.IO ( readReports )@@ -23,14 +25,31 @@ -- Standard: import Control.Monad.Reader import Data.List as L+import Data.List.Split (splitOn)+import Data.Char (isSpace) import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)-import System.Environment (getArgs)+import System.Environment (getArgs, getProgName) import System.Exit import qualified Data.Map as Map +import Data.Version (showVersion)+import Paths_hsbencher_fusion (version)+ ---------------------------------------------------------------------------------------------------- data ExtraFlag = TableName String+ | SetVariant String+ | SetArgs String+ | SetThreads Int+ | SetRunTimeFlags String+ -- TODO: this should include MOST of the schema's+ -- fields... we need a scalable way to do this.+ -- Applicative options would help...+-- | SetHostname String + | SetCustom String String++ | WriteCSV FilePath+ | NoUpload | PrintHelp deriving (Eq,Ord,Show,Read) @@ -38,7 +57,54 @@ 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)." ]+ "Name for the fusion table to which we upload (discovered or created)."+ , Option [] ["variant"] (ReqArg SetVariant "STR")+ "Setting for the VARIANT field for *ALL* uploaded data from the given report."+ , Option [] ["args"] (ReqArg SetArgs "STR")+ "Set the ARGS column in the uploaded data."+ , Option [] ["threads"] (ReqArg (SetThreads . safeRead) "NUM")+ "Set the THREADS column in the uploaded data."+ , Option [] ["custom"] (ReqArg (uncurry SetCustom . parsePair) "STR")+ "Given STR=COL,VAL, set custom column COL to value VAL."+ + , Option [] ["runflags"] (ReqArg SetRunTimeFlags "STR")+ "Set the RUNTIME_FLAGS column in the uploaded data."+ + , Option [] ["csv"] (ReqArg WriteCSV "PATH")+ "Write the Criterion report data into a CSV file using the HSBencher schema."+ , Option [] ["noupload"] (NoArg NoUpload)+ "Don't actually upload to the fusion table (but still possible write CSV)."+ ]++safeRead :: String -> Int+safeRead x = case reads (trim x) of+ (n,[]):_ -> n+ _ -> error $ "error: could not parse as Int: "++x++-- | Parse the comma-separated "COL,VAL" string.+parsePair :: String -> (String,String)+parsePair s =+ case splitOn universalSeparator s of+ ("":_) -> error $ "bad value for --custom: "++show s+ (l:rest) -> (l, concat (intersperse "," rest))+ _ -> error $ "--custom argument expected at least two strings separated by commas, not: "++s++-- | Yech, this is hacky silliness.+mkResult :: String -> SomeResult+mkResult s =+ case reads (trim s) of+ (d,[]):_ -> DoubleResult d+ _ -> StringResult s+ +-- | For now this application is hardcoded to use a particular+-- separator in both rename files and command line arguments.+universalSeparator :: String+universalSeparator = ","++trim :: String -> String+trim = f . f+ where f = reverse . dropWhile isSpace+ plug :: FusionPlug plug = defaultFusionPlugin @@ -49,10 +115,13 @@ 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 + let errs = errs1 ++ errs2+ progName <- getProgName when (L.elem PrintHelp opts1 || not (null errs)) $ do putStrLn $- "USAGE: fusion-upload-criterion [options] REPORTFILE\n\n"+++ "USAGE: "++progName++" [options] REPORTFILE\n"+++ "Version: "++ showVersion version++"\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"++@@ -61,38 +130,85 @@ (usageInfo help fusion_cli_options) if null errs then exitSuccess else exitFailure + let noup = L.elem NoUpload opts1+ let csvPath = (\(WriteCSV path) -> path) `fmap`+ L.find (\case WriteCSV _ -> True+ _ -> False) opts1+ let name = case [ n | TableName n <- opts1 ] of [] -> error "Must supply a table name!" [n] -> n ls -> error $ "Multiple table names supplied!: "++show ls + let presets1 = emptyBenchmarkResult+ let presets2 = case [ n | SetVariant n <- opts1 ] of+ [] -> presets1+ [n] -> presets1 { _VARIANT = n }+ ls -> error $ "Multiple VARIANTs supplied!: "++show ls+ let presets3 = case [ n | SetArgs n <- opts1 ] of+ [] -> presets2+ [n] -> presets2 { _ARGS = words n }+ ls -> error $ "Multiple ARGS settings supplied!: "++show ls+ let presets4 = case [ s | SetRunTimeFlags s <- opts1 ] of+ [] -> presets3+ [s] -> presets3 { _RUNTIME_FLAGS = s }+ ls -> error $ "Multiple RUNTIME_FLAGS settings supplied!: "++show ls + let presets5 = case [ n | SetThreads n <- opts1 ] of+ [] -> presets4+ [n] -> presets4 { _THREADS = n }+ ls -> error $ "Multiple THREADS settings supplied!: "++show ls+ let customs = [ (a,mkResult b) | SetCustom a b <- opts1 ]+ presets6 = presets5+ {+ _CUSTOM = _CUSTOM presets5 ++ customs + }++ unless (null customs) $ putStrLn $ "Adding custom fields: "++show customs+ -- 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 fconf0 = getMyConf plug gconf1 let fconf1 = foldFlags plug opts2 fconf0- let gconf3 = setMyConf plug fconf1 gconf2- + let gconf2 = setMyConf plug fconf1 gconf1 + gconf3 <- if noup then return gconf2 else plugInitialize plug gconf2+ ------------------------------------------------------------ case plainargs of [] -> error "No file given to upload!"- reports -> forM_ reports (doupload gconf3)+ reports -> do+ maybe (return ()) (doCSV gconf3 presets6 reports) csvPath+ unless noup $ forM_ reports (doupload gconf3 presets6) -doupload :: Config -> FilePath -> IO ()-doupload confs file = do+doupload :: Config -> BenchmarkResult -> FilePath -> IO ()+doupload confs presets file = do x <- readReports file case x of Left err -> error $ "Failed to read report file: \n"++err- Right reports -> forM_ reports (upreport confs)+ Right reports -> forM_ reports (upreport confs presets) -upreport :: Config -> Report -> IO ()-upreport gconf report = do- let br = emptyBenchmarkResult- printReport report -- TEMP - br' <- augmentResultWithConfig gconf (addReport report br)+doCSV :: Config -> BenchmarkResult -> [FilePath] -> FilePath -> IO ()+doCSV confs presets reportFiles csvFile = do+ brs <- concat `fmap` forM reportFiles (\reportFile -> do+ critReport <- readReports reportFile+ case critReport of+ Left err -> error $ "Failed to read report file " ++ reportFile ++ ": \n" ++ err+ Right reports -> mapM (augmentResultWithConfig confs . flip addReport presets) reports)+ -- TODO: need to change file names here+ forM_ brs $ \benchRet -> do+ -- we restart dribble plugin to set a new path for each report+ let updateDribbleConf =+ Map.insert "dribble" (SomePluginConf defaultDribblePlugin $ DribbleConf (Just csvFile))+ dribbleConf <- plugInitialize defaultDribblePlugin+ confs{plugInConfs=updateDribbleConf (plugInConfs confs)}+ void $ plugUploadRow defaultDribblePlugin dribbleConf benchRet++upreport :: Config -> BenchmarkResult -> Report -> IO ()+upreport gconf presets report = do+ printReport report -- TEMP+ br' <- augmentResultWithConfig gconf (addReport report presets) runReaderT (uploadBenchResult br') gconf printReport :: Report -> IO ()@@ -103,7 +219,7 @@ putStrLn$ " Regression: "++ show (regResponder, Map.keys regCoeffs) addReport :: Report -> BenchmarkResult -> BenchmarkResult-addReport rep@Report{..} BenchmarkResult{..} =+addReport Report{..} BenchmarkResult{..} = BenchmarkResult { _PROGNAME = reportName , _VARIANT = if null _VARIANT@@ -123,7 +239,7 @@ -- Use time to extrapolate the alloc rate / second: return (round(estPoint e * (1.0 / medtime))) - , _CUSTOM =+ , _CUSTOM = _CUSTOM ++ (maybe [] (\ e -> [("BYTES_ALLOC",DoubleResult (estPoint e))]) (Map.lookup ("allocated","iters") ests)) ++
HSBencher/Backend/Fusion.hs view
@@ -11,10 +11,18 @@ ( -- * The plugin itself, what you probably want defaultFusionPlugin + -- * Creating and finding tables+ , getTableId, findTableId, makeTable, ensureColumns+ -- * Details and configuration options.- , FusionConfig(..), stdRetry, getTableId+ , FusionConfig(..), stdRetry , fusionSchema, resultToTuple++ -- * Prepping and uploading tuples (rows)+ , PreppedTuple, Schema+ , authenticate, prepBenchResult, uploadRows , uploadBenchResult+ , FusionPlug(), FusionCmdLnFlag(..), ) where@@ -119,14 +127,32 @@ fromJustErr _ (Just x) = x +-- TODO: Should probably move these routines into some kind of+-- "Authenticated" monad which would provide a Reader for the auth+-- info.+ -- | Get the table ID that has been cached on disk, or find the the table in the users -- Google Drive, or create a new table if needed. ----- In the case of a preexisting table, this function also performs sanity checking--- comparing the expected schema (including column ordering) to the sserver side one.--- It returns the permutation of columns found server side.+-- This is a simple shorthand for combining findTableId/makeTable/ensureColumns. +--+-- It adds columns if necessary and returns the permutation of columns+-- found server side. It assumes the DEFAULT core table Schema and+-- will not work for creating CUSTOM columns on the server side.+-- Simple drop down to using the three finer grained routines if you want that. getTableId :: OAuth2Client -> String -> BenchM (TableId, [String]) getTableId auth tablename = do+ x <- findTableId auth tablename+ tid <- case x of+ Nothing -> makeTable auth tablename+ Just iD -> return iD+ -- FIXME: this really should not mutate columns... should be deprecated.+ order <- ensureColumns auth tid fusionSchema+ return (tid, order)++-- | Look for a table by name, returning its ID if it is present.+findTableId :: OAuth2Client -> String -> BenchM (Maybe TableId)+findTableId auth tablename = do log$ " [fusiontable] Fetching access tokens, client ID/secret: "++show (clientId auth, clientSecret auth) toks <- liftIO$ getCachedTokens auth log$ " [fusiontable] Retrieved: "++show toks@@ -134,71 +160,136 @@ allTables <- fmap (fromJustErr "[fusiontable] getTableId, API call to listTables failed.") $ stdRetry "listTables" auth toks $ listTables atok log$ " [fusiontable] Retrieved metadata on "++show (length allTables)++" tables"--- let ourSchema = map fst fusionSchema- ourSet = S.fromList ourSchema case filter (\ t -> tab_name t == tablename) allTables of- [] -> do log$ " [fusiontable] No table with name "++show tablename ++" found, creating..."- Just TableMetadata{tab_tableId} <- stdRetry "createTable" auth toks $- createTable atok tablename fusionSchema- log$ " [fusiontable] Table created with ID "++show tab_tableId- - -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns.- return (tab_tableId, ourSchema)+ [] -> do log$ " [fusiontable] No table with name "++show tablename + return Nothing [t] -> do let tid = (tab_tableId t) log$ " [fusiontable] Found one table with name "++show tablename ++", ID: "++show tid- log$ " [fusiontable] Checking columns... " - targetSchema <- fmap (map col_name) $ liftIO$ listColumns atok tid- let targetSet = S.fromList targetSchema- missing = S.difference ourSet targetSet- misslist = L.filter (`S.member` missing) ourSchema -- Keep the order.- extra = S.difference targetSet ourSet- unless (targetSchema == ourSchema) $ - log$ "WARNING: HSBencher upload schema (1) did not match server side schema (2):\n (1) "++- show ourSchema ++"\n (2) " ++ show targetSchema- ++ "\n HSBencher will try to make do..."- unless (S.null missing) $ do - log$ "WARNING: These fields are missing server-side, creating them: "++show misslist- forM_ misslist $ \ colname -> do- 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: "++- show (S.toList extra)- log$ " Expect null-string entries in these fields! "- -- For now we ASSUME that new columns are added to the end:- -- TODO: We could do another read from the list of columns to confirm.- return (tid, targetSchema ++ misslist)- ls -> error$ " More than one table with the name '"++show tablename++"' !\n "++show ls+ return (Just tid) +-- | Make a new table, returning its ID.+-- In the future this may provide failure recovery. But for now it+-- simply produces an exception if anything goes wrong.+-- And in particular there is no way to deal with multiple clients+-- racing to perform a `makeTable` with the same name.+makeTable :: OAuth2Client -> String -> BenchM TableId+makeTable auth tablename = do+ toks <- liftIO$ getCachedTokens auth+ let atok = B.pack $ accessToken toks + log$ " [fusiontable] No table with name "++show tablename ++" found, creating..."+ Just TableMetadata{tab_tableId} <- stdRetry "createTable" auth toks $+ createTable atok tablename fusionSchema+ log$ " [fusiontable] Table created with ID "++show tab_tableId+ -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns.+ return tab_tableId +-- | Make sure that a minimal set of columns are present. This+-- routine creates columns that are missing and returns the+-- permutation of columns found on the server. +ensureColumns :: OAuth2Client -> TableId -> [(String, CellType)] -> BenchM [String]+ensureColumns auth tid ourSchema = do+ log$ " [fusiontable] ensureColumns: Ensuring schema: "++show ourSchema+ toks <- liftIO$ getCachedTokens auth+ log$ " [fusiontable] ensureColumns: Retrieved: "++show toks+ let ourColNames = map fst ourSchema+ let atok = B.pack $ accessToken toks+ let ourSet = S.fromList ourColNames+ log$ " [fusiontable] ensureColumns: Checking columns... " + targetColNames <- fmap (map col_name) $ liftIO$ listColumns atok tid+ let targetSet = S.fromList targetColNames+ missing = S.difference ourSet targetSet+ misslist = L.filter (`S.member` missing) ourColNames -- Keep the order.+ extra = S.difference targetSet ourSet+ unless (targetColNames == ourColNames) $ + log$ "WARNING: HSBencher upload schema (1) did not match server side schema (2):\n (1) "+++ show ourSchema ++"\n (2) " ++ show targetColNames+ ++ "\n HSBencher will try to make do..."+ unless (S.null missing) $ do + log$ "WARNING: These fields are missing server-side, creating them: "++show misslist+ forM_ misslist $ \ colname -> do+ 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: "+++ show (S.toList extra)+ log$ " Expect null-string entries in these fields! "+ -- For now we ASSUME that new columns are added to the end:+ -- TODO: We could do another read from the list of columns to confirm.+ return (targetColNames ++ misslist) --- | Upload the raw data, which had better be in the right format.--- uploadRawTuple :: [(String,String)] -> BenchM ()--- uploadRawTuple tuple = do -+{-# DEPRECATED uploadBenchResult "this is subsumed by the Plugin interface and uploadRows" #-} -- | Push the results from a single benchmark to the server. uploadBenchResult :: BenchmarkResult -> BenchM ()-uploadBenchResult br@BenchmarkResult{..} = do- conf <- ask- let fusionConfig = getMyConf FusionPlug conf--- fusionConfig <- error "FINISHME - acquire config dynamically"- let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID, serverColumns} = fusionConfig- let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)- authclient = OAuth2Client { clientId = cid, clientSecret = sec }+uploadBenchResult br = do+ (_toks,auth,tid) <- authenticate+ let schema = benchmarkResultToSchema br+ order <- ensureColumns auth tid schema+ let row = prepBenchResult order br + flg <- uploadRows [row]+ unless flg $ error "uploadBenchResult: failed to upload rows" - +-- | Upload raw tuples that are already in the format expected on the server.+-- Returns True if the upload succeeded.+uploadRows :: [PreppedTuple] -> BenchM Bool+uploadRows rows = do+ (toks,auth,tid) <- authenticate+ --------------------- + let colss = map (map fst) rows+ dats = map (map snd) rows + case colss of+ [] -> return True+ (schema:rst) -> do+ unless (all (== schema) rst) $+ error ("uploadRows: not all Schemas matched: "++ show (schema, filter (/= schema) rst))+ -- It's easy to blow the URL size; we need the bulk import version.+ -- stdRetry "insertRows" authclient toks $ insertRows+ res <- stdRetry "bulkImportRows" auth toks $ bulkImportRows+ (B.pack$ accessToken toks) tid schema dats+ case res of + Just _ -> do log$ " [fusiontable] Done uploading, run ID "++ (fromJust$ lookup "RUNID" (head rows))+ ++ " date "++ (fromJust$ lookup "DATETIME" (head rows))+ return True+ Nothing -> do log$ " [fusiontable] WARNING: Upload failed the maximum number of times. Continuing with benchmarks anyway"+ return False++-- | Check cached tokens, authenticate with server if necessary, and+-- return a bundle of the commonly needed information to speak to the+-- Fusion Table API.+authenticate :: BenchM (OAuth2Tokens, OAuth2Client, TableId)+authenticate = do+ conf <- ask+ let fusionConfig = getMyConf FusionPlug conf+ -- fusionConfig <- error "FINISHME - acquire config dynamically"+ let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID, serverColumns} = fusionConfig+ let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)+ auth = OAuth2Client { clientId = cid, clientSecret = sec } + toks <- liftIO$ getCachedTokens auth+ let atok = B.pack $ accessToken toks+ let tid = fromJust fusionTableID + return (toks,auth,tid)++-- | Tuples in the format expected on the server.+type PreppedTuple = [(String,String)]++-- | The ordered set of column names that form a schema.+type Schema = [String] -- TODO: include types.++{-+-- | Ensure that a Schema is available on the server, creating columns+-- if necessary. +ensureSchema :: Schema -> BenchM ()+ensureSchema ourSchema = do+ let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)+ authclient = OAuth2Client { clientId = cid, clientSecret = sec } -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload: toks <- liftIO$ getCachedTokens authclient let atok = B.pack $ accessToken toks let tid = fromJust fusionTableID - + -- ////// Enable working with Custom tags-- let ourSchema = map fst $ benchmarkResultToSchema br+ let -- ourSchema = map fst $ benchmarkResultToSchema br ourSet = S.fromList ourSchema if null _CUSTOM then log$ " [fusiontable] Computed schema, no custom fields."@@ -212,31 +303,52 @@ forM_ misslist $ \ colname -> do stdRetry "createColumn" authclient toks $ createColumn atok tid (colname, STRING)- -- Create with the correct type !? Above just states STRING. - + -- Create with the correct type !? Above just states STRING. --- ////// END+-} - - let ourData = M.fromList $ resultToTuple br+ +-- | Prepare a Benchmark result for upload, matching the given Schema+-- in order and contents, which may mean adding empty fields.+-- This function requires that the Schema already contain all columns+-- in the benchmark result.+prepBenchResult :: Schema -> BenchmarkResult -> PreppedTuple+prepBenchResult serverColumns br@BenchmarkResult{..} = +{- + conf <- ask+ let fusionConfig = getMyConf FusionPlug conf+-- fusionConfig <- error "FINISHME - acquire config dynamically"+ let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID, serverColumns} = fusionConfig+ let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)+ authclient = OAuth2Client { clientId = cid, clientSecret = sec }++ + -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload:+ toks <- liftIO$ getCachedTokens authclient+ let atok = B.pack $ accessToken toks+ let tid = fromJust fusionTableID ++-}+ let + ourData = M.fromList $ resultToTuple br+ ourCols = M.keysSet ourData+ targetSet = S.fromList serverColumns+ missing = S.difference ourCols targetSet -- Any field HSBencher doesn't know about just gets an empty string: tuple = [ (key, fromMaybe "" (M.lookup key ourData))- | key <- serverColumns ++ misslist ]- (cols,vals) = unzip tuple+ | key <- serverColumns ]+ in if S.null missing + then tuple+ else error $ "prepBenchResult: benchmark result contained columns absent on server: "++show missing+{- log$ " [fusiontable] Uploading row with "++show (length cols)++ " columns containing "++show (sum$ map length vals)++" characters of data" log$ " [fusiontable] Full row contents: "++show ourData- -- It's easy to blow the URL size; we need the bulk import version.- -- stdRetry "insertRows" authclient toks $ insertRows- res <- stdRetry "bulkImportRows" authclient toks $ bulkImportRows- (B.pack$ accessToken toks) (fromJust fusionTableID) cols [vals]- case res of - Just _ -> log$ " [fusiontable] Done uploading, run ID "++ (fromJust$ lookup "RUNID" tuple)- ++ " date "++ (fromJust$ lookup "DATETIME" tuple)- Nothing -> log$ " [fusiontable] WARNING: Upload failed the maximum number of times. Continuing with benchmarks anyway"--- TODO/FIXME: Make this configurable.- return () + return tuple+-} + -- | A representaton used for creating tables. Must be isomorphic to -- `BenchmarkResult`. This could perhaps be generated automatically -- (e.g. from a Generic instance, or even by creating a default@@ -367,8 +479,12 @@ ("Fusion Table Options:", [ Option [] ["fusion-upload"] (OptArg FusionTables "TABLEID") "enable fusion table upload. Optionally set TABLEID; otherwise create/discover it."- , Option [] ["clientid"] (ReqArg ClientID "ID") "Use (and cache) Google client ID"- , Option [] ["clientsecret"] (ReqArg ClientSecret "STR") "Use (and cache) Google client secret"+ , Option [] ["clientid"] (ReqArg ClientID "ID") + ("Use (and cache auth tokens for) Google client ID\n"+++ "Alternatively set by env var HSBENCHER_GOOGLE_CLIENTID")+ , Option [] ["clientsecret"] (ReqArg ClientSecret "STR")+ ("Use Google client secret\n"+++ "Alternatively set by env var HSBENCHER_GOOGLE_CLIENTSECRET") , Option [] ["fusion-test"] (NoArg FusionTest) "Test authentication and list tables if possible." ])
HSBencher/Internal/Fusion.hs view
@@ -22,9 +22,6 @@ where --- HSBencher -import HSBencher.Types- -- Google API import Network.Google.OAuth2 import Network.Google.FusionTables hiding (createTable)@@ -39,16 +36,10 @@ import qualified Control.Exception as E -- Date and Time-import Data.Time.Clock-import Data.Time.Calendar import Data.Time.Format () -- Data Structures-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.List as L import qualified Data.ByteString.Char8 as B-import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe) import Data.Dynamic import Data.Default (Default(def)) @@ -59,7 +50,6 @@ import Prelude hiding (init) -- TEMPORARY-import Network.HTTP.Conduit (Request(..), RequestBody(..),parseUrl) import System.Environment (getEnvironment) import System.IO.Unsafe (unsafePerformIO) @@ -77,12 +67,14 @@ --------------------------------------------------------------------------- --+fusionTag :: String -> String fusionTag str = "[HSBencher.Internal.Fusion] " ++ str --------------------------------------------------------------------------- -- Initialization and Authorization +initialize :: String -> String -> String -> IO (TableId, [String]) initialize cid sec table_name = do hPutStrLn stderr $ fusionTag "Initializing" let auth = OAuth2Client { clientId=cid, clientSecret=sec }@@ -93,6 +85,7 @@ -- //// experimenting Needs to be updated! +init :: String -> String -> String -> IO (TableId, OAuth2Client) init cid sec table_name = do hPutStrLn stderr $ fusionTag "Initializing" let auth = OAuth2Client { clientId=cid, clientSecret=sec }@@ -102,13 +95,14 @@ return (table_id, auth) ---getSomething :: OAuth2Client -> TableId -> String -> Request m+getSomething :: OAuth2Client -> String -> String -> Maybe String -> IO ColData getSomething auth table_id col_name cond = do tokens <- getCachedTokens auth let atok = B.pack $ accessToken tokens tableSelect atok table_id col_name cond +getWithSQLQuery :: OAuth2Client -> String -> String -> IO ColData getWithSQLQuery auth table_id query = do tokens <- getCachedTokens auth let atok = B.pack $ accessToken tokens@@ -155,8 +149,8 @@ -- | Create a FusionTable with a column schema-createTable :: OAuth2Client -> String -> [(String,CellType)] -> IO TableId-createTable auth table_name schema = do+_createTable :: OAuth2Client -> String -> [(String,CellType)] -> IO TableId+_createTable auth table_name schema = do tokens <- getCachedTokens auth let atok = B.pack $ accessToken tokens result <- stdRetry "createTable" auth tokens $@@ -172,10 +166,10 @@ stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a -> IO (Maybe a)-stdRetry msg client toks action = do- let retryHook num exn = do+stdRetry _msg client toks action = do+ let retryHook _num _exn = do -- datetime <- getDateTime- stdRetry "refresh tokens" client toks (refreshTokens client toks)+ _ <- stdRetry "refresh tokens" client toks (refreshTokens client toks) return () retryIORequest action retryHook $
hsbencher-fusion.cabal view
@@ -1,70 +1,82 @@--- Initial hsbencher-fusion.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: hsbencher-fusion-version: 0.3.4+version: 0.3.15.1 synopsis: Backend for uploading benchmark data to Google Fusion Tables. description: Google Fusion tables are a type of Google Doc that resembles a- SQL database more than a spreadsheet. They have a web + SQL database more than a spreadsheet. They have a web interface and permissions model similar to toher google docs. More information can be found at: <https://support.google.com/fusiontables/answer/2571232?hl=en>- . + . ChangeLog: . * (0.3) Added RETRIES field to the core schema. * (0.3.3) Jump to new versions of handa-gdata, network, and http-conduit+ * (0.3.5) Add findTableId/makeTable/ensureColumns+ * (0.3.6) --variant command line argument for criterion uploader+ * (0.3.7) Routines for bulk-upload of rows.+ * (0.3.8) Add --threads to hsbencher-fusion-upload-criterion+ * (0.3.9) Change type of uploadRows+ * (0.3.10) Add -o to hsbencher-fusion-upload-csv+ * (0.3.11) Add --matchserver to hsbencher-fusion-upload-csv+ * (0.3.12) Add --runflags to hsbencher-fusion-upload-criterion+ * (0.3.13) Fix problem with blank lines.+ * (0.3.14) Bugfix #80+ * (0.3.15) add --custom to hsbencher-fusion-upload-criterion+ * (0.3.15.1) ghc 7.10.1 support +-- Full ChangeLog (detailing anything omitted above):+-- :+-- : + license: BSD3 license-file: LICENSE author: Ryan Newton maintainer: rrnewton@gmail.com--- copyright: --- category: build-type: Simple--- extra-source-files: cabal-version: >=1.10 library- exposed-modules: HSBencher.Backend.Fusion, + exposed-modules: HSBencher.Backend.Fusion, HSBencher.Internal.Fusion- -- other-modules: other-extensions: NamedFieldPuns, RecordWildCards, ScopedTypeVariables, CPP, BangPatterns, TupleSections, DeriveDataTypeable, TypeFamilies- build-depends: base >=4.5 && < 4.8, + build-depends: base >=4.5 && < 4.9, containers >=0.5, bytestring >=0.10, time >=1.4, directory >=1.2, filepath >=1.3, http-conduit >=2.0, network >= 2.5.0.0, data-default >= 0.5.3, mtl,- handa-gdata >= 0.7.0.1,+ handa-gdata >= 0.7.0.3, hsbencher >=1.20.0.2 && <2.0- -- hs-source-dirs: default-language: Haskell2010-+ ghc-options: -Wall -- 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,++ build-depends: base >=4.5, text >= 1.1, bytestring >= 0.10, containers >= 0.5, criterion >= 1.0, statistics,- mtl+ mtl,+ split >= 0.2 build-depends: hsbencher-fusion, hsbencher >=1.20.0.2 && <2.0+ ghc-options: -Wall default-language: Haskell2010 Executable hsbencher-fusion-upload-csv main-is: Main.hs hs-source-dirs: ./CSVUploader- - build-depends: base >=4.5 && < 4.8,++ build-depends: base >=4.5, text >= 1.1, bytestring >= 0.10, containers >= 0.5, mtl, csv >= 0.1- build-depends: hsbencher-fusion, hsbencher >=1.20.0.2 && <2.0+ build-depends: hsbencher-fusion, hsbencher >=1.20.0.2 && <2.0,+ handa-gdata >= 0.7.0.1+ ghc-options: -Wall default-language: Haskell2010