Last active
January 2, 2018 10:30
-
-
Save tfausak/cf3e843b199afac3d0ecb3d3b74207b4 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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