diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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