summaryrefslogtreecommitdiff
path: root/src/Rackspace/MailGun.hs
blob: 17e7d8a96bbef8190b00d5f3f8ca9d40ca7ac85a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}

module Rackspace.MailGun
    ( Message (..)
    , sendMessage
    , sendWith
    ) where

import           Control.Failure
import           Control.Monad.Catch                   as C (MonadThrow)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Control
import           Data.ByteString.Char8                 as BS (ByteString, pack,
                                                              putStrLn)
import qualified Data.ByteString.Lazy.Char8            as LBS (ByteString)
import           Data.Conduit
import qualified Data.Conduit.List                     as CL
import           Data.Text                             as T (Text, concat, pack)
import           Data.Text.Encoding                    (encodeUtf8)
import           Network                               (withSocketsDo)
import           Network.HTTP.Client.MultipartFormData
import           Network.HTTP.Conduit

baseUrl :: String
baseUrl = "https://api.mailgun.net/v2"

data Message = TextMessage
                { from    :: Text
                , to      :: Text
                , cc      :: Maybe Text
                , bcc     :: Maybe Text
                , subject :: Maybe Text
                , text    :: Text }
             | HtmlMessage
                { from    :: Text
                , to      :: Text
                , cc      :: Maybe Text
                , bcc     :: Maybe Text
                , subject :: Maybe Text
                , html    :: Text }
             deriving (Eq, Show)

partText :: Text -> Text -> [Part]
partText name value = [ partBS name (encodeUtf8 value) ]

partMaybeText :: Text -> Maybe Text -> [Part]
partMaybeText name value = case value of
                            Just val    -> [ partBS name (encodeUtf8 val) ]
                            Nothing     -> []

buildTail :: Message -> [Part]
buildTail TextMessage{..} = partText "text" text
buildTail HtmlMessage{..} = partText "html" html

buildBase :: Message -> [Part]
buildBase msg = partText "from" (from msg)
             ++ partText "to" (to msg)
             ++ partMaybeText "cc" (cc msg)
             ++ partMaybeText "bcc" (bcc msg)
             ++ partMaybeText "subject" (subject msg)
             ++ buildTail msg

sendMessage :: (Failure HttpException m, C.MonadThrow m, MonadBaseControl IO m, MonadIO m) =>
                String -> String -> Message -> m (Response LBS.ByteString)
sendMessage domain apiKey message = do
        withManager $ \manager -> do
            sendWith manager domain apiKey message

sendWith :: (Failure HttpException m, C.MonadThrow m, MonadBaseControl IO m, MonadIO m) =>
                Manager -> String -> String -> Message -> m (Response LBS.ByteString)
sendWith manager domain apiKey message = do
        initReq <- parseUrl $ baseUrl ++ "/" ++ domain ++ "/messages"
        let authReq = applyBasicAuth "api" (BS.pack apiKey) initReq
            postReq = authReq { method = "POST" }
        res <- flip httpLbs manager =<<
            (formDataBody (buildBase message) postReq)
        return res