Haskell Weekly in 2018

haskell-weekly-in-2018.hs

#!/usr/bin/env stack
-- stack --resolver lts-13.0 script
{-# OPTIONS_GHC -Weverything -Wno-implicit-prelude -Wno-unsafe #-}

module Main ( main ) where

import qualified Data.Aeson
import qualified Data.Aeson.Types
import qualified Data.List
import qualified Data.Ord
import qualified Data.Scientific
import qualified Data.Text
import qualified Data.Text.Encoding
import qualified Data.Time
import qualified Network.HTTP.Client
import qualified Network.HTTP.Client.TLS
import qualified Network.HTTP.Types
import qualified Network.URI
import qualified Numeric.Natural
import qualified System.Environment
import qualified Text.Printf

main :: IO ()
main = do
  manager <- Network.HTTP.Client.TLS.newTlsManager
  dataCenter <- DataCenter
    . Data.Text.pack
    <$> System.Environment.getEnv "MAILCHIMP_DATA_CENTER"
  apiKey <- ApiKey
    . Data.Text.pack
    <$> System.Environment.getEnv "MAILCHIMP_API_KEY"
  campaigns <- getCampaigns manager dataCenter apiKey
  writeFile "campaigns.csv"
    . campaignsCsv
    $ Data.List.sortOn campaignSendTime campaigns
  links <- getAllLinks manager dataCenter apiKey $ fmap campaignId campaigns
  writeFile "links.csv"
    . linksCsv
    $ Data.List.sortOn (Data.Ord.Down . linkUniqueClicks) links

campaignsCsv :: [Campaign] -> String
campaignsCsv campaigns = unlines $ fmap (Data.List.intercalate ",")
  ( ["ID", "Sent at", "Subscribers", "Open rate", "Click rate"]
  : fmap campaignCsv campaigns
  )

campaignCsv :: Campaign -> [String]
campaignCsv campaign =
  [ Data.Text.unpack . unwrapCampaignId $ campaignId campaign
  , Data.Time.formatTime Data.Time.defaultTimeLocale "%Y-%m-%d %H:%M:%S" $ campaignSendTime campaign
  , show $ campaignEmailsSent campaign
  , Data.Scientific.formatScientific Data.Scientific.Fixed (Just 2) . summaryOpenRate $ campaignReportSummary campaign
  , Data.Scientific.formatScientific Data.Scientific.Fixed (Just 2) . summaryClickRate $ campaignReportSummary campaign
  ]

linksCsv :: [Link] -> String
linksCsv links = unlines $ fmap (Data.List.intercalate ",")
  ( ["ID", "Campaign", "Clicks", "URL"]
  : fmap linkCsv links
  )

linkCsv :: Link -> [String]
linkCsv link =
  [ Data.Text.unpack . unwrapLinkId $ linkId link
  , Data.Text.unpack . unwrapCampaignId $ linkCampaignId link
  , show $ linkUniqueClicks link
  , ($ "") . Network.URI.uriToString id . unwrapUrl $ linkUrl link
  ]

getCampaigns
  :: Network.HTTP.Client.Manager
  -> DataCenter
  -> ApiKey
  -> IO [Campaign]
getCampaigns manager dataCenter apiKey =
  campaignResponseCampaigns
    <$> apiRequest manager dataCenter apiKey "campaigns"
      [ ("since_send_time", "2018-01-01T00:00:00Z")
      , ("before_send_time", "2019-01-01T00:00:00Z")
      , ("count", "52")
      ]

getAllLinks
  :: Network.HTTP.Client.Manager
  -> DataCenter
  -> ApiKey
  -> [CampaignId]
  -> IO [Link]
getAllLinks manager dataCenter apiKey =
  fmap concat . mapM (getLinks manager dataCenter apiKey)

getLinks
  :: Network.HTTP.Client.Manager
  -> DataCenter
  -> ApiKey
  -> CampaignId
  -> IO [Link]
getLinks manager dataCenter apiKey campaign =
  linkResponseUrlsClicked
    <$> apiRequest manager dataCenter apiKey
      (Text.Printf.printf "reports/%s/click-details" $ unwrapCampaignId campaign)
      [("count", "100")]

newtype LinkResponse = LinkResponse
  { linkResponseUrlsClicked :: [Link]
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON LinkResponse where
  parseJSON = Data.Aeson.withObject "LinkResponse" $ \ object -> LinkResponse
    <$> required object "urls_clicked"

data Link = Link
  { linkCampaignId :: CampaignId
  , linkId :: LinkId
  , linkUniqueClicks :: Numeric.Natural.Natural
  , linkUrl :: Url
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON Link where
  parseJSON = Data.Aeson.withObject "Link" $ \ object -> Link
    <$> required object "campaign_id"
    <*> required object "id"
    <*> required object "unique_clicks"
    <*> required object "url"

newtype LinkId = LinkId
  { unwrapLinkId :: Data.Text.Text
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON LinkId where
  parseJSON = Data.Aeson.withText "LinkId" $ pure . LinkId

newtype Url = Url
  { unwrapUrl :: Network.URI.URI
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON Url where
  parseJSON = Data.Aeson.withText "Url" $ \ text ->
    case Network.URI.parseURI $ Data.Text.unpack text of
      Nothing -> fail $ "invalid Url: " <> show text
      Just uri -> pure $ Url uri

newtype CampaignResponse = CampaignResponse
  { campaignResponseCampaigns :: [Campaign]
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON CampaignResponse where
  parseJSON = Data.Aeson.withObject "CampaignResponse" $ \ object -> CampaignResponse
    <$> required object "campaigns"

data Campaign = Campaign
  { campaignEmailsSent :: Numeric.Natural.Natural
  , campaignId :: CampaignId
  , campaignReportSummary :: Summary
  , campaignSendTime :: Data.Time.UTCTime
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON Campaign where
  parseJSON = Data.Aeson.withObject "Campaign" $ \ object -> Campaign
    <$> required object "emails_sent"
    <*> required object "id"
    <*> required object "report_summary"
    <*> required object "send_time"

newtype CampaignId = CampaignId
  { unwrapCampaignId :: Data.Text.Text
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON CampaignId where
  parseJSON = Data.Aeson.withText "CampaignId" $ pure . CampaignId

data Summary = Summary
  { summaryClickRate :: Data.Scientific.Scientific
  , summaryOpenRate :: Data.Scientific.Scientific
  } deriving (Eq, Show)

instance Data.Aeson.FromJSON Summary where
  parseJSON = Data.Aeson.withObject "Summary" $ \ object -> Summary
    <$> required object "click_rate"
    <*> required object "open_rate"

newtype DataCenter = DataCenter
  { unwrapDataCenter :: Data.Text.Text
  } deriving (Eq, Show)

newtype ApiKey = ApiKey
  { unwrapApiKey :: Data.Text.Text
  } deriving (Eq, Show)

apiRequest
  :: (Network.HTTP.Types.QueryLike query, Data.Aeson.FromJSON json)
  => Network.HTTP.Client.Manager
  -> DataCenter
  -> ApiKey
  -> String
  -> query
  -> IO json
apiRequest manager dataCenter apiKey endpoint queryLike = do
  request <- Network.HTTP.Client.parseUrlThrow $ Text.Printf.printf
    "https://%s.api.mailchimp.com/3.0/%s"
    (unwrapDataCenter dataCenter)
    endpoint
  let
    password = Data.Text.Encoding.encodeUtf8 $ unwrapApiKey apiKey
    query = Network.HTTP.Types.toQuery queryLike
  response <- flip Network.HTTP.Client.httpLbs manager
    . Network.HTTP.Client.applyBasicAuth mempty password
    $ Network.HTTP.Client.setQueryString query request
  either fail pure
    . Data.Aeson.eitherDecode
    $ Network.HTTP.Client.responseBody response

required
  :: Data.Aeson.FromJSON value
  => Data.Aeson.Object
  -> String
  -> Data.Aeson.Types.Parser value
required object key = object Data.Aeson..: Data.Text.pack key