version 0.1.0.00.1.0.0

6 files changed, 205 insertions, 0 deletions

diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f6a8157
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2014 Andrew Rademacher
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/mailgun.cabal b/mailgun.cabal
new file mode 100644
index 0000000..a7cbdf1
--- /dev/null
+++ b/mailgun.cabal
@@ -0,0 +1,48 @@
+name:                mailgun
+version:             0.1.0.0
+synopsis:            Connector to Rackspace's Mailgun Service
+description:         Allows users to directly access Rackspace's Mailgun service
+                     without having to work with the underlying REST service.
+license:             MIT
+license-file:        LICENSE
+author:              Andrew Rademacher
+maintainer:          andrewrademacher@gmail.com
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+    exposed-modules:    Rackspace.MailGun 
+    -- other-modules:       
+    -- other-extensions:    
+    hs-source-dirs:     src      
+    default-language:   Haskell2010
+    build-depends:      base >=4.6 && <4.7
+                    ,   text >=1.1.0.1
+                    ,   conduit >=1.0.17.1
+                    ,   http-conduit >=2.0.0.8
+                    ,   bytestring >=0.10.0.2
+                    ,   network >=2.4.2.2
+                    ,   http-client-multipart >=0.2.0.0
+                    ,   transformers >=0.3.0.0
+                    ,   monad-control >=0.3.2.3
+                    ,   http-client >=0.2.2.4
+                    ,   failure >=0.2.0.2
+
+executable send
+    main-is:            Send.hs
+    hs-source-dirs:     test
+    default-language:   Haskell2010
+    build-depends:      base >=4.6 && <4.7
+                    ,   text >=1.1.0.1
+                    ,   mailgun
+
+executable sendmany
+    main-is:            SendMany.hs
+    hs-source-dirs:     test
+    default-language:   Haskell2010
+    build-depends:      base >=4.6 && <4.7
+                    ,   text >=1.1.0.1
+                    ,   http-conduit >=2.0.0.8
+                    ,   transformers >=0.3.0.0
+                    ,   mailgun
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
diff --git a/test/Send.hs b/test/Send.hs
new file mode 100644
index 0000000..94b47e8
--- /dev/null
+++ b/test/Send.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Data.Text          as T (Text (..), pack)
+import           Rackspace.MailGun
+import           System.Environment
+
+main :: IO ()
+main = do
+        domain <- getEnv "MAILGUN_DOMAIN"
+        apiKey <- getEnv "MAILGUN_SECRET"
+        testAddr <- getEnv "MAILGUN_TEST_ADDRESS"
+
+        let message = TextMessage
+                    { from = T.pack ("someone@" ++ domain)
+                    , to = T.pack testAddr
+                    , cc = Nothing
+                    , bcc = Nothing
+                    , subject = Just "Test Message"
+                    , text = "Hello, this is a test message!" }
+        res <- sendMessage domain apiKey message
+        print res
diff --git a/test/SendMany.hs b/test/SendMany.hs
new file mode 100644
index 0000000..6ae9adc
--- /dev/null
+++ b/test/SendMany.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Control.Monad.IO.Class
+import           Data.Text              as T (Text (..), pack)
+import           Network.HTTP.Conduit
+import           Rackspace.MailGun
+import           System.Environment
+
+main :: IO ()
+main = do
+        domain <- getEnv "MAILGUN_DOMAIN"
+        apiKey <- getEnv "MAILGUN_SECRET"
+        testAddr <- getEnv "MAILGUN_TEST_ADDRESS"
+
+        let message = TextMessage
+                    { from = T.pack ("someone@" ++ domain)
+                    , to = T.pack testAddr
+                    , cc = Nothing
+                    , bcc = Nothing
+                    , subject = Just "Test Message"
+                    , text = "Hello, this is a test message!" }
+        withManager $ \manager -> do
+                let sendW = sendWith manager
+                res1 <- sendW domain apiKey message
+                res2 <- sendW domain apiKey message
+                res3 <- sendW domain apiKey message
+                liftIO $ print res1
+                liftIO $ print res2
+                liftIO $ print res3