hsbencher-fusion (empty) → 0.1.0.0
raw patch · 3 files changed
+391/−0 lines, 3 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, directory, filepath, handa-gdata, hsbencher, http-conduit, mtl, time
Files
- HSBencher/Backend/Fusion.hs +355/−0
- Setup.hs +2/−0
- hsbencher-fusion.cabal +34/−0
+ HSBencher/Backend/Fusion.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards, ScopedTypeVariables, CPP, BangPatterns #-}+{-# LANGUAGE TupleSections, DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}++-- | Google Fusion Table upload of benchmark data.+-- +-- This module must be used in conjunction with the main "hsbencher" package,+-- e.g. "import HSBencher".++module HSBencher.Backend.Fusion+ ( -- * The plugin itself, what you probably want + defaultFusionPlugin++ -- * Details and configuration options.+ , FusionConfig(..), stdRetry, getTableId+ , fusionSchema, resultToTuple+ , uploadBenchResult+ , FusionPlug(), FusionCmdLnFlag(..),+ )+ where++import Control.Monad.Reader+import Control.Concurrent (threadDelay)+import qualified Control.Exception as E+import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)+import Data.Dynamic+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.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,+ TableId, CellType(..), TableMetadata(..), ColumnMetadata(..))+import Network.HTTP.Conduit (HttpException)+import HSBencher.Types+import HSBencher.Internal.Logging (log)+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+++-- | A default plugin. This may seem pointless, but we abstract over the internals+-- of FusionPlug to enable backwards compatibility in the phase of future extensions.+defaultFusionPlugin :: FusionPlug+defaultFusionPlugin = FusionPlug++----------------------------------------------------------------------------------------------------+-- #ifdef FUSION_TABLES+-- import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))+-- import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows,+-- TableId, CellType(..), TableMetadata(..))+-- import HSBencher.Fusion (getTableId, fusionPlugin)+-- #endif++----------------------------------------------------------------------------------------------------++-- defaultColumns =+-- ["Program","Args","Threads","Sched","Threads",+-- "MinTime","MedianTime","MaxTime", "MinTime_Prod","MedianTime_Prod","MaxTime_Prod"]+++-- | The standard retry behavior when receiving HTTP network errors. Note that this+-- can retry for quite a long while so it is only to be usedfrom batch applications.+stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a ->+ BenchM (Maybe a)+stdRetry msg client toks action = do+ conf <- ask+ let retryHook num exn = runReaderT (do+ datetime <- lift$ getDateTime+ log$ " [fusiontable] Retry #"++show num++" during <"++msg++"> due to HTTPException: " ++ show exn+ log$ " [fusiontable] ("++datetime++") Retrying, but first, attempt token refresh..."+ -- QUESTION: should we retry the refresh itself, it is NOT inside the exception handler.+ -- liftIO$ refreshTokens client toks+ -- liftIO$ retryIORequest (refreshTokens client toks) (\_ -> return ()) [1,1]+ stdRetry "refresh tokens" client toks (refreshTokens client toks)+ return ()+ ) conf+ liftIO$ retryIORequest action retryHook $+ [1,2,4,4,4,4,4,4,8,16] --- 32,64,+ ++ replicate 30 5++getDateTime :: IO String+getDateTime = do + utc <- getCurrentTime+ -- let day = utctDay utc+ -- secs = utctDayTime utc+-- return $ show day ++" "++show secs+ return $ show utc++-- | Takes an idempotent IO action that includes a network request. Catches+-- `HttpException`s and tries a gain a certain number of times. The second argument+-- is a callback to invoke every time a retry occurs.+-- +-- Takes a list of *seconds* to wait between retries. A null list means no retries,+-- an infinite list will retry indefinitely. The user can choose whatever temporal+-- pattern they desire (e.g. exponential backoff).+--+-- Once the retry list runs out, if it has not been successful, this function returns Nothing.+retryIORequest :: IO a -> (Int -> HttpException -> IO ()) -> [Double] -> IO (Maybe a)+retryIORequest req retryHook times = loop 0 times+ where+ loop _ [] = return Nothing+ loop !num (delay:tl) = + E.catch (fmap Just req) $ \ (exn::HttpException) -> do + retryHook num exn+ threadDelay (round$ delay * 1000 * 1000) -- Microseconds+ loop (num+1) tl+++-- | 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.+getTableId :: OAuth2Client -> String -> BenchM (TableId, [String])+getTableId 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+ let atok = B.pack $ accessToken toks+ Just allTables <- 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)+ [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+ ColumnMetadata{col_name, col_columnId} <- liftIO$ 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++++-- | 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 }+ -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload:+ toks <- liftIO$ getCachedTokens authclient+ let ourData = M.fromList $ resultToTuple br+ -- Any field HSBencher doesn't know about just gets an empty string:+ tuple = [ (key, fromMaybe "" (M.lookup key ourData))+ | key <- serverColumns ]+ (cols,vals) = unzip tuple+ log$ " [fusiontable] Uploading row with "++show (length cols)+++ " columns containing "++show (sum$ map length vals)++" characters of data"++ -- 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 () +++-- | A representaton used for creating tables. Must be isomorphic to+-- `BenchmarkResult`. This could perhaps be generated automatically.+-- +-- Note, order is important here, because this is the preferred order we'd like to+-- have it in the Fusion table.+fusionSchema :: [(String, CellType)]+fusionSchema =+ [ ("PROGNAME",STRING)+ , ("VARIANT",STRING)+ , ("ARGS",STRING) + , ("HOSTNAME",STRING)+ , ("MINTIME", NUMBER)+ , ("MEDIANTIME", NUMBER)+ , ("MAXTIME", NUMBER)+ -- The run is identified by hostname_secondsSinceEpoch:+ , ("RUNID",STRING)+ , ("CI_BUILD_ID",STRING) + , ("THREADS",NUMBER)+ , ("DATETIME",DATETIME) + , ("MINTIME_PRODUCTIVITY", NUMBER)+ , ("MEDIANTIME_PRODUCTIVITY", NUMBER)+ , ("MAXTIME_PRODUCTIVITY", NUMBER)+ , ("ALLTIMES", STRING)+ , ("TRIALS", NUMBER)+ , ("COMPILER",STRING)+ , ("COMPILE_FLAGS",STRING)+ , ("RUNTIME_FLAGS",STRING)+ , ("ENV_VARS",STRING)+ , ("BENCH_VERSION", STRING)+ , ("BENCH_FILE", STRING)+-- , ("OS",STRING)+ , ("UNAME",STRING)+ , ("PROCESSOR",STRING)+ , ("TOPOLOGY",STRING)+ , ("GIT_BRANCH",STRING)+ , ("GIT_HASH",STRING)+ , ("GIT_DEPTH",NUMBER)+ , ("WHO",STRING)+ , ("ETC_ISSUE",STRING)+ , ("LSPCI",STRING) + , ("FULL_LOG",STRING)+ -- New fields: [2013.12.01]+ , ("MEDIANTIME_ALLOCRATE", STRING)+ , ("MEDIANTIME_MEMFOOTPRINT", STRING)+ -- New field: [2014.02.19]+ , ("ALLJITTIMES", STRING) -- In order of trials like ALLTIMES.+ ]++-- | The type of Fusion table plugins. Currently this is a singleton type; there is+-- really only one fusion plugin.+data FusionPlug = FusionPlug+ deriving (Eq,Show,Ord,Read)++instance Plugin FusionPlug where+ type PlugConf FusionPlug = FusionConfig+ type PlugFlag FusionPlug = FusionCmdLnFlag++ defaultPlugConf _ = FusionConfig + { fusionTableID = Nothing + , fusionClientID = lookup "HSBENCHER_GOOGLE_CLIENTID" theEnv+ , fusionClientSecret = lookup "HSBENCHER_GOOGLE_CLIENTSECRET" theEnv+ , serverColumns = []+ }++ -- | Better be globally unique! Careful.+ plugName _ = "fusion" + -- plugName _ = "Google_FusionTable_Backend"++ plugCmdOpts _ = fusion_cli_options++ plugUploadRow p cfg row = runReaderT (uploadBenchResult row) cfg++ plugInitialize p gconf = do + putStrLn " [fusiontable] Fusion table plugin initializing.. First, find config."+ gc2 <- let fc@FusionConfig{fusionClientID, fusionClientSecret, fusionTableID} =+ 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 name,_) -> do+ case (fusionClientID, fusionClientSecret) of+ (Just cid, Just sec ) -> do+ let auth = OAuth2Client { clientId=cid, clientSecret=sec }+ (tid,cols) <- runReaderT (getTableId auth name) gconf+ putStrLn$ " [fusiontable] -> Resolved name "++show name++" to table ID " ++show tid+ return $! setMyConf p fc{ fusionTableID= Just tid, serverColumns= cols } gconf + (_,_) -> error "When --fusion-upload is activated --clientid and --clientsecret are required (or equiv ENV vars)"+ let fc2 = getMyConf p gc2+ 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++ -- TEMP: This should become another command line flag: --fusion-list to list the tables.+{-+ putStrLn " [fusiontable] Next, to test our connections, attempt to list tables:"+ strs <- fmap (map tab_name) (listTables (B.pack (accessToken toks)))+ putStrLn$" [fusiontable] All of users tables:\n"++ unlines (map (" "++) strs)+-}+ return gc2++ foldFlags p flgs cnf0 = + foldr ($) cnf0 (map doFlag flgs)+ where + -- TODO: Move this one to the global config+ doFlag FusionTest r = r+ doFlag (ClientID cid) r = r { fusionClientID = Just cid } + doFlag (ClientSecret s) r = r { fusionClientSecret = Just s } + doFlag (FusionTables m) r = +-- let r2 = r { doFusionUpload = True } in+ case m of + 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])+fusion_cli_options =+ ("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 [] ["fusion-test"] (NoArg FusionTest) "Test authentication and list tables if possible." + ])++-- | Parsed command line options provided by the user initiating benchmarking.+data FusionCmdLnFlag = + FusionTables (Maybe TableId)+ | ClientID String+ | ClientSecret String+ | FusionTest+ deriving (Show,Read,Ord,Eq, Typeable)++-- | Configuration options for Google Fusion Table uploading.+data FusionConfig = + FusionConfig+ { fusionTableID :: Maybe TableId -- ^ This must be Just whenever doFusionUpload is true.+ , fusionClientID :: Maybe String+ , fusionClientSecret :: Maybe String+ , serverColumns :: [String] -- ^ Record the ordering of columns server side.+ }+ deriving (Show,Read,Ord,Eq, Typeable)+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsbencher-fusion.cabal view
@@ -0,0 +1,34 @@+-- Initial hsbencher-fusion.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: hsbencher-fusion+version: 0.1.0.0+synopsis: Backend for uploading benchmark data to Google Fusion Tables.+-- description: +license: MIT+-- 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+ -- other-modules: + other-extensions: NamedFieldPuns, RecordWildCards, ScopedTypeVariables, CPP, BangPatterns, TupleSections, DeriveDataTypeable, TypeFamilies+ build-depends: base >=4.5 && < 4.8, + containers >=0.5, bytestring >=0.10,+ time >=1.4, directory >=1.2, filepath >=1.3,+-- http-conduit >=2.0 && <2.1, + http-conduit >= 1.9.0,+ mtl >=2.1 && <2.2, + handa-gdata >= 0.6.9.1 && <0.7, + hsbencher >=1.8 && <1.9+ -- hs-source-dirs: + default-language: Haskell2010++ -- FIXME:+ cpp-options: -DFUSION_TABLES