diff --git a/CSVUploader/Main.hs b/CSVUploader/Main.hs --- a/CSVUploader/Main.hs +++ b/CSVUploader/Main.hs @@ -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 diff --git a/CriterionUploader/Main.hs b/CriterionUploader/Main.hs --- a/CriterionUploader/Main.hs +++ b/CriterionUploader/Main.hs @@ -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)) ++ diff --git a/HSBencher/Backend/Fusion.hs b/HSBencher/Backend/Fusion.hs --- a/HSBencher/Backend/Fusion.hs +++ b/HSBencher/Backend/Fusion.hs @@ -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." ]) diff --git a/HSBencher/Internal/Fusion.hs b/HSBencher/Internal/Fusion.hs --- a/HSBencher/Internal/Fusion.hs +++ b/HSBencher/Internal/Fusion.hs @@ -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 $ diff --git a/hsbencher-fusion.cabal b/hsbencher-fusion.cabal --- a/hsbencher-fusion.cabal +++ b/hsbencher-fusion.cabal @@ -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: - . + . 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