{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Interactions with GMail made simple.
--
--   == Sending mails
--
--   For now, only mail sending is implemented.
--   Here's an example:
--
--   First we read the Google key file.
--
-- > do gkey <- readKeyFile "google-key.json"
--
--   Then we start a session. We provide the
--   mail address of the user that will send
--   the mail.
--
-- >    session <- newSession gkey "sender@example.com"
--
--   Here's the mail description.
--
-- >    let mail :: Mail Text
-- >        mail = Mail
-- >          { mail_sender = "Me"
-- >          , mail_recipient = "recipient@example.com"
-- >          , mail_subject = "Example mail"
-- >          , mail_body = "This is an example mail."
-- >            }
--
--   Finally, we simply send the mail.
--
-- >    sendMail session mail
--
--   That's it.
--
--   == Importing this library
--
--   I would recommend importing this module qualified. For example:
--
-- > import qualified Network.GMail.Simple as GMail
--
--
module Network.GMail.Simple
  ( -- * Key
    Key (..)
  , readKeyFile
    -- * Session
  , Session
  , newSession
    -- * Mail
  , MailAddress (..)
  , Mail (..)
  , sendMail
    -- * Mail body
  , ToMailBody (..)
    -- * Exceptions
  , 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

-- | A mail address as text.
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

-- | Mail datatype.
data Mail a = Mail
  { -- | Sender's alias.
    Mail a -> Text
mail_sender :: Text
    -- | The recipient of this mail.
  , Mail a -> MailAddress
mail_recipient :: MailAddress
    -- | The subject of this mail.
  , Mail a -> Text
mail_subject :: Text
    -- | Polymorphic mail body.
  , Mail a -> a
mail_body :: a
    }

-- | You can use `fmap` to map a function over the body of a mail.
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 }

-- | Google API Key from a service account. You can create one
--   inside your project in <https://console.cloud.google.com Google Cloud>.
--   Once you have it, you can download it to a file and read it using 'readKeyFile'.
data Key = Key
  { Key -> PrivateKey
private_key    :: PrivateKey
  , Key -> Text
private_key_id :: Text
  , Key -> MailAddress
client_email   :: MailAddress
    }

-- | Read the key file provided by Google Cloud.
--   It throws a 'FailedToParseKey' exception when
--   the file fails to parse.
--
--   If you don't want to read it from a local file,
--   you can use the `JSON.FromJSON` instance of `Key`
--   to read it. The function 'readKeyFile' is just a
--   wrapper around that.
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 -- ^ Google key
  -> MailAddress -- ^ Sender mail address
  -> IO OAuth
oauthQuery :: Key -> MailAddress -> IO OAuth
oauthQuery Key
k MailAddress
sender = do
  NominalDiffTime
now <- IO NominalDiffTime
getPOSIXTime
  let -- JWT Header
      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
              }
      -- Scoped required to send mails
      scope :: Text
      scope :: Text
scope = Text
"https://www.googleapis.com/auth/gmail.send"
      -- JWT Claims
      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
              }
      -- Signed JWT
      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
      -- HTTP request body
      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])
                 ]
      -- HTTP request
      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
    }

-- | A session that can be used to send mails.
--
--   * It may be reused.
--   * Multiple threads can use it simultaneously.
data Session = Session
  { Session -> Key
session_key :: Key
  , Session -> MailAddress
session_sender :: MailAddress
  , Session -> MVar OAuthWithTimestamp
session_oauth :: MVar OAuthWithTimestamp
    }

-- | Create a new session for the given sender.
newSession
  :: Key -- ^ Google API key
  -> MailAddress -- ^ Mail address of the sender
  -> 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
  -- We renew the token 5 seconds earlier
  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
          ]

-- | Exceptions thrown by functions in this library.
data GMailException =
    -- | A mail failed to be sent. The JSON value contains
    --   the error message as sent by Google.
    FailedToSend JSON.Value
    -- | A key file failed to parse. The string contains
    --   the parsing error.
  | 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

-- | Send mail using a session. It might throw a 'FailedToSend' exception.
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

-- ToMailBody class and instances

-- | Class of types that can be used as mail body.
class ToMailBody a where
  -- | Textual representation of the mail body.
  toMailBody :: a -> Text
  -- | Value for the @Content-Type@ header.
  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"