module Network.Google.Api
(
Api
, ApiError(..)
, runApi
, runApi_
, throwApiError
, URL
, Path
, Params
, DownloadSink
, getJSON
, getSource
, postJSON
, putJSON
, requestJSON
, requestLbs
, authorize
, decodeBody
, addHeader
, allowStatus
, setBody
, setBodySource
, setMethod
, liftIO
, throwError
, catchError
, sinkFile
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode, encode)
import Data.ByteString (ByteString)
import Data.Conduit
import Data.Conduit.Binary (sinkFile)
import Data.Monoid ((<>))
import Data.Typeable
import GHC.Int (Int64)
import Network.HTTP.Conduit
( HttpException(..)
, Request(..)
, RequestBody(..)
, Response(..)
, Manager
, http
, httpLbs
, newManager
, parseUrl
, requestBodySource
, responseBody
, setQueryString
, tlsManagerSettings
)
import Network.HTTP.Types
( Header
, Method
, Status
, hAuthorization
, hContentType
)
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
type DownloadSink a =
ResumableSource (ResourceT IO) ByteString -> ResourceT IO a
data ApiError
= HttpError HttpException
| InvalidJSON String
| GenericError String
deriving Typeable
instance Show ApiError where
show (HttpError ex) = "HTTP Exception: " <> show ex
show (InvalidJSON msg) = "failure parsing JSON: " <> msg
show (GenericError msg) = msg
instance E.Exception ApiError
type Api = ReaderT (String, Manager) (ExceptT ApiError IO)
runApi :: String
-> Api a
-> IO (Either ApiError a)
runApi token f = do
manager <- newManager tlsManagerSettings
runExceptT $ runReaderT f (token, manager)
runApi_ :: String -> Api a -> IO ()
runApi_ token f = either E.throw (const $ return ()) =<< runApi token f
throwApiError :: String -> Api a
throwApiError = throwError . GenericError
type URL = String
type Path = String
type Params = [(ByteString, Maybe ByteString)]
getJSON :: FromJSON a => URL -> Params -> Api a
getJSON url params = requestJSON url $ setQueryString params
getSource :: URL -> Params -> DownloadSink a -> Api a
getSource url params withSource = do
request <- setQueryString params <$> authorize url
withManager' $ \manager -> do
response <- http request manager
withSource $ responseBody response
postJSON :: (ToJSON a, FromJSON b) => URL -> Params -> a -> Api b
postJSON url params body =
requestJSON url $
addHeader (hContentType, "application/json") .
setMethod "POST" .
setQueryString params .
setBody (encode body)
putJSON :: (ToJSON a, FromJSON b) => URL -> Params -> a -> Api b
putJSON url params body =
requestJSON url $
addHeader (hContentType, "application/json") .
setMethod "PUT" .
setQueryString params .
setBody (encode body)
requestJSON :: FromJSON a => URL -> (Request -> Request) -> Api a
requestJSON url modify = decodeBody =<< requestLbs url modify
requestLbs :: URL -> (Request -> Request) -> Api (Response BL.ByteString)
requestLbs url modify = do
request <- authorize url
withManager' $ httpLbs $ modify request
authorize :: URL -> Api Request
authorize url = do
(token, _) <- ask
request <- parseUrl' url
let authorization = C8.pack $ "Bearer " <> token
return $ addHeader (hAuthorization, authorization) request
addHeader :: Header -> Request -> Request
addHeader header request =
request { requestHeaders = header:requestHeaders request }
setMethod :: Method -> Request -> Request
setMethod m request = request { method = m }
setBody :: BL.ByteString -> Request -> Request
setBody bs request = request { requestBody = RequestBodyLBS bs }
setBodySource :: Int64 -> Source (ResourceT IO) ByteString -> Request -> Request
setBodySource len source request =
request { requestBody = requestBodySource len source }
allowStatus :: Status -> Request -> Request
allowStatus status request =
let original = checkStatus request
override s r c
| s == status = Nothing
| otherwise = original s r c
in request { checkStatus = override }
decodeBody :: FromJSON a => Response BL.ByteString -> Api a
decodeBody =
either (throwError . InvalidJSON) return . eitherDecode . responseBody
parseUrl' :: URL -> Api Request
parseUrl' url = case parseUrl url of
Just request -> return request
Nothing -> throwApiError $ "Invalid URL: " <> url
withManager' :: (Manager -> ResourceT IO a) -> Api a
withManager' f = do
(_, manager) <- ask
result <- liftIO $ E.try $ runResourceT $ f manager
either (throwError . HttpError) return result