hsbencher-fusion 0.1.0.0 → 0.2
raw patch · 4 files changed
+331/−33 lines, 4 filesdep +data-defaultdep +networkdep ~handa-gdatadep ~hsbencherdep ~http-conduit
Dependencies added: data-default, network
Dependency ranges changed: handa-gdata, hsbencher, http-conduit, mtl
Files
- HSBencher/Backend/Fusion.hs +51/−24
- HSBencher/Internal/Fusion.hs +231/−0
- LICENSE +30/−0
- hsbencher-fusion.cabal +19/−9
HSBencher/Backend/Fusion.hs view
@@ -24,6 +24,7 @@ import qualified Control.Exception as E import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe) import Data.Dynamic+import Data.Default (Default(..)) import qualified Data.Set as S import qualified Data.Map as M import qualified Data.List as L@@ -39,6 +40,7 @@ import Network.HTTP.Conduit (HttpException) import HSBencher.Types import HSBencher.Internal.Logging (log)+import HSBencher.Internal.Fusion import Prelude hiding (log) import System.IO (hPutStrLn, stderr) import System.IO.Unsafe (unsafePerformIO)@@ -51,12 +53,16 @@ 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.+-- | A default plugin. This binding provides future-proof way to get+-- a default instance of the plugin, in the eventuality that more+-- configuration options are added in the future. defaultFusionPlugin :: FusionPlug defaultFusionPlugin = FusionPlug +-- | This is the same as defaultFusionPlugin+instance Default FusionPlug where+ def = defaultFusionPlugin+ ---------------------------------------------------------------------------------------------------- -- #ifdef FUSION_TABLES -- import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))@@ -119,7 +125,10 @@ threadDelay (round$ delay * 1000 * 1000) -- Microseconds loop (num+1) tl +fromJustErr msg Nothing = error msg+fromJustErr _ (Just x) = x + -- | 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. --@@ -132,9 +141,11 @@ toks <- liftIO$ getCachedTokens auth log$ " [fusiontable] Retrieved: "++show toks let atok = B.pack $ accessToken toks- Just allTables <- stdRetry "listTables" auth toks $ listTables atok+ 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@@ -182,16 +193,41 @@ 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 + +-- ////// Enable working with Custom tags++ let ourSchema = map fst $ benchmarkResultToSchema br+ ourSet = S.fromList ourSchema + if null _CUSTOM + then log$ " [fusiontable] Computed schema, no custom fields."+ else log$ " [fusiontable] Computed schema, including these custom fields: " ++ show _CUSTOM+ 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+ log$ " [fusiontable] There were " ++ show (length misslist) ++ " columns missing"+ unless (S.null missing) $ do+ forM_ misslist $ \ colname -> do+ liftIO$ createColumn atok tid (colname, STRING)+ -- Create with the correct type !? Above just states STRING. + +--- ////// END++ 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 ]+ | key <- serverColumns ++ misslist ] (cols,vals) = unzip tuple 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@@ -209,6 +245,7 @@ -- -- 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)@@ -251,7 +288,15 @@ -- New field: [2014.02.19] , ("ALLJITTIMES", STRING) -- In order of trials like ALLTIMES. ]+ +benchmarkResultToSchema bm = fusionSchema ++ map custom (_CUSTOM bm) + where+ custom (tag, IntResult _) = (tag,NUMBER)+ custom (tag, DoubleResult _) = (tag,NUMBER)+ custom (tag, StringResult _) = (tag, STRING) ++ -- | The type of Fusion table plugins. Currently this is a singleton type; there is -- really only one fusion plugin. data FusionPlug = FusionPlug@@ -261,13 +306,6 @@ 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"@@ -340,16 +378,5 @@ | 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)-
+ HSBencher/Internal/Fusion.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-} +++-- | Common functionality for uploading and downloading data+-- from Google FusionTables. +++module HSBencher.Internal.Fusion+ ( initialize+ , FusionConfig(..)+ -- Experiments+ , getSomething+ -- replaces getSomething+ , getWithSQLQuery+ , init+ , ColData(..) -- export from hgdata+ , FTValue(..) -- export from hgdata + )+ where+++-- HSBencher +import HSBencher.Types++-- Google API+import Network.Google.OAuth2 +import Network.Google.FusionTables hiding (createTable)+import qualified Network.Google.FusionTables as FT++-- Network+import Network.HTTP.Conduit (HttpException)++-- Control+import Control.Monad.Reader+import Control.Concurrent (threadDelay)+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))++-- Print to stderr+import System.IO (hPutStrLn, stderr)++-- Prelude+import Prelude hiding (init) ++-- TEMPORARY+import Network.HTTP.Conduit (Request(..), RequestBody(..),parseUrl)+import System.Environment (getEnvironment)+import System.IO.Unsafe (unsafePerformIO)++---------------------------------------------------------------------------+-- Exception+data FusionException = FusionException String+ | TableNotFoundException+ | FailedCreateTableException+ | MoreThanOneTableFoundException + deriving (Show, Typeable)++instance E.Exception FusionException + +++---------------------------------------------------------------------------+--+fusionTag str = "[HSBencher.Internal.Fusion] " ++ str+++---------------------------------------------------------------------------+-- Initialization and Authorization++initialize cid sec table_name = do+ hPutStrLn stderr $ fusionTag "Initializing"+ let auth = OAuth2Client { clientId=cid, clientSecret=sec }+ table_id <- getTableId auth table_name+ cols <- getTableColumns auth table_id + hPutStrLn stderr $ fusionTag (table_id ++ " " ++ show cols)+ return (table_id,cols)++-- //// experimenting Needs to be updated! + +init cid sec table_name = do+ hPutStrLn stderr $ fusionTag "Initializing"+ let auth = OAuth2Client { clientId=cid, clientSecret=sec }+ table_id <- getTableId auth table_name+ cols <- getTableColumns auth table_id + hPutStrLn stderr $ fusionTag (table_id ++ " " ++ show cols)+ return (table_id, auth)+++--getSomething :: OAuth2Client -> TableId -> String -> Request m+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 auth table_id query = do+ tokens <- getCachedTokens auth+ let atok = B.pack $ accessToken tokens+ tableSQLQuery atok table_id query++++-- \\\\++-- | Obtain the id of a FusionTable identified by name.+getTableId :: OAuth2Client + -> String -- ^ Human-readable name of the fusion table+ -> IO TableId+getTableId auth table_name = do+ hPutStrLn stderr $ fusionTag "Fetching information from Google"++ tokens <- getCachedTokens auth++ -- hPutStrLn stderr $ fusionTag $ "retrieved tokens: " ++ show tokens++ let atok = B.pack $ accessToken tokens++ -- error check here+ Just allTables <- stdRetry "listTables" auth tokens $ listTables atok ++ -- hPutStrLn stderr $ fusionTag $ "Found " ++ show (length allTables) ++ " tables."++ case filter (\t -> tab_name t == table_name) allTables of+ [] -> E.throwIO TableNotFoundException+ -- Replace with an exception and let user of this library handle that+ [t] -> do+ let table_id = tab_tableId t+ return table_id+ _ -> E.throwIO MoreThanOneTableFoundException ++-- | Obtain the column headings from a FusionTable +getTableColumns :: OAuth2Client -> TableId -> IO [String]+getTableColumns auth table_id = do+ tokens <- getCachedTokens auth+ let atok = B.pack $ accessToken tokens++ columns <- fmap (map col_name) $ listColumns atok table_id+ return columns + ++-- | Create a FusionTable with a column schema+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 $+ FT.createTable atok table_name schema+ case result of+ Just TableMetadata{tab_tableId} -> return tab_tableId+ Nothing -> E.throwIO FailedCreateTableException++++---------------------------------------------------------------------------+-- Internal: HTTP requests retry behaviour+ +stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a ->+ IO (Maybe a)+stdRetry msg client toks action = do+ let retryHook num exn = do+ -- datetime <- getDateTime+ stdRetry "refresh tokens" client toks (refreshTokens client toks)+ return ()+ + retryIORequest action retryHook $+ [1,2,4,4,4,4,4,4,8,16] --- 32,64,+ ++ replicate 30 5+ + +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+++---------------------------------------------------------------------------+-- Upload++++---------------------------------------------------------------------------+-- Download ++++++---------------------------------------------------------------------------+-- Data ++-- | 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)++instance Default FusionConfig where+ def = FusionConfig + { fusionTableID = Nothing + , fusionClientID = lookup "HSBENCHER_GOOGLE_CLIENTID" theEnv+ , fusionClientSecret = lookup "HSBENCHER_GOOGLE_CLIENTSECRET" theEnv+ , serverColumns = []+ }++theEnv :: [(String,String)] +theEnv = unsafePerformIO getEnvironment
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Ryan Newton++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ryan Newton nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
hsbencher-fusion.cabal view
@@ -2,11 +2,16 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hsbencher-fusion-version: 0.1.0.0+version: 0.2 synopsis: Backend for uploading benchmark data to Google Fusion Tables.--- description: -license: MIT--- license-file: LICENSE+description: Google Fusion tables are a type of Google Doc that resembles a+ 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++license: BSD3+license-file: LICENSE author: Ryan Newton maintainer: rrnewton@gmail.com -- copyright: @@ -16,19 +21,24 @@ 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, 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+ http-conduit == 1.9.0,+ network == 2.5.0.0,+ data-default >= 0.5.3,+ -- mtl >=2.1 && <2.2, + mtl,+ handa-gdata >= 0.6.9.3 && <0.7, + hsbencher >=1.11 && <2.0 -- hs-source-dirs: default-language: Haskell2010 -- FIXME: cpp-options: -DFUSION_TABLES+