diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2016 Juan Pedro Villa Isaza + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# Haskell bindings for the MailChimp API + +[![][1]][0] + +[0]: https://travis-ci.org/jpvillaisaza/mailchimp-haskell +[1]: https://travis-ci.org/jpvillaisaza/mailchimp-haskell.svg?branch=master + +![][2] +![][3] + +[2]: https://www.stackage.org/package/mailchimp/badge/lts +[3]: https://www.stackage.org/package/mailchimp/badge/nightly + +## License + +Licensed under the MIT license. See [LICENSE.md](LICENSE.md). + +[mailchimp]: http://mailchimp.com/ +[mailchimp-api]: http://developer.mailchimp.com/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/mailchimp.cabal b/mailchimp.cabal new file mode 100644 --- /dev/null +++ b/mailchimp.cabal @@ -0,0 +1,61 @@ +name: mailchimp +version: 0.1.0 + +build-type: Simple +cabal-version: >= 1.21 + +license: MIT +license-file: LICENSE.md + +copyright: 2016 Juan Pedro Villa Isaza +author: Juan Pedro Villa Isaza +maintainer: Juan Pedro Villa Isaza + +stability: Experimental + +homepage: https://github.com/jpvillaisaza/mailchimp-haskell +bug-reports: https://github.com/jpvillaisaza/mailchimp-haskell/issues + +synopsis: Bindings for the MailChimp API +description: Haskell bindings for the MailChimp API. + +category: Web + +tested-with: GHC == 7.10.3 + +extra-source-files: README.md + + +library + hs-source-dirs: + src + exposed-modules: + Web.MailChimp + Web.MailChimp.Tutorial + other-modules: + Paths_mailchimp + Web.MailChimp.Common + Web.MailChimp.Extra + Web.MailChimp.Key + Web.MailChimp.List + Web.MailChimp.List.Member + build-depends: + aeson >= 0.11 && < 0.12 + , attoparsec >= 0.13 && < 0.14 + , base >= 4.8 && < 4.10 + , bytestring + , http-client >= 0.4 && < 0.5 + , http-client-tls >= 0.2 && < 0.3 + , servant >= 0.7 && < 0.8 + , servant-client >= 0.7 && < 0.8 + , text >= 1.2 && < 1.3 + , transformers + default-language: + Haskell2010 + ghc-options: + -Wall + + +source-repository head + type: git + location: https://github.com/jpvillaisaza/mailchimp-haskell diff --git a/src/Web/MailChimp.hs b/src/Web/MailChimp.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp + ( Key + , Client(..) + , makeClient + , ListClient(..) + , ListId + , ListMemberClient(..) + , makeListMemberClient + , ListMemberRequest(..) + , makeListMemberRequest + , ListMemberResponse(..) + , ListMemberId + , ListMemberStatus(..) + , Id + , Paths_mailchimp.version + , makeManager + ) + where + +-- aeson +import Data.Aeson + +-- base +import Data.Proxy (Proxy (Proxy)) +import Data.Void (Void) + +-- bytestring +import Data.ByteString.Char8 (unpack) + +-- http-client +import Network.HTTP.Client (Manager) + +-- mailchimp +import qualified Paths_mailchimp +import Web.MailChimp.Common +import Web.MailChimp.Extra +import Web.MailChimp.Key +import Web.MailChimp.List +import Web.MailChimp.List.Member + +-- servant +import Servant.API + +-- servant-client +import Servant.Client hiding (Client) +import qualified Servant.Client as Servant + +-- transformers +import Control.Monad.IO.Class +import Control.Monad.Trans.Except (ExceptT, runExceptT) + + +-- | +-- +-- The MailChimp API, version 3.0. + +type Api = + "3.0" + :> BasicAuth "" Void + :> (Get '[JSON] Object :<|> ListApi) + + +-- | +-- +-- A client for MailChimp. + +data Client = + Client + { -- | + -- + -- + + getLinks + :: forall m . MonadIO m + => m (Either ServantError Object) + + -- | + -- + -- Create a client for a list. + + , makeListClient + :: ListId + -> ListClient + + } + + +-- | +-- +-- Create a client for MailChimp. + +makeClient + :: Manager -- ^ A manager + -> Key -- ^ A key + -> Maybe Client -- ^ The client +makeClient manager key = + case makeBaseUrl key of + Nothing -> + Nothing + + Just baseUrl -> + let + makeGetLinks :<|> client' = client (Proxy :: Proxy Api) basicAuthData + + getLinks :: MonadIO m => m (Either ServantError Object) + getLinks = run (makeGetLinks manager baseUrl) + + makeListClient = makeListClient' manager baseUrl client' + + basicAuthData = BasicAuthData "" key + in + Just Client {..} + + +-- | +-- +-- + +makeListClient' + :: Manager + -> BaseUrl + -> Servant.Client ListApi + -> ListId + -> ListClient +makeListClient' manager baseUrl client' listId = + let + listMemberClient = + makeListMemberClient' manager baseUrl (client' listId) + in + ListClient {..} + + +-- | +-- +-- + +makeListMemberClient' + :: Manager + -> BaseUrl + -> Servant.Client ListMemberApi + -> ListMemberClient +makeListMemberClient' manager baseUrl listClient = + let + makeAddListMember + :<|> md + :<|> md2 + :<|> md3 + :<|> md4 + :<|> makeDeleteListMember = listClient + + addListMember lm = run (makeAddListMember lm manager baseUrl) + + getListMembers :: MonadIO m => m (Either ServantError [ListMemberResponse]) + getListMembers = run (md manager baseUrl) + + getListMember s = run (md2 s manager baseUrl) + + updateListMember s lm = run (md3 s lm manager baseUrl) + + addOrUpdateListMember s lm = run (md4 s lm manager baseUrl) + + deleteListMember s = run (makeDeleteListMember s manager baseUrl) + in + ListMemberClient {..} + + +-- | +-- +-- + +run + :: MonadIO m + => ExceptT e IO a + -> m (Either e a) +run = + liftIO . runExceptT + + +-- | +-- +-- Create a client for a list members. + +makeListMemberClient + :: Manager + -> Key + -> ListId + -> Maybe ListMemberClient +makeListMemberClient manager key listId = + listMemberClient . (`makeListClient` listId) + <$> makeClient manager key + + +-- | +-- +-- + +makeBaseUrl + :: Key + -> Maybe BaseUrl +makeBaseUrl key = + case fmap unpack (parseDataCenter key) of + Left _ -> + Nothing + + Right dataCenter -> + Just $ + BaseUrl + Https + (mappend dataCenter ".api.mailchimp.com") + 443 + "" diff --git a/src/Web/MailChimp/Common.hs b/src/Web/MailChimp/Common.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/Common.hs @@ -0,0 +1,24 @@ +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.Common +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.Common + ( Id + ) + where + +-- text +import Data.Text (Text) + + +-- | +-- +-- An ID. + +type Id = + Text diff --git a/src/Web/MailChimp/Extra.hs b/src/Web/MailChimp/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/Extra.hs @@ -0,0 +1,28 @@ +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.Extra +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.Extra + ( makeManager + ) + where + +-- http-client +import Network.HTTP.Client (Manager, newManager) + +-- http-client-tls +import Network.HTTP.Client.TLS (tlsManagerSettings) + + +-- | +-- +-- Create a manager. + +makeManager :: IO Manager +makeManager = + newManager tlsManagerSettings diff --git a/src/Web/MailChimp/Key.hs b/src/Web/MailChimp/Key.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/Key.hs @@ -0,0 +1,58 @@ +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.Key +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.Key + ( DataCenter + , Key + , parseDataCenter + ) + where + +-- attoparsec +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 (anyChar, char) + +-- bytestring +import Data.ByteString.Char8 + + +-- | +-- +-- A MailChimp data center. + +type DataCenter = + ByteString + + +-- | +-- +-- A MailChimp API key. + +type Key = + ByteString + + +-- | +-- +-- + +parseDataCenter + :: Key + -> Either String DataCenter +parseDataCenter = + parseOnly dataCenterParser + + +-- | +-- +-- + +dataCenterParser :: Parser DataCenter +dataCenterParser = + manyTill anyChar (char '-') *> fmap pack (many1 anyChar) diff --git a/src/Web/MailChimp/List.hs b/src/Web/MailChimp/List.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/List.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.List +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.List + ( ListApi + , ListClient(..) + , ListId + ) + where + +-- mailchimp +import Web.MailChimp.Common +import Web.MailChimp.List.Member + +-- servant +import Servant.API + + +-- | +-- +-- A list ID. + +type ListId = + Id + + +-- | +-- +-- + +type ListApi = + "lists" + :> Capture "list_id" ListId + :> "members" + :> ListMemberApi + + +-- | +-- +-- A client for a list. + +data ListClient = + ListClient + { -- | + -- + -- + + listMemberClient :: ListMemberClient + + } diff --git a/src/Web/MailChimp/List/Member.hs b/src/Web/MailChimp/List/Member.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/List/Member.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.List.Member +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.List.Member + ( ListMemberApi + , ListMemberClient(..) + , ListMemberRequest(..) + , makeListMemberRequest + , ListMemberResponse(..) + , ListMemberId + , ListMemberStatus(..) + ) + where + +-- aeson +import Data.Aeson +import qualified Data.Aeson as Aeson + +-- mailchimp +import Web.MailChimp.Common + +-- servant +import Servant.API + +-- servant-client +import Servant.Client + +-- text +import Data.Text (Text) + +-- transformers +import Control.Monad.IO.Class (MonadIO) + + +type ListMemberId = + Id + +-- | +-- +-- + +type ListMemberApi = + ReqBody '[JSON] ListMemberRequest + :> Post '[JSON] ListMemberResponse + + :<|> Get '[JSON] [ListMemberResponse] + + :<|> Capture "subscriber_hash" ListMemberId + :> Get '[JSON] ListMemberResponse + + :<|> Capture "subscriber_hash" ListMemberId + :> ReqBody '[JSON] ListMemberRequest + :> Patch '[JSON] ListMemberResponse + + :<|> Capture "subscriber_hash" ListMemberId + :> ReqBody '[JSON] ListMemberRequest + :> Put '[JSON] ListMemberResponse + + + :<|> Capture "subscriber_hash" ListMemberId + :> Delete '[JSON] String + + +-- | +-- +-- + +data ListMemberClient = + ListMemberClient + { -- | + -- + -- Add a new list member. + + addListMember + :: forall m . MonadIO m + => ListMemberRequest + -> m (Either ServantError ListMemberResponse) + + -- | + -- + -- Get information about members in a list. + + , getListMembers + :: forall m . MonadIO m + => m (Either ServantError [ListMemberResponse]) + + -- | + -- + -- Get information about a specific list member. + + , getListMember + :: forall m . MonadIO m + => ListMemberId + -> m (Either ServantError ListMemberResponse) + + -- | + -- + -- Update a list member. + + , updateListMember + :: forall m . MonadIO m + => ListMemberId + -> ListMemberRequest + -> m (Either ServantError ListMemberResponse) + + -- | + -- + -- Add or update a list member. + + , addOrUpdateListMember + :: forall m . MonadIO m + => ListMemberId + -> ListMemberRequest + -> m (Either ServantError ListMemberResponse) + + -- | + -- + -- Remove a list member. + + , deleteListMember + :: forall m . MonadIO m + => ListMemberId + -> m (Either ServantError String) + + } + + +-- | +-- +-- + +data ListMemberRequest = + ListMemberRequest + { listMemberEmailAddress :: Text + , listMemberMergeFields :: [(Text, Text)] + , listMemberStatus :: ListMemberStatus + , listMemberExtra :: [(Text, Aeson.Value)] + } + deriving (Show) + + +-- | +-- +-- Create a list member request. + +makeListMemberRequest + :: Text -- ^ Email + -> ListMemberStatus + -> ListMemberRequest +makeListMemberRequest emailAddress status = + ListMemberRequest + { listMemberEmailAddress = emailAddress + , listMemberMergeFields = mempty + , listMemberStatus = status + , listMemberExtra = mempty + } + + +-- | +-- +-- + +instance ToJSON ListMemberRequest where + toJSON ListMemberRequest {..} = + Aeson.object $ + "email_address" .= listMemberEmailAddress + : mergeFields + : "status" .= listMemberStatus + : listMemberExtra + where + mergeFields = + ( "merge_fields" + , Aeson.object (fmap (fmap toJSON) listMemberMergeFields) + ) + + +-- | +-- +-- + +data ListMemberResponse = + ListMemberResponse + { listMemberId :: ListMemberId + } + deriving (Show) + + +-- | +-- +-- + +instance FromJSON ListMemberResponse where + parseJSON = + Aeson.withObject "" $ + \o -> + ListMemberResponse + <$> o .: "id" + + +-- | +-- +-- + +data ListMemberStatus + = Cleaned + | Pending + | Subscribed + | Unsubscribed + deriving (Show) + + +-- | +-- +-- + +instance ToJSON ListMemberStatus where + toJSON Cleaned = "cleaned" + toJSON Pending = "pending" + toJSON Subscribed = "subscribed" + toJSON Unsubscribed = "unsubscribed" diff --git a/src/Web/MailChimp/Tutorial.hs b/src/Web/MailChimp/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Web/MailChimp/Tutorial.hs @@ -0,0 +1,56 @@ +---------------------------------------------------------------------- +-- | +-- Module: Web.MailChimp.Tutorial +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.MailChimp.Tutorial + ( + ) + where + +-- | +-- +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE RecordWildCards #-} +-- +-- -- base +-- import System.Environment (getEnv) +-- +-- -- bytestring +-- import Data.ByteString.Char8 (pack) +-- +-- -- mailchimp +-- import Web.MailChimp +-- +-- -- text +-- import qualified Data.Text as Text +-- +-- +-- example :: IO () +-- example = do +-- manager <- makeManager +-- key <- fmap pack (getEnv "MAILCHIMP_API_KEY") +-- listId <- fmap Text.pack (getEnv "MAILCHIMP_LIST_ID") +-- +-- let +-- Just ListMemberClient {..} = +-- makeListMemberClient manager key listId +-- +-- let +-- member = +-- (makeListMemberRequest "sd@sd.com" Pending) +-- { listMemberMergeFields = [("FNAME", "Juan")] +-- } +-- +-- eitherAdd <- addListMember member +-- +-- case eitherAdd of +-- Left err -> +-- putStrLn $ "Error: " ++ show err +-- +-- Right msg -> +-- print msg