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.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, Request(..), RequestBody(..), Response(..), HttpException,
closeManager, def, 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 m
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 m
makeProjectRequest projectId accessToken api method hostPath =
appendHeaders
[
("x-goog-project-id", projectId)
]
(makeRequest accessToken api method hostPath)
class DoRequest a where
doRequest ::
Request (ResourceT IO)
-> IO a
doRequest request =
do
manager <- newManager def
E.finally
(doManagedRequest manager request)
(closeManager manager)
doManagedRequest ::
Manager
-> Request (ResourceT IO)
-> 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 m
-> Request m
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 m
-> Request m
appendBody bytes request =
request {
requestBody = RequestBodyLBS bytes
}
appendQuery ::
[(String, String)]
-> Request m
-> Request m
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 times = loop times
where
loop [] = req
loop (delay:tl) =
E.catch req $ \ (exn::HttpException) -> do
retryHook exn
threadDelay (round$ delay * 1000 * 1000)
loop tl