{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Google.Client
( getToken
, getCalendarEventList
, postCalendarEvent
, postGmailSend
) where
import Data.Aeson (FromJSON, ToJSON)
import Data.ByteString.Base64.URL (encode)
import qualified Data.ByteString.Lazy as LBS
import Data.Data (Data)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.Mail.Mime
import Servant.API
( (:<|>)(..)
, (:>)
, Capture
, FormUrlEncoded
, FromHttpApiData
, Get
, Header
, JSON
, Post
, QueryParam
, ReqBody
, ToHttpApiData
)
import Servant.Client
( BaseUrl(BaseUrl)
, ClientM
, Scheme(..)
, ServantError
, client
, mkClientEnv
, runClientM
)
import qualified Google.Form as Form
import Google.JWT (JWT)
import qualified Google.JWT as JWT
import qualified Google.Response as Response
newtype Bearer = Bearer
{ _unBearer :: Text
} deriving ( Data
, Eq
, FromHttpApiData
, FromJSON
, Generic
, Ord
, Show
, ToHttpApiData
, ToJSON
, Typeable
)
type API
= "oauth2" :> "v4" :> "token" :>
ReqBody '[ FormUrlEncoded] Form.Token :>
Post '[ JSON] Response.Token
:<|> "calendar" :> "v3" :> "calendars" :>
Capture "calendarId" Text :>
"events" :>
Header "Authorization" Bearer :>
QueryParam "singleEvents" Bool :>
QueryParam "timeMin" Form.DateTime :>
QueryParam "timeMax" Form.DateTime :>
QueryParam "orderBy" Text :>
Get '[ JSON] Response.CalendarEventList
:<|> "calendar" :> "v3" :> "calendars" :>
Capture "calendarId" Text :>
"events" :>
Header "Authorization" Bearer :>
ReqBody '[ JSON] Form.CalendarEvent :>
Post '[ JSON] Response.CalendarEvent
:<|> "gmail" :> "v1" :> "users" :> "me" :> "messages" :> "send" :>
Header "Authorization" Bearer :>
ReqBody '[ JSON] Form.GmailSend :>
Post '[ JSON] Response.GmailSend
api :: Proxy API
api = Proxy
getToken' :: Form.Token -> ClientM Response.Token
getCalendarEventList' ::
Text
-> Maybe Bearer
-> Maybe Bool
-> Maybe Form.DateTime
-> Maybe Form.DateTime
-> Maybe Text
-> ClientM Response.CalendarEventList
postCalendarEvent' ::
Text
-> Maybe Bearer
-> Form.CalendarEvent
-> ClientM Response.CalendarEvent
postGmailSend' :: Maybe Bearer -> Form.GmailSend -> ClientM Response.GmailSend
getToken' :<|> getCalendarEventList' :<|> postCalendarEvent' :<|> postGmailSend' = client api
getToken ::
Maybe JWT.Email
-> JWT
-> [JWT.Scope]
-> IO (Either ServantError Response.Token)
getToken maccount jwt scopes = do
manager <- newManager tlsManagerSettings
Right a <- JWT.getSignedJWT jwt maccount scopes Nothing
runClientM
(getToken' $
Form.Token
{ grantType = googleGrantType
, assertion = decodeUtf8 . JWT.unSignedJWT $ a
})
(mkClientEnv manager googleBaseUrl)
getCalendarEventList ::
Response.Token
-> Text
-> Maybe Bool
-> Maybe Form.DateTime
-> Maybe Form.DateTime
-> Maybe Text
-> IO (Either ServantError Response.CalendarEventList)
getCalendarEventList token calendarId singleEvents timeMin timeMax orderBy = do
manager <- newManager tlsManagerSettings
runClientM
(getCalendarEventList'
calendarId
(pure . toBearer $ token)
singleEvents
timeMin
timeMax
orderBy)
(mkClientEnv manager googleBaseUrl)
postCalendarEvent ::
Response.Token
-> Form.CalendarEvent
-> IO (Either ServantError Response.CalendarEvent)
postCalendarEvent token event = do
manager <- newManager tlsManagerSettings
runClientM
(postCalendarEvent'
(Form.email . Form.creator $ event)
(pure . toBearer $ token)
event)
(mkClientEnv manager googleBaseUrl)
postGmailSend ::
Response.Token -> Form.Email -> IO (Either ServantError Response.GmailSend)
postGmailSend token email = do
manager <- newManager tlsManagerSettings
mail <- (renderMail' =<< Form.toMail email)
let gmailSend = Form.GmailSend {raw = decodeUtf8 $ encode $ LBS.toStrict mail}
runClientM
(postGmailSend' (pure . toBearer $ token) gmailSend)
(mkClientEnv manager googleBaseUrl)
toBearer :: Response.Token -> Bearer
toBearer Response.Token {accessToken} = Bearer $ "Bearer " <> accessToken
googleGrantType :: Text
googleGrantType = "urn:ietf:params:oauth:grant-type:jwt-bearer"
googleBaseUrl :: BaseUrl
googleBaseUrl = BaseUrl Https "www.googleapis.com" 443 ""