diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,26 @@ +MIT X11 license +=============== + +Copyright © 2014 [Miëtek Bak](https://mietek.io/). + +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.* + +Except as contained in this notice, the names of the above copyright holders +shall not be used in advertising or otherwise to promote the sale, use or +other dealings in the Software without prior written authorization. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +import Control.Applicative ((<$>)) +import Control.Exception (try) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=), ToJSON, toJSON) +import Data.Reflection (Given, give, given) +import Data.Text (Text) +import Network.Wai.Middleware.RequestLogger (logStdout) +import System.Environment (getEnv, getEnvironment) +import Web.Scotty (scotty) + +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Client.TLS as C +import qualified Network.HTTP.Types.Status as H +import qualified Web.Scotty as S + + +data Cfg = Cfg + { cfgMailChimpApiKey :: Text + , cfgMailChimpListId :: Text + , cfgWebsiteUrl :: Text + } + deriving (Show) + + +data SubRequest = SubRequest + { srName :: Text + , srEmailAddress :: Text + } + deriving (Show) + + +instance (Given Cfg) => ToJSON SubRequest where + toJSON request = J.object + [ "apikey" .= cfgMailChimpApiKey given + , "id" .= cfgMailChimpListId given + , "merge_vars" .= J.object ["name" .= srName request] + , "email" .= J.object ["email" .= srEmailAddress request] + , "update_existing" .= True + , "double_optin" .= True + , "send_welcome" .= False + ] + + +accept :: S.ActionM () +accept = do + S.html "

202 Accepted

" + S.status H.accepted202 + + +rejectNotAcceptable :: S.ActionM () +rejectNotAcceptable = do + S.html "

406 Not Acceptable

" + S.status H.notAcceptable406 + + +rejectBadRequest :: S.ActionM () +rejectBadRequest = do + S.html "

400 Bad Request

" + S.status H.badRequest400 + + +redirectToWebsite :: (Given Cfg) => S.ActionM () +redirectToWebsite = + S.redirect $ LT.fromStrict $ cfgWebsiteUrl given + + +subscribeToList :: (Given Cfg) => S.ActionM () +subscribeToList = do + name <- S.param "name" + emailAddress <- S.param "email-address" + didSub <- liftIO $ postSubRequest $ SubRequest name emailAddress + case didSub of + True -> accept + False -> rejectNotAcceptable + + +postSubRequest :: (Given Cfg) => SubRequest -> IO Bool +postSubRequest request = do + manager <- C.newManager C.tlsManagerSettings + endpoint <- C.parseUrl "https://us3.api.mailchimp.com/2.0/lists/subscribe" + let post = endpoint + { C.method = "POST" + , C.requestBody = C.RequestBodyLBS $ J.encode request + } + response :: Either C.HttpException () <- try $ + C.withResponse post manager $ const $ return () + case response of + Right _ -> return True + Left failure -> do + putStrLn $ " *** WARNING: Request failed: " ++ show failure + return False + + +main :: IO () +main = do + mailChimpApiKey <- T.pack <$> getEnv "MAILCHIMP_API_KEY" + mailChimpListId <- T.pack <$> getEnv "MAILCHIMP_LIST_ID" + websiteUrl <- T.pack <$> getEnv "WEBSITE_URL" + let cfg = Cfg + { cfgMailChimpApiKey = mailChimpApiKey + , cfgMailChimpListId = mailChimpListId + , cfgWebsiteUrl = websiteUrl + } + env <- getEnvironment + let port = maybe 8080 read $ lookup "PORT" env + give cfg $ scotty port $ do + S.middleware logStdout + S.get "/" redirectToWebsite + S.post "/subscribe" subscribeToList + S.notFound rejectBadRequest diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +_mailchimp-subscribe_ +===================== + +[MailChimp](http://mailchimp.com/) subscription request handler, built with [Scotty](https://github.com/scotty-web/scotty/). Intended to support custom signup forms. + + +Usage +----- + +### Deploying with [Halcyon](https://halcyon.sh/) + +``` +$ halcyon deploy https://github.com/mietek/mailchimp-subscribe +$ export MAILCHIMP_API_KEY=... +$ export MAILCHIMP_LIST_ID=... +$ export WEBSITE_URL=... +$ PORT=8080 mailchimp-subscribe +``` + + +### Deploying with [Haskell on Heroku](https://haskellonheroku.com/) + +[![Deploy](https://www.herokucdn.com/deploy/button.png)](https://heroku.com/deploy?template=https://github.com/mietek/mailchimp-subscribe/) + + +About +----- + +Made by [Miëtek Bak](https://mietek.io/). Published under the [MIT X11 license](https://mietek.io/license/). 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/mailchimp-subscribe.cabal b/mailchimp-subscribe.cabal new file mode 100644 --- /dev/null +++ b/mailchimp-subscribe.cabal @@ -0,0 +1,30 @@ +name: mailchimp-subscribe +version: 1.0 +build-type: Simple +cabal-version: >= 1.20 +license: MIT +copyright: Copyright © 2014 Miëtek Bak +author: Miëtek Bak +maintainer: Miëtek Bak +stability: experimental +homepage: https://github.com/mietek/mailchimp-subscribe/ +license-file: LICENSE.md +extra-source-files: README.md +category: Mail +synopsis: MailChimp subscription request handler +description: subscription request handler, built with . Intended to support custom signup forms. + +executable mailchimp-subscribe + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -O2 -Wall -threaded + build-depends: base >= 4 && < 5, + aeson < 0.9, + http-client < 0.5, + http-client-tls < 0.3, + http-types < 0.9, + reflection < 1.6, + scotty < 0.10, + text < 1.3, + transformers < 0.5, + wai-extra < 3.1