summaryrefslogtreecommitdiff
path: root/src/Rackspace/MailGun.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rackspace/MailGun.hs')
-rw-r--r--src/Rackspace/MailGun.hs80
1 files changed, 80 insertions, 0 deletions
diff --git a/src/Rackspace/MailGun.hs b/src/Rackspace/MailGun.hs
new file mode 100644
index 0000000..fda50ba
--- /dev/null
+++ b/src/Rackspace/MailGun.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Rackspace.MailGun
+ ( Message (..)
+ , sendMessage
+ , sendWith
+ ) where
+
+import Control.Failure
+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, 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, 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