commit c200e5c98cd888090d7c4c407d7026c8ec4905e5 Author: Mats Rauhala Date: Mon Oct 25 19:04:24 2021 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cd7dd01 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle +.envrc diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..472fa1d --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,248 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: false + top_level_patterns: false + records: false + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: none + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: new_line + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: false + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: new_line_multiline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + list_padding: 7 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: false + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: false + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +language_extensions: + - RecordWildCards + - TemplateHaskell + - QuasiQuotes + - LambdaCase + - TupleSections + - MultiParamTypeClasses + - TypeApplications + - DataKinds + - TypeFamilies + - FlexibleContexts + - NamedFieldPuns + - MultiWayIf + - PolyKinds + - ExplicitForAll + - FunctionalDependencies + - ExplicitNamespaces + - ScopedTypeVariables + - ExistentialQuantification + - InstanceSigs + - GeneralizedNewtypeDeriving + - BangPatterns diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..12bc617 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for reddit-pub + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..60d904e --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified MyLib (someFunc) + +main :: IO () +main = do + putStrLn "Hello, Haskell!" + MyLib.someFunc diff --git a/config.dhall b/config.dhall new file mode 100644 index 0000000..019c3f2 --- /dev/null +++ b/config.dhall @@ -0,0 +1,16 @@ +let config = ./dhall/package.dhall + +in { amqp = config.AMQP::{ + , vhost = "reddit" + , username = env:AMQP_USER as Text ? "reddit_pub" + , password = env:AMQP_PASS as Text ? "tester" + , host = env:AMQP_HOST as Text ? "127.0.0.1" + -- , host = "10.233.5.2" + } + , fetchers = + [ config.Fetcher::{ subreddit = "haskell" } + , config.Fetcher::{ subreddit = "scala" } + , config.Fetcher::{ subreddit = "pics", entries = 150 } + ] + } + : config.Type diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..d851cef --- /dev/null +++ b/default.nix @@ -0,0 +1,17 @@ +{ mkDerivation, aeson, amqp, base, bytestring, dhall, lens +, lens-aeson, lib, mtl, pipes, text, wreq +}: +mkDerivation { + pname = "reddit-pub"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson amqp base bytestring dhall lens lens-aeson mtl pipes text + wreq + ]; + executableHaskellDepends = [ base ]; + license = "unknown"; + hydraPlatforms = lib.platforms.none; +} diff --git a/dhall/AMQP/Type.dhall b/dhall/AMQP/Type.dhall new file mode 100644 index 0000000..42fec25 --- /dev/null +++ b/dhall/AMQP/Type.dhall @@ -0,0 +1,5 @@ +{ vhost : Text +, username : Text +, password : Text +, host : Text +} diff --git a/dhall/AMQP/default.dhall b/dhall/AMQP/default.dhall new file mode 100644 index 0000000..a3dc86b --- /dev/null +++ b/dhall/AMQP/default.dhall @@ -0,0 +1,4 @@ +{ vhost = "/" +, username = "guest" +, host = "localhost" +} diff --git a/dhall/AMQP/package.dhall b/dhall/AMQP/package.dhall new file mode 100644 index 0000000..3cfe62e --- /dev/null +++ b/dhall/AMQP/package.dhall @@ -0,0 +1 @@ +{ Type = ./Type.dhall, default = ./default.dhall } diff --git a/dhall/Fetcher/Type.dhall b/dhall/Fetcher/Type.dhall new file mode 100644 index 0000000..622e228 --- /dev/null +++ b/dhall/Fetcher/Type.dhall @@ -0,0 +1,4 @@ +{ subreddit : Text +, entries : Natural +, qualifier : Optional ../Qualifier/Type.dhall +} diff --git a/dhall/Fetcher/default.dhall b/dhall/Fetcher/default.dhall new file mode 100644 index 0000000..31b2353 --- /dev/null +++ b/dhall/Fetcher/default.dhall @@ -0,0 +1,3 @@ +{ entries = 50 +, qualifier = None ../Qualifier/Type.dhall +} diff --git a/dhall/Fetcher/package.dhall b/dhall/Fetcher/package.dhall new file mode 100644 index 0000000..3cfe62e --- /dev/null +++ b/dhall/Fetcher/package.dhall @@ -0,0 +1 @@ +{ Type = ./Type.dhall, default = ./default.dhall } diff --git a/dhall/Qualifier/Type.dhall b/dhall/Qualifier/Type.dhall new file mode 100644 index 0000000..3d87940 --- /dev/null +++ b/dhall/Qualifier/Type.dhall @@ -0,0 +1 @@ +< Top | Controversial > diff --git a/dhall/Type.dhall b/dhall/Type.dhall new file mode 100644 index 0000000..e30616f --- /dev/null +++ b/dhall/Type.dhall @@ -0,0 +1,3 @@ +{ amqp : ./AMQP/Type.dhall +, fetchers : List ./Fetcher/Type.dhall +} diff --git a/dhall/default.dhall b/dhall/default.dhall new file mode 100644 index 0000000..e7506b5 --- /dev/null +++ b/dhall/default.dhall @@ -0,0 +1 @@ +{ amqp = ./AMQP/default.dhall } diff --git a/dhall/package.dhall b/dhall/package.dhall new file mode 100644 index 0000000..d5d9d1b --- /dev/null +++ b/dhall/package.dhall @@ -0,0 +1,5 @@ +{ Type = ./Type.dhall +, default = ./default.dhall +, AMQP = ./AMQP/package.dhall +, Fetcher = ./Fetcher/package.dhall +} diff --git a/easy-dhall-nix.json b/easy-dhall-nix.json new file mode 100644 index 0000000..ed7f1e3 --- /dev/null +++ b/easy-dhall-nix.json @@ -0,0 +1,7 @@ +{ + "url": "https://github.com/justinwoo/easy-dhall-nix.git", + "rev": "9bd1bea0dcebe1d1d120c0fd1ba76683dc4a62e3", + "date": "2021-07-17T15:03:24+03:00", + "sha256": "1gdx1iqhr3ih3f2v304yjnpjqydpl0x4ngrg58qa4x5wlcr5rdhl", + "fetchSubmodules": false +} diff --git a/easy-hls-nix.json b/easy-hls-nix.json new file mode 100644 index 0000000..13bd576 --- /dev/null +++ b/easy-hls-nix.json @@ -0,0 +1,11 @@ +{ + "url": "https://github.com/ssbothwell/easy-hls-nix", + "rev": "393ccab35104d5d49e0ff9eadf7b8654e87abffd", + "date": "2021-09-16T11:13:40-07:00", + "path": "/nix/store/dsfqcsiahsp9rkip4fsqzz32x0swa3d4-easy-hls-nix", + "sha256": "0q1qxlkzjqx2hvf9k2cp5a98vlvsj13lap6hm7gl1kkqp88ai1dw", + "fetchLFS": false, + "fetchSubmodules": false, + "deepClone": false, + "leaveDotGit": false +} diff --git a/rabbitmq.nix b/rabbitmq.nix new file mode 100644 index 0000000..ca5eee9 --- /dev/null +++ b/rabbitmq.nix @@ -0,0 +1,11 @@ +{ lib, config, pkgs, ... }: + +{ + services.rabbitmq = { + enable = true; + listenAddress = "0.0.0.0"; + managementPlugin.enable = true; + }; + networking.firewall.allowedTCPPorts = [ 5672 15672 ]; +} + diff --git a/reddit-pub.cabal b/reddit-pub.cabal new file mode 100644 index 0000000..329fef6 --- /dev/null +++ b/reddit-pub.cabal @@ -0,0 +1,65 @@ +cabal-version: 2.4 +name: reddit-pub +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Mats Rauhala +maintainer: mats.rauhala@iki.fi + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +library + ghc-options: -Wall + exposed-modules: MyLib + Data.Config + Data.Deriving.Aeson + Network.AMQP.Reddit + Data.SubReddit + Publish + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + , amqp + , aeson + , lens + , lens-aeson + , mtl + , text + , bytestring + , dhall + , wreq + , pipes + hs-source-dirs: src + default-language: Haskell2010 + +executable reddit-pub + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + base ^>=4.14.1.0, + reddit-pub + + hs-source-dirs: app + default-language: Haskell2010 diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..8e20efe --- /dev/null +++ b/shell.nix @@ -0,0 +1,41 @@ +{ nixpkgs ? import {} }: + +with nixpkgs; + +let + easy-dhall-nix-src = with builtins; + fetchgit { inherit (fromJSON (readFile ./easy-dhall-nix.json)) url rev sha256 fetchSubmodules; }; + easy-hls-src = fetchFromGitHub { + owner = "ssbothwell"; + repo = "easy-hls-nix"; + inherit (builtins.fromJSON (builtins.readFile ./easy-hls-nix.json)) rev sha256; + }; + easy-hls = callPackage easy-hls-src { ghcVersions = [ hp.ghc.version ]; }; + easy-dhall-nix = import easy-dhall-nix-src {}; + hp = haskellPackages.extend (self: super: { + reddit_pub = self.callPackage ./. {}; + }); + +in + +hp.shellFor { + packages = h: [h.reddit_pub]; + withHoogle = true; + buildInputs = [ + easy-dhall-nix.dhall-lsp-simple + entr + cabal-install + haskellPackages.hlint + stylish-haskell + ghcid + easy-hls + + sqlite-interactive + rrdtool + + jq + + haskellPackages.graphmod + ]; +} + diff --git a/src/Data/Config.hs b/src/Data/Config.hs new file mode 100644 index 0000000..ea8e00c --- /dev/null +++ b/src/Data/Config.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeOperators #-} +module Data.Config where + +import Control.Lens +import Data.Text (Text) +import Dhall (FromDhall, Generic, ToDhall, auto, inputFile) +import Dhall.Deriving +import Numeric.Natural (Natural) +import Data.SubReddit (SubReddit) + +data AMQP = AMQP + { amqpVhost :: Text + , amqpUsername :: Text + , amqpPassword :: Text + , amqpHost :: Text + } + deriving stock (Generic, Show) + deriving (FromDhall, ToDhall) + via (Codec (Field (CamelCase <<< DropPrefix "amqp"))) AMQP + +host :: Lens' AMQP Text +host = lens amqpHost (\ am txt -> am{amqpHost=txt}) + +vhost :: Lens' AMQP Text +vhost = lens amqpVhost (\ am txt -> am{amqpVhost=txt}) + +username :: Lens' AMQP Text +username = lens amqpUsername (\ am txt -> am{amqpUsername=txt}) + +password :: Lens' AMQP Text +password = lens amqpPassword (\ am txt -> am{amqpPassword=txt}) + +data Fetcher = Fetcher + { fetcherSubreddit :: SubReddit + , fetcherEntries :: Natural + , fetcherQualifier :: Maybe Qualifier + } + deriving stock (Show, Generic) + deriving (FromDhall, ToDhall) via Codec (Field (CamelCase <<< DropPrefix "fetcher")) Fetcher + +subreddit :: Lens' Fetcher SubReddit +subreddit = lens fetcherSubreddit (\ fe sr -> fe{fetcherSubreddit=sr}) + +entries :: Lens' Fetcher Natural +entries = lens fetcherEntries (\ fe nat -> fe{fetcherEntries=nat}) + +data Qualifier = Top | Controversial + deriving stock (Show, Generic) + deriving (FromDhall, ToDhall) via Codec (Constructor TitleCase) Qualifier + +data Config = Config + { configAmqp :: AMQP + , configFetchers :: [Fetcher] + } + deriving stock (Generic, Show) + deriving (FromDhall, ToDhall) + via (Codec (Field (CamelCase <<< DropPrefix "config"))) Config + +amqp :: Lens' Config AMQP +amqp = lens configAmqp (\ con am -> con{configAmqp=am}) + +fetchers :: Lens' Config [Fetcher] +fetchers = lens configFetchers (\ con fes -> con{configFetchers=fes}) + +readConfig :: FilePath -> IO Config +readConfig = inputFile auto diff --git a/src/Data/Deriving/Aeson.hs b/src/Data/Deriving/Aeson.hs new file mode 100644 index 0000000..10d5727 --- /dev/null +++ b/src/Data/Deriving/Aeson.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Deriving.Aeson + ( AesonCodec(..) + , type (<<<) + , Field + , CamelCase + , DropPrefix + ) + where + +import Control.Lens +import Data.Aeson +import qualified Data.Text.Strict.Lens as T +import Dhall.Deriving +import GHC.Generics (Generic, Rep) + +newtype AesonCodec codec a = AesonCodec a + +class ModifyAesonOptions a where + modifyAesonOptions :: Options -> Options + +instance (ModifyAesonOptions f, ModifyAesonOptions g) => ModifyAesonOptions (f <<< g) where + modifyAesonOptions = modifyAesonOptions @f . modifyAesonOptions @g + +instance TextFunction f => ModifyAesonOptions (Field f) where + modifyAesonOptions opts = opts{fieldLabelModifier = over T.packed (textFunction @f) } + +instance (Generic a, ModifyAesonOptions codec, GToJSON' Value Zero (Rep a)) + => ToJSON (AesonCodec codec a) where + toJSON (AesonCodec a) = + genericToJSON (modifyAesonOptions @codec defaultOptions) a + +instance (ModifyAesonOptions codec, Generic a, GFromJSON Zero (Rep a)) + => FromJSON (AesonCodec codec a) where + parseJSON va = + AesonCodec <$> genericParseJSON (modifyAesonOptions @codec defaultOptions) va diff --git a/src/Data/SubReddit.hs b/src/Data/SubReddit.hs new file mode 100644 index 0000000..2d0d1a8 --- /dev/null +++ b/src/Data/SubReddit.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DerivingVia #-} +module Data.SubReddit where + +import Dhall (FromDhall, ToDhall) + +newtype SubReddit = SubReddit { getSubReddit :: String } + deriving Show + deriving (FromDhall, ToDhall) via String + diff --git a/src/MyLib.hs b/src/MyLib.hs new file mode 100644 index 0000000..4b3cf9f --- /dev/null +++ b/src/MyLib.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module MyLib (someFunc) where + +import Control.Exception (bracket) +import Control.Lens +import Data.Config +import qualified Data.Text.Strict.Lens as T +import Network.AMQP +import Network.AMQP.Reddit (publishEntries) +import Network.Wreq.Session (newSession) +import Data.Text (Text) +import qualified Data.ByteString.Lazy as LB +import Control.Monad (void) +import qualified Data.Aeson as A +import Data.Functor.Contravariant ((>$<)) +import Publish (Publish(..)) +import Data.Foldable (for_) + + +amqpPublisher :: Channel -> Text -> Publish IO LB.ByteString +amqpPublisher channel exchange = Publish $ \lbs -> void $ publishMsg channel exchange "" (message lbs) + where + message lbs = newMsg + { msgBody = lbs + , msgDeliveryMode = Just Persistent + } + +someFunc :: IO () +someFunc = do + conf <- readConfig "./config.dhall" + let connect = openConnection + (conf ^. amqp . host . T.unpacked) + (conf ^. amqp . vhost) + (conf ^. amqp . username) + (conf ^. amqp . password) + bracket connect closeConnection $ \conn -> do + putStrLn "Hello" + chan <- openChannel conn + declareExchange chan newExchange { exchangeName = "reddit_posts", exchangeType = "fanout" } + sess <- newSession + let encoder = amqpPublisher chan "reddit_posts" + for_ (conf ^. fetchers) $ \fetcher -> do + print fetcher + publishEntries (A.encode >$< encoder) sess fetcher diff --git a/src/Network/AMQP/Reddit.hs b/src/Network/AMQP/Reddit.hs new file mode 100644 index 0000000..18e65fd --- /dev/null +++ b/src/Network/AMQP/Reddit.hs @@ -0,0 +1,61 @@ +{-# 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) diff --git a/src/Publish.hs b/src/Publish.hs new file mode 100644 index 0000000..3b3e357 --- /dev/null +++ b/src/Publish.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DerivingVia #-} +module Publish where + +import Data.Functor.Contravariant + +newtype Publish m a = Publish { publish :: a -> m () } + deriving Contravariant via (Op (m ()))