module HSBencher.Internal.Fusion
( initialize
, FusionConfig(..)
, getSomething
, getWithSQLQuery
, init
, ColData(..)
, FTValue(..)
)
where
import HSBencher.Types
import Network.Google.OAuth2
import Network.Google.FusionTables hiding (createTable)
import qualified Network.Google.FusionTables as FT
import Network.HTTP.Conduit (HttpException)
import Control.Monad.Reader
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.Format ()
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))
import System.IO (hPutStrLn, stderr)
import Prelude hiding (init)
import Network.HTTP.Conduit (Request(..), RequestBody(..),parseUrl)
import System.Environment (getEnvironment)
import System.IO.Unsafe (unsafePerformIO)
data FusionException = FusionException String
| TableNotFoundException
| FailedCreateTableException
| MoreThanOneTableFoundException
deriving (Show, Typeable)
instance E.Exception FusionException
fusionTag str = "[HSBencher.Internal.Fusion] " ++ str
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)
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 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
getTableId :: OAuth2Client
-> String
-> IO TableId
getTableId auth table_name = do
hPutStrLn stderr $ fusionTag "Fetching information from Google"
tokens <- getCachedTokens auth
let atok = B.pack $ accessToken tokens
Just allTables <- stdRetry "listTables" auth tokens $ listTables atok
case filter (\t -> tab_name t == table_name) allTables of
[] -> E.throwIO TableNotFoundException
[t] -> do
let table_id = tab_tableId t
return table_id
_ -> E.throwIO MoreThanOneTableFoundException
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
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
stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a ->
IO (Maybe a)
stdRetry msg client toks action = do
let retryHook num exn = do
stdRetry "refresh tokens" client toks (refreshTokens client toks)
return ()
retryIORequest action retryHook $
[1,2,4,4,4,4,4,4,8,16]
++ replicate 30 5
++ replicate 10 10
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)
loop (num+1) tl
data FusionConfig =
FusionConfig
{ fusionTableID :: Maybe TableId
, fusionClientID :: Maybe String
, fusionClientSecret :: Maybe String
, serverColumns :: [String]
}
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