Get Haskell Reddit Data

reddit-score.csv

reddit-score.hs

#!/usr/bin/env stack
-- stack --resolver lts script

{-| Call this with `stack reddit-score.hs` -}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

import ClassyPrelude
import Control.Concurrent (threadDelay)
import Control.Monad (fail)
import Data.Time.Calendar (DayOfWeek, dayOfWeek)
import Data.Time.Clock (addUTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Network.HTTP.Client (Manager, Request, httpLbs, parseRequest, responseBody, setQueryString)
import Network.HTTP.Client.TLS (newTlsManager)
import qualified Data.Aeson as Aeson
import qualified Data.Csv as Csv

{- curl https://api.pushshift.io/reddit/search/submission/\?subreddit\=haskell\&sort\=desc\&sort_type\=created_utc\&after\=1523588521\&before\=1615213869\&size\=10000
 -}

data Stats = Stats
  { statsCreated :: UTCTime
  , statsDayOfWeek :: DayOfWeek
  , statsHourOfDay :: Int
  , statsScore :: Int
  , statsAuthor :: Text
  , statsTitle :: Text
  } deriving (Eq, Ord, Show)

data RawStats = RawStats
  { rawStatsScore :: Int
  , rawStatsCreated :: Int64
  , rawStatsAuthor :: Text
  , rawStatsTitle :: Text
  } deriving (Eq, Ord, Show)

newtype RawStatsWrapper = RawStatsWrapper { unRawStatsWrapper :: [RawStats] }
  deriving (Eq, Ord, Show)

instance Csv.ToNamedRecord Stats where
  toNamedRecord Stats {..} = Csv.namedRecord
    [ Csv.namedField "created" $ iso8601Show statsCreated
    , Csv.namedField "dayOfWeek" $ show statsDayOfWeek
    , Csv.namedField "hourOfDay" statsHourOfDay
    , Csv.namedField "score" statsScore
    , Csv.namedField "author" statsAuthor
    , Csv.namedField "title" statsTitle
    ]

instance Aeson.FromJSON RawStats where
  parseJSON = Aeson.withObject "RawStats" $ \obj ->
    RawStats
      <$> obj Aeson..: "score"
      <*> obj Aeson..: "created_utc"
      <*> obj Aeson..: "author"
      <*> obj Aeson..: "title"

instance Aeson.FromJSON RawStatsWrapper where
  parseJSON = Aeson.withObject "RawStatsWrapper" $ \obj ->
    RawStatsWrapper <$>
      (Aeson.parseJSON =<< obj Aeson..: "data")

rawStatsToStats :: RawStats -> Stats
rawStatsToStats RawStats {..} =
  let created = posixSecondsToUTCTime $ fromIntegral rawStatsCreated
  in Stats
    { statsCreated = created
    , statsDayOfWeek = dayOfWeek $ utctDay created
    , statsHourOfDay = flip div (60 * 60) . floor . utctDayTime $ created
    , statsScore = rawStatsScore
    , statsAuthor = rawStatsAuthor
    , statsTitle = rawStatsTitle
    }

csvHeader :: Csv.Header
csvHeader = fromList ["created", "dayOfWeek", "hourOfDay", "score", "author", "title"]

paged :: Int -> Manager -> Request -> IO [Stats]
paged n manager baseReq = do
  let req = setQueryString
        [ ("subreddit", Just "haskell")
        , ("sort", Just "desc")
        , ("sort_type", Just "created_utc")
        , ("after", Just . encodeUtf8 $ tshow n <> "d")
        , ("before", Just . encodeUtf8 $ tshow (n - 12) <> "d")
        , ("size", Just "1000")
        ]
        baseReq
  putStrLn $ "Sending request " <> tshow req
  resp <- httpLbs req manager
  let body = toStrict $ responseBody resp
  RawStatsWrapper rawStats <- either (fail . (\reason -> "Failed to decode response " <> unpack (decodeUtf8 body) <> " due to " <> reason)) pure $ Aeson.eitherDecodeStrict' body
  pure $ rawStatsToStats <$> rawStats

main :: IO ()
main = do
  baseReq <- parseRequest "https://api.pushshift.io/reddit/search/submission/"
  manager <- newTlsManager
  stats <- map mconcat $ for [1..30] $ \i -> threadDelay 1000000 >> paged (i * 12) manager baseReq
  writeFile "reddit-score.csv" . toStrict . Csv.encodeByName csvHeader $ stats