diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.2.0 + +- Moved to Servant 0.10 (3931320) + # 0.1.1 - Tested with GHC 8.0.1. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,14 +2,20 @@ [![][1]][0] -[0]: https://travis-ci.org/jpvillaisaza/mailchimp-haskell -[1]: https://travis-ci.org/jpvillaisaza/mailchimp-haskell.svg?branch=master +[0]: https://circleci.com/gh/jpvillaisaza/mailchimp-haskell +[1]: https://circleci.com/gh/jpvillaisaza/mailchimp-haskell.svg?style=svg ![][2] ![][3] [2]: https://www.stackage.org/package/mailchimp/badge/lts [3]: https://www.stackage.org/package/mailchimp/badge/nightly + +## Coverage + +- API Root +- Lists + - Members ## License diff --git a/mailchimp.cabal b/mailchimp.cabal --- a/mailchimp.cabal +++ b/mailchimp.cabal @@ -1,5 +1,5 @@ name: mailchimp -version: 0.1.1 +version: 0.2.0 build-type: Simple cabal-version: >= 1.21 @@ -33,23 +33,24 @@ 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 + Web.MailChimp.Tutorial + other-modules: + Paths_mailchimp build-depends: - aeson >= 0.11 && < 0.12 + aeson >= 1.1 && < 1.2 , 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.9 - , servant-client >= 0.7 && < 0.9 + , generics-sop >= 0.2 && < 0.3 + , http-client >= 0.5 && < 0.6 + , http-client-tls >= 0.3 && < 0.4 + , servant >= 0.10 && < 0.11 + , servant-client >= 0.10 && < 0.11 , text >= 1.2 && < 1.3 , transformers default-language: diff --git a/src/Web/MailChimp.hs b/src/Web/MailChimp.hs --- a/src/Web/MailChimp.hs +++ b/src/Web/MailChimp.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- @@ -14,21 +17,14 @@ ---------------------------------------------------------------------- module Web.MailChimp - ( Key - , Client(..) - , makeClient - , ListClient(..) - , ListId - , ListMemberClient(..) - , makeListMemberClient - , ListMemberRequest(..) - , makeListMemberRequest - , ListMemberResponse(..) - , ListMemberId - , ListMemberStatus(..) - , Id + ( MainClient (..) + , makeMainClient + , AuthClient (..) + , makeAuthClientWithKey + , run + , makeBaseUrl , Paths_mailchimp.version - , makeManager + , module X ) where @@ -38,171 +34,175 @@ -- base import Data.Proxy (Proxy (Proxy)) import Data.Void (Void) +import GHC.Generics -- bytestring import Data.ByteString.Char8 (unpack) +-- generics-sop +import Generics.SOP + -- 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 +import Web.MailChimp.Common as X +import Web.MailChimp.Extra as X +import Web.MailChimp.Key as X +import Web.MailChimp.List as X +import Web.MailChimp.List.Member as X -- servant import Servant.API -- servant-client -import Servant.Client hiding (Client) -import qualified Servant.Client as Servant +import Servant.Client +import Servant.Client.Generic -- transformers import Control.Monad.IO.Class -import Control.Monad.Trans.Except (ExceptT, runExceptT) -- | -- -- The MailChimp API, version 3.0. -type Api = +type MainApi = "3.0" :> BasicAuth "" Void - :> (Get '[JSON] Object :<|> ListApi) + :> AuthApi -- | -- +-- + +newtype MainClient = + MainClient + { makeAuthClient + :: BasicAuthData + -> AuthClient + + } + deriving (GHC.Generics.Generic) + + +-- | +-- +-- +instance Generics.SOP.Generic MainClient + + +-- | +-- +-- + +instance (Client MainApi ~ client) => ClientLike client MainClient + + +-- | +-- +-- + +makeMainClient :: MainClient +makeMainClient = + mkClient (client (Proxy :: Proxy MainApi)) + + +-- | +-- +-- + +type AuthApi = + Get '[JSON] Object + :<|> + "lists" + :> ListApi + :<|> + "lists" + :> Capture "list_id" ListId + :> "members" + :> ListMemberApi + + +-- | +-- -- A client for MailChimp. -data Client = - Client +data AuthClient = + AuthClient { -- | -- -- getLinks - :: forall m . MonadIO m - => m (Either ServantError Object) + :: ClientM Object -- | -- - -- Create a client for a list. + -- Create a client for lists. , makeListClient + :: ListClient + + -- | + -- + -- Create a client for list members. + + , makeListMemberClient :: ListId - -> ListClient + -> ListMemberClient } + deriving (GHC.Generics.Generic) -- | -- --- 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 {..} +instance Generics.SOP.Generic AuthClient -- | -- -- -makeListClient' - :: Manager - -> BaseUrl - -> Servant.Client ListApi - -> ListId - -> ListClient -makeListClient' manager baseUrl client' listId = - let - listMemberClient = - makeListMemberClient' manager baseUrl (client' listId) - in - ListClient {..} +instance (Client AuthApi ~ client) => ClientLike client AuthClient -- | -- -- -makeListMemberClient' - :: Manager - -> BaseUrl - -> Servant.Client ListMemberApi - -> ListMemberClient -makeListMemberClient' manager baseUrl listClient = +makeAuthClientWithKey + :: Key + -> AuthClient +makeAuthClientWithKey key = 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) + MainClient {..} = makeMainClient in - ListMemberClient {..} + makeAuthClient (BasicAuthData "" key) + -- | -- -- run :: MonadIO m - => ExceptT e IO a - -> m (Either e a) -run = - liftIO . runExceptT - - --- | --- --- Create a client for a list members. - -makeListMemberClient - :: Manager + => Manager -> Key - -> ListId - -> Maybe ListMemberClient -makeListMemberClient manager key listId = - listMemberClient . (`makeListClient` listId) - <$> makeClient manager key + -> ClientM a + -> m (Either ServantError a) +run manager key = + let + Just baseUrl = + makeBaseUrl key + in + liftIO . flip runClientM (ClientEnv manager baseUrl) -- | diff --git a/src/Web/MailChimp/List.hs b/src/Web/MailChimp/List.hs --- a/src/Web/MailChimp/List.hs +++ b/src/Web/MailChimp/List.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- @@ -12,19 +16,28 @@ module Web.MailChimp.List ( ListApi - , ListClient(..) + , ListClient (..) , ListId ) where +-- base +import GHC.Generics + +-- generics-sop +import Generics.SOP + -- mailchimp import Web.MailChimp.Common -import Web.MailChimp.List.Member -- servant import Servant.API +-- servant-client +import Servant.Client +import Servant.Client.Generic + -- | -- -- A list ID. @@ -38,10 +51,7 @@ -- type ListApi = - "lists" - :> Capture "list_id" ListId - :> "members" - :> ListMemberApi + Get '[JSON] [String] -- | @@ -54,6 +64,20 @@ -- -- - listMemberClient :: ListMemberClient + getLists :: ClientM [String] } + deriving (GHC.Generics.Generic) + + +-- | +-- +-- +instance Generics.SOP.Generic ListClient + + +-- | +-- +-- + +instance (Client ListApi ~ client) => ClientLike client ListClient diff --git a/src/Web/MailChimp/List/Member.hs b/src/Web/MailChimp/List/Member.hs --- a/src/Web/MailChimp/List/Member.hs +++ b/src/Web/MailChimp/List/Member.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- @@ -15,12 +18,12 @@ module Web.MailChimp.List.Member ( ListMemberApi - , ListMemberClient(..) - , ListMemberRequest(..) + , ListMemberClient (..) + , ListMemberRequest (..) , makeListMemberRequest - , ListMemberResponse(..) + , ListMemberResponse (..) , ListMemberId - , ListMemberStatus(..) + , ListMemberStatus (..) ) where @@ -28,6 +31,12 @@ import Data.Aeson import qualified Data.Aeson as Aeson +-- base +import GHC.Generics + +-- generics-sop +import Generics.SOP + -- mailchimp import Web.MailChimp.Common @@ -36,41 +45,44 @@ -- servant-client import Servant.Client +import Servant.Client.Generic -- 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] + ReqBody '[JSON] ListMemberRequest + :> Post '[JSON] ListMemberResponse - :<|> Capture "subscriber_hash" ListMemberId - :> Get '[JSON] ListMemberResponse + :<|> + Get '[JSON] [ListMemberResponse] - :<|> Capture "subscriber_hash" ListMemberId - :> ReqBody '[JSON] ListMemberRequest - :> Patch '[JSON] ListMemberResponse + :<|> + Capture "subscriber_hash" ListMemberId + :> Get '[JSON] ListMemberResponse - :<|> Capture "subscriber_hash" ListMemberId - :> ReqBody '[JSON] ListMemberRequest - :> Put '[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 + :<|> + Capture "subscriber_hash" ListMemberId + :> Delete '[JSON] String -- | @@ -84,57 +96,66 @@ -- Add a new list member. addListMember - :: forall m . MonadIO m - => ListMemberRequest - -> m (Either ServantError ListMemberResponse) + :: ListMemberRequest + -> ClientM ListMemberResponse -- | -- -- Get information about members in a list. , getListMembers - :: forall m . MonadIO m - => m (Either ServantError [ListMemberResponse]) + :: ClientM [ListMemberResponse] -- | -- -- Get information about a specific list member. , getListMember - :: forall m . MonadIO m - => ListMemberId - -> m (Either ServantError ListMemberResponse) + :: ListMemberId + -> ClientM ListMemberResponse -- | -- -- Update a list member. , updateListMember - :: forall m . MonadIO m - => ListMemberId + :: ListMemberId -> ListMemberRequest - -> m (Either ServantError ListMemberResponse) + -> ClientM ListMemberResponse -- | -- -- Add or update a list member. , addOrUpdateListMember - :: forall m . MonadIO m - => ListMemberId + :: ListMemberId -> ListMemberRequest - -> m (Either ServantError ListMemberResponse) + -> ClientM ListMemberResponse -- | -- -- Remove a list member. , deleteListMember - :: forall m . MonadIO m - => ListMemberId - -> m (Either ServantError String) + :: ListMemberId + -> ClientM String } + deriving (GHC.Generics.Generic) + + +-- | +-- +-- + +instance Generics.SOP.Generic ListMemberClient + + +-- | +-- +-- + +instance (Client ListMemberApi ~ client) => ClientLike client ListMemberClient -- | diff --git a/src/Web/MailChimp/Tutorial.hs b/src/Web/MailChimp/Tutorial.hs --- a/src/Web/MailChimp/Tutorial.hs +++ b/src/Web/MailChimp/Tutorial.hs @@ -35,12 +35,8 @@ listId <- fmap Text.pack (getEnv "MAILCHIMP_LIST_ID") let - Just Client {..} = - makeClient manager key - - let - Just ListMemberClient {..} = - makeListMemberClient manager key listId + AuthClient {..} = makeAuthClientWithKey key + ListMemberClient {..} = makeListMemberClient listId let member = @@ -48,16 +44,8 @@ { listMemberMergeFields = [("FNAME", "Juan")] } - eitherLinks <- getLinks - - case eitherLinks of - Left err -> - putStrLn $ "Error: " ++ show err - - Right msg -> - print msg - - eitherAdd <- addListMember member + eitherAdd <- run manager key (addListMember member) +-- eitherAdd <- run manager key (getLinks (BasicAuthData "" key)) case eitherAdd of Left err ->