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