{-# LANGUAGE OverloadedStrings #-} -- | -- Module: MailchimpSimple -- License: BSD3 -- Maintainer: Dananji Liyanage -- Stability: experimental -- -- Types and functions for working with Mailchimp JSON API Version 3.0 module MailchimpSimple ( -- ** Working with Lists -- $lists listMailingLists , listSubscribers , addSubscriber , removeSubscriber -- ** Retrieve Template related data -- $templates , getTemplates -- ** Working with Campaigns -- $campaigns , getCampaigns , createCampaign , sendEmail -- ** Batch Requests -- $batches , batchSubscribe ) where import Network.HTTP.Conduit import Network.HTTP.Types ( methodPost, methodGet, methodDelete, Status(..), http11, ResponseHeaders, hContentType ) import Control.Monad.IO.Class ( liftIO ) import Safe import Control.Exception ( catch, IOException, Exception ) import Control.Lens.Getter ( (^.)) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath.Posix ( pathSeparator ) import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Base16 as B16 import qualified Data.Text as T import Data.Aeson ( encode, decode, eitherDecode, Value, Array, ToJSON ) import Data.List ( transpose, intercalate ) import Data.Aeson.Lens ( key ) import Data.Maybe ( Maybe(..), fromJust ) import qualified Data.Vector as V import Crypto.Hash.MD5 as MD5 -- App modules import Utils.Types -- | Takes an @apiKey@ of a Mailchimp account, and gives all the mailing-lists in the account. -- -- This function lists the mailing lists in a particular account listMailingLists :: String -> IO [MailListResponse] listMailingLists apiKey = do let url = endPointUrl apiKey let lUrl = url ++ "/lists?fields=lists.id,lists.name" response <- processGET lUrl apiKey let resBody = decode (responseBody response) :: Maybe Value let vArray = resBody ^. key "lists" :: Maybe Array let listResponse = getValues vArray return listResponse where getValues ls | ls /= (Just V.empty) = constructMLRes (fmap V.head ls) : getValues (fmap V.tail ls) | otherwise = [] constructMLRes elem = do let lName = elem ^. key "name" :: Maybe String let lID = elem ^. key "id" :: Maybe String MailListResponse lName lID -- | Takes an @apiKey@ of the Mailchimp account, and a @listName@. -- Retrieves all the members in the given list. -- -- Request URL specifies which data to be returned from the response. They are, -- @email_address, unique_email_id, email_type, list_id@, and @status@ for each -- member in the reponse. -- -- This function lists subscribers in a mailing list listSubscribers :: String -> String -> IO [ListSubscribersResponse] listSubscribers apiKey listName = do let url = endPointUrl apiKey listid <- getListID apiKey listName let lUrl = url ++ "/lists/" ++ listid ++ "/members?fields=members.email_address,members.unique_email_id,members.email_type,members.list_id,members.status" response <- processGET lUrl apiKey let resBody = decode (responseBody response) :: Maybe Value let vArray = resBody ^. key "members" :: Maybe Array let listSubResponse = getValues vArray return listSubResponse where getValues ls | ls /= (Just V.empty) = constructMLRes (fmap V.head ls) : getValues (fmap V.tail ls) | otherwise = [] constructMLRes elem = ListSubscribersResponse sName sEuid (Just listName) sEmailType sStatus where sName = elem ^. key "email_address" :: Maybe String sEuid = elem ^. key "unique_email_id" :: Maybe String sEmailType = elem ^. key "email_type" :: Maybe String sStatus = elem ^. key "status" :: Maybe String -- | Taking @apiKey,@ @listName,@ @emailAddress,@ @emailType,@ and @memberStatus@ as input -- parameters in the given order, this function creates and add the member to the given list. -- -- This function adds a new member to a given list addSubscriber :: String -> String -> String -> String -> String -> IO SubscriptionResponse addSubscriber apiKey listName email emailType status = do let url = endPointUrl apiKey let subscription = Subscription { s_email = email , s_email_type = emailType , s_status = status } listid <- getListID apiKey listName let sUrl = url ++ "/lists/" ++ listid ++ "/members" response <- processPOST sUrl subscription apiKey let resBody = decode (responseBody response) :: Maybe Value let subscribers = constructSRes resBody return subscribers where constructSRes elem = do let email = elem ^. key "email_address" :: Maybe String let euid = elem ^. key "unique_email_id" :: Maybe String let status = elem ^. key "status" :: Maybe String SubscriptionResponse email euid status (Just listName) filterListID list = filter ((==(Just listName)) . l_name) list -- | Giving an @apiKey,@ @emailAddress,@ and @listName@ which the member belongs to, this -- function unsubscribe the member from the list. This function does not deletes the particular -- user profile from the mailing-list. -- -- This function removes a member from a given list removeSubscriber :: String -> String -> String -> IO Bool removeSubscriber apiKey email listName = do let url = endPointUrl apiKey listid <- getListID apiKey listName let subhash = createHash email let rUrl = url ++ "/lists/" ++ listid ++ "/members/" ++ subhash response <- processDELETE rUrl apiKey let resBody = statusCode $ responseStatus response case resBody of 204 -> return True _ -> return False where createHash str = (B8.unpack (calculateHash (strToBS str))) calculateHash str = (B16.encode (hash str)) strToBS str = B8.pack str -- | Input parameters for this function is the @apiKey@ of the Mailchimp account. -- -- This function retrieves all the templates in the account. getTemplates :: String -> IO [TemplateResponse] getTemplates apiKey = do let url = endPointUrl apiKey let tUrl = url ++ "/templates?fields=templates.id,templates.name" response <- processGET tUrl apiKey let resBody = decode (responseBody response) :: Maybe Value let galleryT = resBody ^. key "templates" :: Maybe Array let templateList = getValues galleryT return templateList where getValues ls | ls /= (Just V.empty) = constructTRes (fmap V.head ls) : getValues (fmap V.tail ls) | otherwise = [] constructTRes elem = do let tName = elem ^. key "name" :: Maybe String let tID = elem ^. key "id" :: Maybe Int TemplateResponse tName tID -- | Taking the @apiKey@ of a Mailchimp account, this function returns all the -- stored unsent Campaigns. -- -- This function returns all the Campaigns in the account. getCampaigns :: String -> IO [(Maybe String, Maybe String)] getCampaigns apiKey = do let url = endPointUrl apiKey let cUrl = url ++ "/campaigns?fields=campaigns.id,campaigns.settings" response <- processGET cUrl apiKey let resBody = decode (responseBody response) :: Maybe Value let rawcids = resBody ^. key "campaigns" :: Maybe Array let cids = getValues rawcids return cids where getValues ls | ls /= (Just V.empty) = constructCRes (fmap V.head ls) : getValues (fmap V.tail ls) | otherwise = [] constructCRes elem = do let cid = elem ^. key "id" :: Maybe String let settings = elem ^. key "settings" :: Maybe Value let name = settings ^. key "subject_line" :: Maybe String (cid, name) -- | Usage of this function to create a new Campaign and save is as follows; -- -- @createCampaign@ @apiKey listName replyTo fromName cType title subject -> campaignID@ -- -- This function creates a new campaign and save it createCampaign :: String -> String -> String -> String -> String -> String -> String -> IO (Maybe String) createCampaign apiKey listName replyTo fromName cType title subject = do let url = endPointUrl apiKey listid <- getListID apiKey listName let campaign = Campaign { c_type = cType , c_settings = Settings { s_subject = subject , s_title = title , s_from_name = fromName , s_reply_to = replyTo } , c_receipients = (ListID listid) } let eUrl = url ++ "/campaigns" response <- processPOST eUrl campaign apiKey let resBody = decode (responseBody response) :: Maybe Value let campaignid = resBody ^. key "id" :: Maybe String return campaignid -- | Input parameters for this function are @apiKey@ and the @campaignID@ of the -- particular Campaign to be sent. -- -- This function sends an email campaign sendEmail :: String -> String -> IO (Either String SendMailResponse) sendEmail apiKey cid = do let url = endPointUrl apiKey let sUrl = url ++ "/campaigns/" ++ cid ++ "/actions/send" response <- processEmptyPOST sUrl apiKey let sendRes = eitherDecode (responseBody response) :: Either String SendMailResponse return sendRes -- | Efficiently processes a batch subscription requests for a given list -- of @emailAddress@ and @subscriptionStatus@ combinations. -- -- This function can be re-implemented to perform other batch requests by changing the -- @body@ and @path@ properties of @Operation@ data structure. -- -- This function adds a batch of subscribers batchSubscribe :: String -> String -> [(String, String)] -> IO BatchSubscriptionResponse batchSubscribe apiKey listName subs = do let url = endPointUrl apiKey listid <- getListID apiKey listName let batchSubs = map constructSubs subs let batchOps = map (constructOps listid) batchSubs let batchSubscription = Batch { operations = batchOps } let bUrl = url ++ "/batches" response <- processPOST bUrl batchSubscription apiKey let resBody = decode (responseBody response) :: Maybe Value let batchResponse = BatchSubscriptionResponse (resBody ^. key "id" :: Maybe String) (resBody ^. key "status" :: Maybe String) return batchResponse where constructSubs (email, status) = Subscription { s_email = email , s_email_type = "html" , s_status = status } constructOps listid sub = Operation { o_method = "POST" , o_path = "/lists/" ++ listid ++ "/members" , o_params = Params { params = [] } , o_body = B8.unpack $ BL.toStrict $ encode sub } ------------------------------------------------------------------------------------------------------------------------------------- -- Get the list_id when the listname is given getListID :: String -> String -> IO String getListID apiKey listName = do mailinglists <- listMailingLists apiKey let rawlistid = headMay $ filterListID mailinglists case rawlistid of Just mlist -> return $ fromJust $ l_id mlist Nothing -> do putStrLn $ "Error: Invalid list name, " ++ listName return "" where filterListID list = filter ((==(Just listName)) . l_name) list -- | Build the response from URL and JSON data processGET :: String -> String -> IO (Response ByteString) processGET url apiKey = do let initReq = applyBasicAuth (B8.pack "anystring") (B8.pack apiKey) $ fromJust $ parseUrl url let req = initReq { method = methodGet } catch (newManager tlsManagerSettings >>= (httpLbs req)) (\(StatusCodeException s h c) -> do let ex = (show s ++ "," ++ show h ++ "," ++ show c) getResponse s h c apiKey exitWith (ExitFailure 0)) processPOST :: ToJSON a => String -> a -> String -> IO (Response ByteString) processPOST url json apiKey = do let initReq = applyBasicAuth (B8.pack "anystring") (B8.pack apiKey) $ fromJust $ parseUrl url let req = initReq { requestBody = RequestBodyLBS $ encode json , method = methodPost } manager <- newManager tlsManagerSettings catch (httpLbs req manager) (\(StatusCodeException s h c) -> do let ex = (show s ++ "," ++ show h ++ "," ++ show c) getResponse s h c apiKey) processEmptyPOST :: String -> String -> IO (Response ByteString) processEmptyPOST url apiKey = do let initReq = applyBasicAuth (B8.pack "anystring") (B8.pack apiKey) $ fromJust $ parseUrl url let req = initReq { method = methodPost } manager <- newManager tlsManagerSettings catch (httpLbs req manager) (\(StatusCodeException s h c) -> do let ex = (show s ++ "," ++ show h ++ "," ++ show c) getResponse s h c apiKey) processDELETE :: String -> String -> IO (Response ByteString) processDELETE url apiKey = do let initReq = applyBasicAuth (B8.pack "anystring") (B8.pack apiKey) $ fromJust $ parseUrl url let req = initReq { method = methodDelete } manager <- newManager tlsManagerSettings catch (httpLbs req manager) (\(StatusCodeException s h c) -> do let ex = (show s ++ "," ++ show h ++ "," ++ show c) getResponse s h c apiKey) -- | Construct the erroneous HTTP responses when an exception occurs getResponse :: Status -> ResponseHeaders -> CookieJar -> String -> IO (Response ByteString) getResponse s h c apiKey = do let url = endPointUrl apiKey let initReq = applyBasicAuth (B8.pack "anystring") (B8.pack apiKey) $ fromJust $ parseUrl url let req = initReq { method = methodGet } manager <- newManager tlsManagerSettings response <- httpLbs req manager let errorRes = response { responseStatus = s , responseVersion = http11 , responseBody = "" , responseHeaders = h , responseCookieJar = c } return errorRes -- | Construct the end-point URL endPointUrl :: String -> String endPointUrl apiKey = "https://" ++ (last (splitString '-' apiKey)) ++ ".api.mailchimp.com/3.0" -- | Utility function to split strings splitString :: Char -> String -> [String] splitString d [] = [] splitString d s = x : splitString d (drop 1 y) where (x,y) = span (/= d) s