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