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

-- | 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

-- TODO: Better organize the import list
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
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | Mail datatype.
data Mail a = Mail
  { -- | Sender's alias.
    forall a. Mail a -> Text
mail_sender :: Text
    -- | The recipient of this mail.
  , forall a. Mail a -> MailAddress
mail_recipient :: MailAddress
    -- | The subject of this mail.
  , forall a. Mail a -> Text
mail_subject :: Text
    -- | Polymorphic mail body.
  , forall a. 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 :: forall a b. (a -> b) -> Mail a -> Mail b
fmap a -> b
f Mail a
mail = Mail a
mail { mail_body :: b
mail_body = a -> b
f forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GMailException
FailedToParseKey) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode

instance JSON.FromJSON Key where
  parseJSON :: Value -> Parser Key
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"Key" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
pkt <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"private_key"
    case ByteString -> Maybe PrivateKey
JWT.readRsaSecret forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
pkt of
      Just PrivateKey
pk -> PrivateKey -> Text -> MailAddress -> Key
Key
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure PrivateKey
pk
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"private_key_id"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> MailAddress
MailAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"client_email")
      Maybe PrivateKey
_ -> 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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"OAuth" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> NominalDiffTime -> OAuth
OAuth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"access_token" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"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 = JWT.JOSEHeader
            { typ :: Maybe Text
JWT.typ = forall a. a -> Maybe a
Just Text
"JWT"
            , cty :: Maybe Text
JWT.cty = forall a. Maybe a
Nothing
            , alg :: Maybe Algorithm
JWT.alg = forall a. a -> Maybe a
Just Algorithm
JWT.RS256
            , kid :: Maybe Text
JWT.kid = 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 = JWT.JWTClaimsSet
            { iss :: Maybe StringOrURI
JWT.iss = Text -> Maybe StringOrURI
JWT.stringOrURI forall a b. (a -> b) -> a -> b
$ MailAddress -> Text
mailAddressText forall a b. (a -> b) -> a -> b
$ Key -> MailAddress
client_email Key
k
            , sub :: Maybe StringOrURI
JWT.sub = Text -> Maybe StringOrURI
JWT.stringOrURI forall a b. (a -> b) -> a -> b
$ MailAddress -> Text
mailAddressText MailAddress
sender
            , aud :: Maybe (Either StringOrURI [StringOrURI])
JWT.aud = forall a b. a -> Either a b
Left 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 forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
"scope" forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ NominalDiffTime
now forall a. Num a => a -> a -> a
+ NominalDiffTime
3600
            , nbf :: Maybe IntDate
JWT.nbf = forall a. Maybe a
Nothing
            , jti :: Maybe StringOrURI
JWT.jti = forall a. Maybe a
Nothing
              }
      -- Signed JWT
#if MIN_VERSION_jwt(0,11,0)
      jwt :: Text
jwt = EncodeSigner -> JOSEHeader -> JWTClaimsSet -> Text
JWT.encodeSigned (PrivateKey -> EncodeSigner
JWT.EncodeRSAPrivateKey forall a b. (a -> b) -> a -> b
$ Key -> PrivateKey
private_key Key
k) JOSEHeader
h JWTClaimsSet
c
#else
      jwt = JWT.encodeSigned (JWT.RSAPrivateKey $ private_key k) h c
#endif
      -- HTTP request body
      body :: ByteString
      body :: ByteString
body = Form -> ByteString
URLEncoded.urlEncodeForm forall a b. (a -> b) -> a -> b
$ HashMap Text [Text] -> Form
URLEncoded.Form forall a b. (a -> b) -> a -> b
$ 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"
          forall a b. (a -> b) -> a -> b
$ Bool -> Request -> Request
HTTP.setRequestSecure Bool
True
          forall a b. (a -> b) -> a -> b
$ Int -> Request -> Request
HTTP.setRequestPort Int
443
          forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestHost ByteString
"oauth2.googleapis.com"
          forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestPath ByteString
"/token"
          forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"Content-Type" ByteString
"application/x-www-form-urlencoded"
          forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestBodyLBS ByteString
body
          forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest
  forall a. Response a -> a
HTTP.getResponseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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_value :: OAuth
oauth_value = OAuth
oauth
        , oauth_time :: NominalDiffTime
oauth_time = NominalDiffTime
now
          }
  Key -> MailAddress -> MVar OAuthWithTimestamp -> Session
Session Key
k MailAddress
sender forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar OAuthWithTimestamp
oauthw

