mailchimp-subscribe (empty) → 1.0

raw patch · 5 files changed

+205/−0 lines, 5 filesdep +aesondep +basedep +http-clientsetup-changed

Dependencies added: aeson, base, http-client, http-client-tls, http-types, reflection, scotty, text, transformers, wai-extra

Files

LICENSE.md +26/−0
Main.hs +118/−0
README.md +29/−0
Setup.hs +2/−0
mailchimp-subscribe.cabal +30/−0

+ LICENSE.md view

@@ -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.

+ Main.hs view

@@ -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 "<h1>202 Accepted</h1>"+    S.status H.accepted202+++rejectNotAcceptable :: S.ActionM ()+rejectNotAcceptable = do+    S.html "<h1>406 Not Acceptable</h1>"+    S.status H.notAcceptable406+++rejectBadRequest :: S.ActionM ()+rejectBadRequest = do+    S.html "<h1>400 Bad Request</h1>"+    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

+ README.md view

@@ -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/).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <hello@mietek.io>+maintainer:         Miëtek Bak <hello@mietek.io>+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:        <http://mailchimp.com/ MailChimp> subscription request handler, built with <https://github.com/scotty-web/scotty/ Scotty>.  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