module HSBencher.Internal.Fusion
( initialize
, FusionConfig(..)
, getSomething
, getWithSQLQuery
, init
, ColData(..)
, FTValue(..)
)
where
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.Format ()
import qualified Data.ByteString.Char8 as B
import Data.Dynamic
import Data.Default (Default(def))
import System.IO (hPutStrLn, stderr)
import Prelude hiding (init)
import System.Environment (getEnvironment)
import System.IO.Unsafe (unsafePerformIO)
data FusionException = FusionException String
| TableNotFoundException
| FailedCreateTableException
| MoreThanOneTableFoundException
deriving (Show, Typeable)
instance E.Exception FusionException
fusionTag :: String -> String
fusionTag str = "[HSBencher.Internal.Fusion] " ++ str
initialize :: String -> String -> String -> IO (TableId, [String])
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 :: String -> String -> String -> IO (TableId, OAuth2Client)
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 -> 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
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