module Network.Google (
AccessToken
, toAccessToken
, ProjectId
, appendBody
, appendHeaders
, appendQuery
, doManagedRequest
, doRequest
, makeHeaderName
, makeProjectRequest
, makeRequest
, makeRequestValue
) where
import qualified Control.Exception as E
import Control.Concurrent (threadDelay)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Data.Default
import Data.List (intercalate)
import Data.Maybe (fromJust)
import Data.ByteString as BS (ByteString)
import Data.ByteString.Char8 as BS8 (ByteString, append, pack)
import Data.ByteString.Lazy.Char8 as LBS8 (ByteString)
import Data.ByteString.Lazy.UTF8 (toString)
import Data.CaseInsensitive as CI (CI(..), mk)
import Network.HTTP.Base (urlEncode)
import Network.HTTP.Conduit (Manager, ManagerSettings, mkManagerSettings, Request(..), RequestBody(..), Response(..), HttpException,
closeManager, httpLbs, newManager, responseBody)
import Text.JSON (JSValue, Result(Ok), decode)
import Text.XML.Light (Element, parseXMLDoc)
type AccessToken = BS.ByteString
toAccessToken ::
String
-> AccessToken
toAccessToken = BS8.pack
type ProjectId = String
makeRequest ::
AccessToken
-> (String, String)
-> String
-> (String, String)
-> Request
makeRequest accessToken (apiName, apiVersion) method (host, path) =
def {
method = BS8.pack method
, secure = True
, host = BS8.pack host
, port = 443
, path = BS8.pack path
, requestHeaders = [
(makeHeaderName apiName, BS8.pack apiVersion)
, (makeHeaderName "Authorization", BS8.append (BS8.pack "OAuth ") accessToken)
]
}
makeProjectRequest ::
ProjectId
-> AccessToken
-> (String, String)
-> String
-> (String, String)
-> Request
makeProjectRequest projectId accessToken api method hostPath =
appendHeaders
[
("x-goog-project-id", projectId)
]
(makeRequest accessToken api method hostPath)
class DoRequest a where
doRequest ::
Request
-> IO a
doRequest request =
do
manager <- newManager (mkManagerSettings def Nothing)
E.finally
(doManagedRequest manager request)
(closeManager manager)
doManagedRequest ::
Manager
-> Request
-> IO a
instance DoRequest LBS8.ByteString where
doManagedRequest manager request =
do
response <- runResourceT (httpLbs request manager)
return $ responseBody response
instance DoRequest String where
doManagedRequest manager request =
do
result <- doManagedRequest manager request
return $ toString result
instance DoRequest [(String, String)] where
doManagedRequest manager request =
do
response <- runResourceT (httpLbs request manager)
return $ read . show $ responseHeaders response
instance DoRequest () where
doManagedRequest manager request =
do
doManagedRequest manager request :: IO LBS8.ByteString
return ()
instance DoRequest Element where
doManagedRequest manager request =
do
result <- doManagedRequest manager request :: IO String
return $ fromJust $ parseXMLDoc result
instance DoRequest JSValue where
doManagedRequest manager request =
do
result <- doManagedRequest manager request :: IO String
let
Ok result' = decode result
return result'
makeRequestValue ::
String
-> BS8.ByteString
makeRequestValue = BS8.pack
makeHeaderName ::
String
-> CI.CI BS8.ByteString
makeHeaderName = CI.mk . BS8.pack
makeHeaderValue ::
String
-> BS8.ByteString
makeHeaderValue = BS8.pack
appendHeaders ::
[(String, String)]
-> Request
-> Request
appendHeaders headers request =
let
headerize :: (String, String) -> (CI.CI BS8.ByteString, BS8.ByteString)
headerize (n, v) = (makeHeaderName n, makeHeaderValue v)
in
request {
requestHeaders = requestHeaders request ++ map headerize headers
}
appendBody ::
LBS8.ByteString
-> Request
-> Request
appendBody bytes request =
request {
requestBody = RequestBodyLBS bytes
}
appendQuery ::
[(String, String)]
-> Request
-> Request
appendQuery query request =
let
makeParameter :: (String, String) -> String
makeParameter (k, v) = k ++ "=" ++ urlEncode v
query' :: String
query' = intercalate "&" $ map makeParameter query
in
request
{
queryString = BS8.pack $ '?' : query'
}
retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a
retryIORequest req retryHook = loop
where
loop [] = req
loop (delay:tl) =
E.catch req $ \ (exn::HttpException) -> do
retryHook exn
threadDelay (round$ delay * 1000 * 1000)
loop tl