{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
module Network.GMail.Simple
(
Key (..)
, readKeyFile
, Session
, newSession
, MailAddress (..)
, Mail (..)
, sendMail
, ToMailBody (..)
, GMailException (..)
) where
import Control.Monad (unless)
import Control.Exception (Exception, throwIO)
import Control.Concurrent (MVar, newMVar, modifyMVar)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Web.JWT as JWT
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Aeson as JSON
import qualified Network.HTTP.Simple as HTTP
import Data.ByteString.Base64 (encodeBase64)
import Network.HTTP.Media (MediaType)
import qualified Network.HTTP.Media as Media
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import qualified Web.FormUrlEncoded as URLEncoded
import Crypto.PubKey.RSA.Types (PrivateKey)
import qualified Data.Map as Map
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LazyB
import Text.Blaze.Html (Html)
import qualified Text.Blaze.Html.Renderer.Text as HTML
newtype MailAddress = MailAddress Text
mailAddressText :: MailAddress -> Text
mailAddressText :: MailAddress -> Text
mailAddressText (MailAddress Text
t) = Text
t
instance IsString MailAddress where
fromString :: String -> MailAddress
fromString = Text -> MailAddress
MailAddress (Text -> MailAddress) -> (String -> Text) -> String -> MailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString
data Mail a = Mail
{
Mail a -> Text
mail_sender :: Text
, Mail a -> MailAddress
mail_recipient :: MailAddress
, Mail a -> Text
mail_subject :: Text
, Mail a -> a
mail_body :: a
}
instance Functor Mail where
fmap :: (a -> b) -> Mail a -> Mail b
fmap a -> b
f Mail a
mail = Mail a
mail { mail_body :: b
mail_body = a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Mail a -> a
forall a. Mail a -> a
mail_body Mail a
mail }
data Key = Key
{ Key -> PrivateKey
private_key :: PrivateKey
, Key -> Text
private_key_id :: Text
, Key -> MailAddress
client_email :: MailAddress
}
readKeyFile :: FilePath -> IO Key
readKeyFile :: String -> IO Key
readKeyFile String
fp = String -> IO ByteString
LazyB.readFile String
fp IO ByteString -> (ByteString -> IO Key) -> IO Key
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(String -> IO Key)
-> (Key -> IO Key) -> Either String Key -> IO Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GMailException -> IO Key
forall e a. Exception e => e -> IO a
throwIO (GMailException -> IO Key)
-> (String -> GMailException) -> String -> IO Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GMailException
FailedToParseKey) Key -> IO Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Key -> IO Key)
-> (ByteString -> Either String Key) -> ByteString -> IO Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Key
forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode
instance JSON.FromJSON Key where
parseJSON :: Value -> Parser Key
parseJSON = String -> (Object -> Parser Key) -> Value -> Parser Key
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"Key" ((Object -> Parser Key) -> Value -> Parser Key)
-> (Object -> Parser Key) -> Value -> Parser Key
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
Text
pkt <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"private_key"
case ByteString -> Maybe PrivateKey
JWT.readRsaSecret (ByteString -> Maybe PrivateKey) -> ByteString -> Maybe PrivateKey
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
pkt of
Just PrivateKey
pk -> PrivateKey -> Text -> MailAddress -> Key
Key
(PrivateKey -> Text -> MailAddress -> Key)
-> Parser PrivateKey -> Parser (Text -> MailAddress -> Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrivateKey -> Parser PrivateKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrivateKey
pk
Parser (Text -> MailAddress -> Key)
-> Parser Text -> Parser (MailAddress -> Key)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"private_key_id"
Parser (MailAddress -> Key) -> Parser MailAddress -> Parser Key
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> MailAddress
MailAddress (Text -> MailAddress) -> Parser Text -> Parser MailAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"client_email")
Maybe PrivateKey
_ -> String -> Parser Key
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Error parsing private key."
data OAuth = OAuth
{ OAuth -> Text
oauth_access_token :: Text
, OAuth -> NominalDiffTime
oauth_expires_in :: NominalDiffTime
}
instance JSON.FromJSON OAuth where
parseJSON :: Value -> Parser OAuth
parseJSON = String -> (Object -> Parser OAuth) -> Value -> Parser OAuth
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"OAuth" ((Object -> Parser OAuth) -> Value -> Parser OAuth)
-> (Object -> Parser OAuth) -> Value -> Parser OAuth
forall a b. (a -> b) -> a -> b
$ \Object
o ->
Text -> NominalDiffTime -> OAuth
OAuth (Text -> NominalDiffTime -> OAuth)
-> Parser Text -> Parser (NominalDiffTime -> OAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"access_token" Parser (NominalDiffTime -> OAuth)
-> Parser NominalDiffTime -> Parser OAuth
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser NominalDiffTime
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"expires_in"
oauthQuery
:: Key
-> MailAddress
-> IO OAuth
oauthQuery :: Key -> MailAddress -> IO OAuth
oauthQuery Key
k MailAddress
sender = do
NominalDiffTime
now <- IO NominalDiffTime
getPOSIXTime
let
h :: JOSEHeader
h = JOSEHeader :: Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader
JWT.JOSEHeader
{ typ :: Maybe Text
JWT.typ = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JWT"
, cty :: Maybe Text
JWT.cty = Maybe Text
forall a. Maybe a
Nothing
, alg :: Maybe Algorithm
JWT.alg = Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
JWT.RS256
, kid :: Maybe Text
JWT.kid = Maybe Text
forall a. Maybe a
Nothing
}
scope :: Text
scope :: Text
scope = Text
"https://www.googleapis.com/auth/gmail.send"
c :: JWTClaimsSet
c = JWTClaimsSet :: Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe IntDate
-> Maybe IntDate
-> Maybe IntDate
-> Maybe StringOrURI
-> ClaimsMap
-> JWTClaimsSet
JWT.JWTClaimsSet
{ iss :: Maybe StringOrURI
JWT.iss = Text -> Maybe StringOrURI
JWT.stringOrURI (Text -> Maybe StringOrURI) -> Text -> Maybe StringOrURI
forall a b. (a -> b) -> a -> b
$ MailAddress -> Text
mailAddressText (MailAddress -> Text) -> MailAddress -> Text
forall a b. (a -> b) -> a -> b
$ Key -> MailAddress
client_email Key
k
, sub :: Maybe StringOrURI
JWT.sub = Text -> Maybe StringOrURI
JWT.stringOrURI (Text -> Maybe StringOrURI) -> Text -> Maybe StringOrURI
forall a b. (a -> b) -> a -> b
$ MailAddress -> Text
mailAddressText MailAddress
sender
, aud :: Maybe (Either StringOrURI [StringOrURI])
JWT.aud = StringOrURI -> Either StringOrURI [StringOrURI]
forall a b. a -> Either a b
Left (StringOrURI -> Either StringOrURI [StringOrURI])
-> Maybe StringOrURI -> Maybe (Either StringOrURI [StringOrURI])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe StringOrURI
JWT.stringOrURI Text
"https://oauth2.googleapis.com/token"
, unregisteredClaims :: ClaimsMap
JWT.unregisteredClaims = Map Text Value -> ClaimsMap
JWT.ClaimsMap (Map Text Value -> ClaimsMap) -> Map Text Value -> ClaimsMap
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
"scope" (Value -> Map Text Value) -> Value -> Map Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
scope
, iat :: Maybe IntDate
JWT.iat = NominalDiffTime -> Maybe IntDate
JWT.numericDate NominalDiffTime
now
, exp :: Maybe IntDate
JWT.exp = NominalDiffTime -> Maybe IntDate
JWT.numericDate (NominalDiffTime -> Maybe IntDate)
-> NominalDiffTime -> Maybe IntDate
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
now NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3600
, nbf :: Maybe IntDate
JWT.nbf = Maybe IntDate
forall a. Maybe a
Nothing
, jti :: Maybe StringOrURI
JWT.jti = Maybe StringOrURI
forall a. Maybe a
Nothing
}
jwt :: Text
jwt = Signer -> JOSEHeader -> JWTClaimsSet -> Text
JWT.encodeSigned (PrivateKey -> Signer
JWT.RSAPrivateKey (PrivateKey -> Signer) -> PrivateKey -> Signer
forall a b. (a -> b) -> a -> b
$ Key -> PrivateKey
private_key Key
k) JOSEHeader
h JWTClaimsSet
c
body :: ByteString
body :: ByteString
body = Form -> ByteString
URLEncoded.urlEncodeForm (Form -> ByteString) -> Form -> ByteString
forall a b. (a -> b) -> a -> b
$ HashMap Text [Text] -> Form
URLEncoded.Form (HashMap Text [Text] -> Form) -> HashMap Text [Text] -> Form
forall a b. (a -> b) -> a -> b
$ [(Text, [Text])] -> HashMap Text [Text]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
[ (Text
"grant_type", [Text
"urn:ietf:params:oauth:grant-type:jwt-bearer"])
, (Text
"assertion", [Text
jwt])
]
req :: HTTP.Request
req :: Request
req = ByteString -> Request -> Request
HTTP.setRequestMethod ByteString
"POST"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Bool -> Request -> Request
HTTP.setRequestSecure Bool
True
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Int -> Request -> Request
HTTP.setRequestPort Int
443
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestHost ByteString
"oauth2.googleapis.com"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestPath ByteString
"/token"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"Content-Type" ByteString
"application/x-www-form-urlencoded"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestBodyLBS ByteString
body
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest
Response OAuth -> OAuth
forall a. Response a -> a
HTTP.getResponseBody (Response OAuth -> OAuth) -> IO (Response OAuth) -> IO OAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO (Response OAuth)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
HTTP.httpJSON Request
req
data OAuthWithTimestamp = OAuthWithTimestamp
{ OAuthWithTimestamp -> OAuth
oauth_value :: OAuth
, OAuthWithTimestamp -> NominalDiffTime
oauth_time :: POSIXTime
}
data Session = Session
{ Session -> Key
session_key :: Key
, Session -> MailAddress
session_sender :: MailAddress
, Session -> MVar OAuthWithTimestamp
session_oauth :: MVar OAuthWithTimestamp
}
newSession
:: Key
-> MailAddress
-> IO Session
newSession :: Key -> MailAddress -> IO Session
newSession Key
k MailAddress
sender = do
OAuth
oauth <- Key -> MailAddress -> IO OAuth
oauthQuery Key
k MailAddress
sender
NominalDiffTime
now <- IO NominalDiffTime
getPOSIXTime
let oauthw :: OAuthWithTimestamp
oauthw = OAuthWithTimestamp :: OAuth -> NominalDiffTime -> OAuthWithTimestamp
OAuthWithTimestamp
{ oauth_value :: OAuth
oauth_value = OAuth
oauth
, oauth_time :: NominalDiffTime
oauth_time = NominalDiffTime
now
}
Key -> MailAddress -> MVar OAuthWithTimestamp -> Session
Session Key
k MailAddress
sender (MVar OAuthWithTimestamp -> Session)
-> IO (MVar OAuthWithTimestamp) -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OAuthWithTimestamp -> IO (MVar OAuthWithTimestamp)
forall a. a -> IO (MVar a)
newMVar OAuthWithTimestamp
oauthw
withOAuth :: Session -> (OAuth -> IO a) -> IO a
withOAuth :: Session -> (OAuth -> IO a) -> IO a
withOAuth Session
session OAuth -> IO a
f = MVar OAuthWithTimestamp
-> (OAuthWithTimestamp -> IO (OAuthWithTimestamp, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Session -> MVar OAuthWithTimestamp
session_oauth Session
session) ((OAuthWithTimestamp -> IO (OAuthWithTimestamp, a)) -> IO a)
-> (OAuthWithTimestamp -> IO (OAuthWithTimestamp, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \OAuthWithTimestamp
oauthw -> do
let oauth :: OAuth
oauth = OAuthWithTimestamp -> OAuth
oauth_value OAuthWithTimestamp
oauthw
NominalDiffTime
now <- IO NominalDiffTime
getPOSIXTime
if NominalDiffTime
now NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
5 NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< OAuthWithTimestamp -> NominalDiffTime
oauth_time OAuthWithTimestamp
oauthw NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ OAuth -> NominalDiffTime
oauth_expires_in OAuth
oauth
then (,) OAuthWithTimestamp
oauthw (a -> (OAuthWithTimestamp, a))
-> IO a -> IO (OAuthWithTimestamp, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OAuth -> IO a
f OAuth
oauth
else do OAuth
oauth' <- Key -> MailAddress -> IO OAuth
oauthQuery (Session -> Key
session_key Session
session) (Session -> MailAddress
session_sender Session
session)
NominalDiffTime
now' <- IO NominalDiffTime
getPOSIXTime
let oauthw' :: OAuthWithTimestamp
oauthw' = OAuthWithTimestamp :: OAuth -> NominalDiffTime -> OAuthWithTimestamp
OAuthWithTimestamp
{ oauth_value :: OAuth
oauth_value = OAuth
oauth'
, oauth_time :: NominalDiffTime
oauth_time = NominalDiffTime
now'
}
(,) OAuthWithTimestamp
oauthw' (a -> (OAuthWithTimestamp, a))
-> IO a -> IO (OAuthWithTimestamp, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OAuth -> IO a
f OAuth
oauth'
renderMail :: forall a . ToMailBody a => MailAddress -> Mail a -> JSON.Value
renderMail :: MailAddress -> Mail a -> Value
renderMail MailAddress
sender Mail a
mail = Object -> Value
JSON.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Text
"raw" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value
JSON.String
(Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Text.replace Text
"+" Text
"-"
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Text.replace Text
"/" Text
"_"
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase64
(ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat
[ Text
"From: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mail a -> Text
forall a. Mail a -> Text
mail_sender Mail a
mail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MailAddress -> Text
mailAddressText MailAddress
sender Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">\r\n"
, Text
"To: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MailAddress -> Text
mailAddressText (Mail a -> MailAddress
forall a. Mail a -> MailAddress
mail_recipient Mail a
mail) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
, Text
"Subject: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mail a -> Text
forall a. Mail a -> Text
mail_subject Mail a
mail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
, Text
"Content-Type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 (MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
Media.renderHeader (MediaType -> ByteString) -> MediaType -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy a -> MediaType
forall a (proxy :: * -> *). ToMailBody a => proxy a -> MediaType
mailContentType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
, Text
"\r\n"
, a -> Text
forall a. ToMailBody a => a -> Text
toMailBody (a -> Text) -> a -> Text
forall a b. (a -> b) -> a -> b
$ Mail a -> a
forall a. Mail a -> a
mail_body Mail a
mail
]
data GMailException =
FailedToSend JSON.Value
| FailedToParseKey String
deriving Int -> GMailException -> ShowS
[GMailException] -> ShowS
GMailException -> String
(Int -> GMailException -> ShowS)
-> (GMailException -> String)
-> ([GMailException] -> ShowS)
-> Show GMailException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GMailException] -> ShowS
$cshowList :: [GMailException] -> ShowS
show :: GMailException -> String
$cshow :: GMailException -> String
showsPrec :: Int -> GMailException -> ShowS
$cshowsPrec :: Int -> GMailException -> ShowS
Show
instance Exception GMailException
sendMail :: ToMailBody a => Session -> Mail a -> IO ()
sendMail :: Session -> Mail a -> IO ()
sendMail Session
session Mail a
mail = Session -> (OAuth -> IO ()) -> IO ()
forall a. Session -> (OAuth -> IO a) -> IO a
withOAuth Session
session ((OAuth -> IO ()) -> IO ()) -> (OAuth -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \OAuth
oauth -> do
let mailReq :: HTTP.Request
mailReq :: Request
mailReq = ByteString -> Request -> Request
HTTP.setRequestMethod ByteString
"POST"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Bool -> Request -> Request
HTTP.setRequestSecure Bool
True
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Int -> Request -> Request
HTTP.setRequestPort Int
443
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestHost ByteString
"gmail.googleapis.com"
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestPath (ByteString
"/gmail/v1/users/me/messages/send")
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Query -> Request -> Request
HTTP.setRequestQueryString [(ByteString
"key",ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Key -> Text
private_key_id (Key -> Text) -> Key -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Key
session_key Session
session)]
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"Authorization" (ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (OAuth -> Text
oauth_access_token OAuth
oauth))
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Value -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
HTTP.setRequestBodyJSON (MailAddress -> Mail a -> Value
forall a. ToMailBody a => MailAddress -> Mail a -> Value
renderMail (Session -> MailAddress
session_sender Session
session) Mail a
mail)
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest
Response Value
resp <- Request -> IO (Response Value)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
HTTP.httpJSON Request
mailReq
let respCode :: Int
respCode = Response Value -> Int
forall a. Response a -> Int
HTTP.getResponseStatusCode Response Value
resp
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
respCode Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GMailException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (GMailException -> IO ()) -> GMailException -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> GMailException
FailedToSend (Value -> GMailException) -> Value -> GMailException
forall a b. (a -> b) -> a -> b
$ Response Value -> Value
forall a. Response a -> a
HTTP.getResponseBody Response Value
resp
class ToMailBody a where
toMailBody :: a -> Text
mailContentType :: proxy a -> MediaType
instance ToMailBody Text where
toMailBody :: Text -> Text
toMailBody = Text -> Text
forall a. a -> a
id
mailContentType :: proxy Text -> MediaType
mailContentType proxy Text
_ = ByteString
"text" ByteString -> ByteString -> MediaType
Media.// ByteString
"plain"
instance ToMailBody Html where
toMailBody :: Html -> Text
toMailBody = Text -> Text
LazyText.toStrict (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HTML.renderHtml
mailContentType :: proxy Html -> MediaType
mailContentType proxy Html
_ = ByteString
"text" ByteString -> ByteString -> MediaType
Media.// ByteString
"html"