Instantly share code, notes, and snippets.

Embed
What would you like to do?
-- stack --resolver lts-10.0 script
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
import qualified Data.Aeson as Json
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (writeFile)
import Data.Colour.SRGB (sRGB24)
import qualified Data.CSV.Conduit as Csv
import qualified Data.CSV.Conduit.Conversion as Csv
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (fromMaybe)
import Data.Ord (Down(Down))
import Data.Text (pack)
import Data.Text.Encoding (encodeUtf8)
import Data.Time (UTCTime, formatTime, defaultTimeLocale)
import GHC.Generics (Generic)
import qualified Graphics.Rendering.Chart.Easy as Chart
import qualified Graphics.Rendering.Chart.Backend.Cairo as Cairo
import qualified Graphics.Rendering.Chart.Backend.Diagrams as Diagrams
import qualified Network.HTTP.Client as Http
import Network.HTTP.Client.TLS (getGlobalManager, newTlsManager, setGlobalManager)
import Prelude hiding (writeFile)
import System.Environment (getArgs)
import System.FilePath (addExtension)
import System.IO (IOMode(WriteMode), hPutStrLn, stderr)
main = do
[dataCenter, apiKey] <- getArgs
manager <- newTlsManager
setGlobalManager manager
campaigns <- do
warnLn "Getting campaigns"
response <- mailChimp
dataCenter
apiKey
"campaigns"
[ ("since_send_time", "2017-01-01T00:00:00Z")
, ("before_send_time", "2018-01-01T00:00:00Z")
, ("count", "52")
]
let campaigns = campaignResponseCampaigns response
warnLn (unwords ["Got", show (length campaigns), "campaigns"])
pure campaigns
let sortedCampaigns = sortBy (on compare campaignSendTime) campaigns
links <- mapM
( \campaign -> do
warnLn (unwords ["Getting links for campaign", campaignId campaign])
let
endpoint = concat ["reports/", campaignId campaign, "/click-details"]
response <- mailChimp dataCenter apiKey endpoint [("count", "100")]
let links = linkResponseUrlsClicked response
warnLn (unwords ["Got", show (length links), "links"])
pure links
)
campaigns
let
sortedLinks = sortBy (on compare (Down . linkUniqueClicks)) (concat links)
warnLn "Making campaigns JSON"
writeFile "output-campaigns.json" (encodePretty sortedCampaigns)
warnLn "Making links JSON"
writeFile "output-links.json" (encodePretty sortedLinks)
warnLn "Making campaigns CSV"
writeCsv
"output-campaigns"
( map
utf8
["Campaign ID", "Sent at", "Emails sent", "Open rate", "Click rate"]
: map
( \campaign ->
[ Csv.toField (campaignId campaign)
, Csv.toField
( formatTime
defaultTimeLocale
"%Y-%m-%dT%H:%M:%S"
(campaignSendTime campaign)
)
, Csv.toField (campaignEmailsSent campaign)
, Csv.toField (summaryOpenRate (campaignReportSummary campaign))
, Csv.toField (summaryClickRate (campaignReportSummary campaign))
]
)
sortedCampaigns
)
warnLn "Making links CSV"
writeCsv
"output-links"
( map
utf8
[ "Campaign ID"
, "Link ID"
, "Link URL"
, "Unique clicks"
, "Click percentage"
]
: map
( \link ->
[ Csv.toField (linkCampaignId link)
, Csv.toField (linkId link)
, Csv.toField (linkUrl link)
, Csv.toField (linkUniqueClicks link)
, Csv.toField (linkUniqueClickPercentage link)
]
)
sortedLinks
)
warnLn "Making recipients graph"
writeLineGraph
"output-total-subscribers"
"Haskell Weekly total subscribers"
( fmap
(\campaign -> (campaignDate campaign, campaignEmailsSent campaign))
sortedCampaigns
)
warnLn "Making subscribers graph"
writeBarChart
"output-new-subscribers"
"Haskell Weekly new subscribers"
( fmap
( \(old, new) ->
(campaignDate new, campaignEmailsSent new - campaignEmailsSent old)
)
(zip sortedCampaigns (drop 1 sortedCampaigns))
)
warnLn "Making open rate graph"
writeLineGraph
"output-open-rate"
"Haskell Weekly open rate"
( fmap
( \campaign ->
( campaignDate campaign
, 100 * summaryOpenRate (campaignReportSummary campaign)
)
)
sortedCampaigns
)
warnLn "Making click rate graph"
writeLineGraph
"output-click-rate"
"Haskell Weekly click rate"
( fmap
( \campaign ->
( campaignDate campaign
, 100 * summaryClickRate (campaignReportSummary campaign)
)
)
sortedCampaigns
)
writeCsv :: Csv.CSV ByteString a => FilePath -> [a] -> IO ()
writeCsv file rows =
Csv.writeCSVFile Csv.defCSVSettings (addExtension file "csv") WriteMode rows
mailChimp
:: Json.FromJSON json
=> String
-> String
-> String
-> [(String, String)]
-> IO json
mailChimp dataCenter apiKey endpoint query = do
let
url =
concat ["https://us", dataCenter, ".api.mailchimp.com/3.0/", endpoint]
initialRequest <- Http.parseUrlThrow url
let
request = Http.applyBasicAuth
mempty
(utf8 apiKey)
( Http.setQueryString
(fmap (\(k, v) -> (utf8 k, Just (utf8 v))) query)
initialRequest
)
manager <- getGlobalManager
response <- Http.httpLbs request manager
either fail pure (Json.eitherDecode (Http.responseBody response))
writeLineGraph
:: (Num a, Chart.PlotValue a) => FilePath -> String -> [(String, a)] -> IO ()
writeLineGraph file title elements = do
let
graph = do
Chart.assign Chart.layout_title title
Chart.assign
(Chart.layout_x_axis . Chart.laxis_generate)
(Chart.autoIndexAxis (fmap fst elements))
Chart.plot
( Chart.liftEC
( do
Chart.assign
(Chart.plot_fillbetween_style . Chart.fill_color)
(Chart.withOpacity purple 0.5)
Chart.assign
Chart.plot_fillbetween_values
(fmap (\(i, (_, v)) -> (i :: Int, (0, v))) (zip [0 ..] elements))
)
)
Diagrams.toFile Chart.def (addExtension file "svg") graph
Cairo.toFile Chart.def (addExtension file "png") graph
writeBarChart
:: Chart.BarsPlotValue a => FilePath -> String -> [(String, a)] -> IO ()
writeBarChart file title elements = do
let
chart = do
Chart.assign Chart.layout_title title
Chart.setColors [Chart.opaque purple]
Chart.assign
(Chart.layout_x_axis . Chart.laxis_generate)
(Chart.autoIndexAxis (fmap fst elements))
Chart.plot
( fmap
Chart.plotBars
(Chart.bars [""] (Chart.addIndexes (fmap (pure . snd) elements)))
)
Diagrams.toFile Chart.def (addExtension file "svg") chart
Cairo.toFile Chart.def (addExtension file "png") chart
newtype CampaignResponse = CampaignResponse
{ campaignResponseCampaigns :: [Campaign]
} deriving (Eq, Generic, Show)
instance Json.FromJSON CampaignResponse where
parseJSON = Json.genericParseJSON (prefixOptions "campaignResponse")
data Campaign = Campaign
{ campaignId :: String
, campaignSendTime :: UTCTime
, campaignEmailsSent :: Int
, campaignReportSummary :: Summary
} deriving (Eq, Generic, Show)
instance Json.FromJSON Campaign where
parseJSON = Json.genericParseJSON (prefixOptions "campaign")
instance Json.ToJSON Campaign where
toJSON = Json.genericToJSON (prefixOptions "campaign")
data Summary = Summary
{ summaryOpenRate :: Double
, summaryClickRate :: Double
} deriving (Eq, Generic, Show)
instance Json.FromJSON Summary where
parseJSON = Json.genericParseJSON (prefixOptions "summary")
instance Json.ToJSON Summary where
toJSON = Json.genericToJSON (prefixOptions "summary")
newtype LinkResponse = LinkResponse
{ linkResponseUrlsClicked :: [Link]
} deriving (Eq, Generic, Show)
instance Json.FromJSON LinkResponse where
parseJSON = Json.genericParseJSON (prefixOptions "linkResponse")
data Link = Link
{ linkId :: String
, linkCampaignId :: String
, linkUrl :: String
, linkUniqueClicks :: Int
, linkUniqueClickPercentage :: Double
} deriving (Eq, Generic, Show)
instance Json.FromJSON Link where
parseJSON = Json.genericParseJSON (prefixOptions "link")
instance Json.ToJSON Link where
toJSON = Json.genericToJSON (prefixOptions "link")
purple :: Chart.Colour Double
purple = sRGB24 0x5c 0x35 0x66
campaignDate :: Campaign -> String
campaignDate = formatTime defaultTimeLocale "%Y-%m-%d" . campaignSendTime
prefixOptions :: String -> Json.Options
prefixOptions prefix = Json.defaultOptions
{ Json.fieldLabelModifier = snake . unsafeDropPrefix prefix
}
snake :: String -> String
snake = Json.camelTo2 '_'
unsafeDropPrefix :: (Eq a, Show a) => [a] -> [a] -> [a]
unsafeDropPrefix prefix list = fromMaybe
(error (unwords [show prefix, "is not a prefix of", show list]))
(dropPrefix prefix list)
dropPrefix :: Eq a => [a] -> [a] -> Maybe [a]
dropPrefix prefix list = case prefix of
[] -> Just list
prefixFirst:prefixRest -> case list of
[] -> Nothing
listFirst:listRest -> if prefixFirst == listFirst
then dropPrefix prefixRest listRest
else Nothing
utf8 :: String -> ByteString
utf8 = encodeUtf8 . pack
warnLn :: String -> IO ()
warnLn = hPutStrLn stderr
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment