62 lines
2.1 KiB
Haskell
62 lines
2.1 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
module Network.AMQP.Reddit where
|
|
|
|
import Control.Lens
|
|
import Data.Aeson (FromJSON, ToJSON, Value)
|
|
import Data.Aeson.Lens
|
|
import Data.Config
|
|
import Data.Deriving.Aeson
|
|
import Data.SubReddit
|
|
import Data.Text (Text)
|
|
import GHC.Generics (Generic)
|
|
import Network.Wreq hiding (getWith)
|
|
import Network.Wreq.Session (Session, getWith)
|
|
import Pipes (Producer, (>->), for, runEffect)
|
|
import qualified Pipes.Prelude as P
|
|
import Publish
|
|
import Data.Maybe (maybeToList)
|
|
import Control.Monad.Trans (liftIO)
|
|
|
|
data MessageType = Create | Update
|
|
deriving stock (Show, Eq, Generic)
|
|
deriving anyclass (ToJSON, FromJSON)
|
|
|
|
newtype RedditId = RedditId Text
|
|
deriving stock (Show, Eq)
|
|
deriving (ToJSON, FromJSON) via Text
|
|
|
|
data Message = Message
|
|
{ messageType :: MessageType
|
|
, messageIdentifier :: RedditId
|
|
, messageContent :: Value
|
|
}
|
|
deriving stock (Show, Eq, Generic)
|
|
deriving (ToJSON, FromJSON)
|
|
via AesonCodec (Field (CamelCase <<< DropPrefix "message")) Message
|
|
|
|
messages :: Session -> SubReddit -> Producer Message IO ()
|
|
messages sess sre = P.unfoldr go Nothing >-> P.concat
|
|
where
|
|
go :: Maybe Text -> IO (Either () ([Message], Maybe Text))
|
|
go after = do
|
|
let opts = defaults & header "User-Agent" .~ ["reddit-pubsub"] & param "after" .~ (maybeToList after)
|
|
r <- getWith opts sess ("https://www.reddit.com/r/" <> getSubReddit sre <> ".json")
|
|
let xs = r ^.. responseBody . key "data" . key "children" . _Array . traversed . key "data"
|
|
next = r ^? responseBody . key "data" . key "after" . _String
|
|
msgs = [Message Create (RedditId (entry ^. key "id" . _String)) entry | entry <- xs]
|
|
print next
|
|
pure $ Right (msgs, next)
|
|
|
|
publishEntries :: Publish IO Message -> Session -> Fetcher -> IO ()
|
|
publishEntries publisher sess fetcher =
|
|
runEffect $
|
|
for
|
|
(messages sess (fetcher ^. subreddit) >-> P.take (fromIntegral $ fetcher ^. entries))
|
|
(liftIO . publish publisher)
|