withOAuth :: Session -> (OAuth -> IO a) -> IO a
withOAuth :: forall a. Session -> (OAuth -> IO a) -> IO a
withOAuth Session
session OAuth -> IO a
f = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Session -> MVar OAuthWithTimestamp
session_oauth Session
session) 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 forall a. Num a => a -> a -> a
+ NominalDiffTime
5 forall a. Ord a => a -> a -> Bool
< OAuthWithTimestamp -> NominalDiffTime
oauth_time OAuthWithTimestamp
oauthw forall a. Num a => a -> a -> a
+ OAuth -> NominalDiffTime
oauth_expires_in OAuth
oauth
     then (,) OAuthWithTimestamp
oauthw 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_value :: OAuth
oauth_value = OAuth
oauth'
                   , oauth_time :: NominalDiffTime
oauth_time = NominalDiffTime
now'
                     }
             (,) OAuthWithTimestamp
oauthw' 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
#if MIN_VERSION_aeson(2,0,0)
renderMail :: forall a. ToMailBody a => MailAddress -> Mail a -> Value
renderMail MailAddress
sender Mail a
mail = Object -> Value
JSON.Object forall a b. (a -> b) -> a -> b
$ forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"raw" forall a b. (a -> b) -> a -> b
$ Text -> Value
JSON.String
#else
renderMail sender mail = JSON.Object $ HashMap.singleton "raw" $ JSON.String
#endif
    forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Text.replace Text
"+" Text
"-"
    forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Text.replace Text
"/" Text
"_"
    forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase64
    forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat
        [ Text
"From: " forall a. Semigroup a => a -> a -> a
<> forall a. Mail a -> Text
mail_sender Mail a
mail forall a. Semigroup a => a -> a -> a
<> Text
" <" forall a. Semigroup a => a -> a -> a
<> MailAddress -> Text
mailAddressText MailAddress
sender forall a. Semigroup a => a -> a -> a
<> Text
">\r\n"
        , Text
"To: " forall a. Semigroup a => a -> a -> a
<> MailAddress -> Text
mailAddressText (forall a. Mail a -> MailAddress
mail_recipient Mail a
mail) forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
        , Text
"Subject: " forall a. Semigroup a => a -> a -> a
<> forall a. Mail a -> Text
mail_subject Mail a
mail forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
        , Text
"Content-Type: " forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 (forall h. RenderHeader h => h -> ByteString
Media.renderHeader forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *). ToMailBody a => proxy a -> MediaType
mailContentType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. Semigroup a => a -> a -> a
<> Text
"\r\n"
        , Text
"\r\n"
        , forall a. ToMailBody a => a -> Text
toMailBody forall a b. (a -> b) -> a -> b
$ 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
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.
--
--   In order for this to work, the user must have permissions for the @https://www.googleapis.com/auth/gmail.send@ scope.
sendMail :: ToMailBody a => Session -> Mail a -> IO ()
sendMail :: forall a. ToMailBody a => Session -> Mail a -> IO ()
sendMail Session
session Mail a
mail = forall a. Session -> (OAuth -> IO a) -> IO a
withOAuth Session
session forall a b. (a -> b) -> a -> b
$ \OAuth
oauth -> do
  let mailReq :: HTTP.Request
      mailReq :: Request
mailReq = ByteString -> Request -> Request
HTTP.setRequestMethod ByteString
"POST"
              forall a b. (a -> b) -> a -> b
$ Bool -> Request -> Request
HTTP.setRequestSecure Bool
True
              forall a b. (a -> b) -> a -> b
$ Int -> Request -> Request
HTTP.setRequestPort Int
443
              forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestHost ByteString
"gmail.googleapis.com"
              forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestPath (ByteString
"/gmail/v1/users/me/messages/send")
              forall a b. (a -> b) -> a -> b
$ Query -> Request -> Request
HTTP.setRequestQueryString [(ByteString
"key",forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Key -> Text
private_key_id forall a b. (a -> b) -> a -> b
$ Session -> Key
session_key Session
session)]
              forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"Authorization" (ByteString
"Bearer " forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (OAuth -> Text
oauth_access_token OAuth
oauth))
              forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Request -> Request
HTTP.setRequestBodyJSON (forall a. ToMailBody a => MailAddress -> Mail a -> Value
renderMail (Session -> MailAddress
session_sender Session
session) Mail a
mail)
              forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest
  Response Value
resp <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
HTTP.httpJSON Request
mailReq
  let respCode :: Int
respCode = forall a. Response a -> Int
HTTP.getResponseStatusCode Response Value
resp
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Integral a => a -> a -> a
div Int
respCode Int
100 forall a. Eq a => a -> a -> Bool
== Int
2) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Value -> GMailException
FailedToSend forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> a
id
  mailContentType :: forall (proxy :: * -> *). 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HTML.renderHtml
  mailContentType :: forall (proxy :: * -> *). proxy Html -> MediaType
mailContentType proxy Html
_ = ByteString
"text" ByteString -> ByteString -> MediaType
Media.// ByteString
"html"