{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | -- Module : Network.Reddit.Types.Subreddit -- Copyright : (c) 2021 Rory Tyler Hayford -- License : BSD-3-Clause -- Maintainer : rory.hayford@protonmail.com -- Stability : experimental -- Portability : GHC -- module Network.Reddit.Subreddit ( -- * Actions getSubreddit , getSubredditRules , getPostRequirements , getHotSubmissions , getNewSubmissions , getRandomRisingSubmissions , getControversialSubmissions , getRisingSubmissions , getTopSubmissions , getRandomSubmission , getStickiedSubmission , subscribe , unsubscribe , quarantineOptIn , quarantineOptOut -- * Subreddit @Listing@s -- | These actions return @Listing@s of subreddits site-wide -- corresponding to various filters , getDefaultSubreddits , getNewSubreddits , getPopularSubreddits , getPremiumSubreddits , getGoldSubreddits , searchSubreddits , searchSubredditsByName , getRecommendedSubreddits , followCollection , unfollowCollection -- * Collections , getCollections , getCollectionsWithName , getCollection , getCollectionByPermalink -- * Flair , getUserFlairTemplates , getSubmissionFlairTemplates , getNewSubmissionFlairChoices , getUserFlairChoices , getSubmissionFlairChoices -- * Wiki , getWikiPage , getWikiPages , getWikiPageRevision , getWikiPageRevisions , editWikiPage , createWikiPage -- * Widgets , getSubredditWidgets , getAllSubredditWidgets -- * Emojis , getSubredditEmojis -- * Types , module M ) where import Control.Monad.Catch ( MonadCatch(catch) , MonadThrow(throwM) ) import Data.Aeson ( FromJSON ) import Data.ByteString ( ByteString ) import Data.Generics.Wrapped ( wrappedTo ) import Data.Maybe ( fromMaybe ) import Data.Sequence ( Seq((:<|)) ) import Data.Text ( Text ) import qualified Data.Text.Encoding as T import Lens.Micro ( (&), (<&>) ) import qualified Network.HTTP.Client.Conduit as H import Network.Reddit.Internal import Network.Reddit.Types import Network.Reddit.Types.Emoji import Network.Reddit.Types.Emoji as M ( Emoji(Emoji) , EmojiName , mkEmoji , mkEmojiName ) import Network.Reddit.Types.Flair import Network.Reddit.Types.Flair as M ( AssignedFlair(AssignedFlair) , CSSClass , CurrentUserFlair , FlairChoice(FlairChoice) , FlairChoiceList , FlairContent(..) , FlairID , FlairList(FlairList) , FlairResult(FlairResult) , FlairSelection(FlairSelection) , FlairTemplate(FlairTemplate) , FlairText , FlairType(..) , ForegroundColor(..) , PostedFlairTemplate , UserFlair(UserFlair) , defaultFlairTemplate , flairlistToListing , mkFlairText ) import Network.Reddit.Types.Item import Network.Reddit.Types.Submission import Network.Reddit.Types.Subreddit import Network.Reddit.Types.Subreddit as M ( BodyRestriction(..) , NewSubredditRule(NewSubredditRule) , PostRequirements(PostRequirements) , PostedSubredditRule , RuleType(..) , Subreddit(Subreddit) , SubredditID(SubredditID) , SubredditName , SubredditRule(SubredditRule) , mkSubredditName ) import Network.Reddit.Types.Widget import Network.Reddit.Types.Widget as M ( Button(..) , ButtonHover(..) , ButtonImage(ButtonImage) , ButtonText(ButtonText) , ButtonWidget(ButtonWidget) , CalendarConfig(CalendarConfig) , CalendarWidget(CalendarWidget) , CommunityInfo(CommunityInfo) , CommunityListWidget(CommunityListWidget) , CustomWidget(CustomWidget) , IDCardWidget(IDCardWidget) , Image(Image) , ImageData(ImageData) , ImageHover(ImageHover) , ImageWidget(ImageWidget) , MenuChild(..) , MenuLink(MenuLink) , MenuWidget(MenuWidget) , ModInfo(ModInfo) , ModeratorsWidget(ModeratorsWidget) , PostFlairInfo(PostFlairInfo) , PostFlairWidget(PostFlairWidget) , PostFlairWidgetDisplay(..) , RulesDisplay(..) , RulesWidget(RulesWidget) , ShortName , Submenu(Submenu) , SubredditWidgets(SubredditWidgets) , TextAreaWidget(TextAreaWidget) , TextHover(TextHover) , Widget(..) , WidgetID(WidgetID) , WidgetSection(..) , WidgetStyles(WidgetStyles) , defaultCalendarConfig , mkCommunityInfo , mkPostFlairWidget , mkShortName , mkTextAreaWidget ) import Network.Reddit.Types.Wiki as M ( WikiPage(WikiPage) , WikiPageListing , WikiPageName , WikiPageSettings(WikiPageSettings) , WikiPermLevel(..) , WikiRevision(WikiRevision) , WikiRevisionID , mkWikiPageName ) import Network.Reddit.Utils import Web.FormUrlEncoded ( Form ) import Web.HttpApiData ( ToHttpApiData(..) ) import Web.Internal.FormUrlEncoded ( ToForm(toForm) ) -- | Get information about a 'Subreddit'. An 'ErrorWithStatus' will be thrown if -- attempting to query information on banned or private 'Subreddit's getSubreddit :: MonadReddit m => SubredditName -> m Subreddit getSubreddit sname = catchEmptyListing $ runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "about" ] } -- | Get a 'Subreddit'\'s 'SubredditRule's getSubredditRules :: MonadReddit m => SubredditName -> m (Seq SubredditRule) getSubredditRules sname = runAction @RuleList r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "about", "rules" ] } -- | Get the requirements that moderators have configured for all submissions on -- the given subreddit getPostRequirements :: MonadReddit m => SubredditName -> m PostRequirements getPostRequirements sname = runAction defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "post_requirements" ] } getHotSubmissions, getNewSubmissions, getRandomRisingSubmissions :: MonadReddit m => SubredditName -> Paginator SubmissionID Submission -> m (Listing SubmissionID Submission) -- | Get \"hot\" 'Submission's for a given 'Subreddit' getHotSubmissions = submissions "hot" -- | Get \"new\" 'Submission's for a given 'Subreddit' getNewSubmissions = submissions "new" getControversialSubmissions, getRisingSubmissions, getTopSubmissions :: MonadReddit m => SubredditName -> Paginator SubmissionID Submission -> m (Listing SubmissionID Submission) -- | Get \"controversial\" 'Submission's for a given 'Subreddit' getControversialSubmissions = submissions "controversial" -- | Get \"rising\" 'Submission's for a given 'Subreddit' getRisingSubmissions = submissions "rising" -- | Get \"top\" 'Submission's for a given 'Subreddit' getTopSubmissions = submissions "top" -- | Get \"rising\" 'Submission's for a given 'Subreddit' getRandomRisingSubmissions = submissions "randomrising" submissions :: (MonadReddit m, Thing a, FromJSON a) => Text -> SubredditName -> Paginator a Submission -> m (Listing a Submission) submissions txt sname paginator = runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, txt ] , requestData = paginatorToFormData paginator } -- | Get a random submission from the subreddit. The sub must support this feature, -- or an 'ErrorWithStatus' exception will be thrown getRandomSubmission :: MonadReddit m => SubredditName -> m Submission getRandomSubmission sname = catchRedirected "getRandomSubmission" action handler where action = runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "random" ] , followRedirects = False } handler ps = runAction @[Listing ItemID Item] defaultAPIAction { pathSegments = T.decodeUtf8 <$> ps, needsAuth = False } -- | Get one of the stickied submission, optionally specifying its position in the -- sticky list, returning the top one otherwise. Note that this will throw an -- 'ErrorWithStatus' if the sub does not have any stickied submissions getStickiedSubmission :: MonadReddit m => Maybe Word -- ^ Which sticky to fetch. 1 is at the top of the sticky list, and is -- the default if this param is @Nothing@ -> SubredditName -> m Submission getStickiedSubmission num sname = catchRedirected "getStickiedSubmission" action handler where action = runAction defaultAPIAction { pathSegments = subAboutPath sname "sticky" , followRedirects = False , requestData = mkTextFormData [ ( "num" , toQueryParam $ fromMaybe 1 num ) ] } handler ps = runAction @[Listing ItemID Item] defaultAPIAction { pathSegments = T.decodeUtf8 <$> ps, needsAuth = False } -- HACK -- This is a mega-hack to deal with how Reddit deals with the absence or -- presence of certain subreddit features, like random and stickied -- submissions catchRedirected :: MonadCatch m => Text -> m Submission -> ([ByteString] -> m [Listing t Item]) -> m Submission catchRedirected func action handler = catch @_ @APIException action $ \case Redirected (Just req) -> case req & H.path & splitPath of [ r@"r", sub, c@"comments", path, t, j@".json" ] -> handler [ r, sub, c, path, t, j ] >>= \case Listing { children } : _ -> handleChildren children _ -> noResults _ -> throwM . InvalidResponse $ func <> ": Could not parse redirect URL" e -> throwM e where noResults = throwM . InvalidResponse $ func <> ": No results" handleChildren = \case SubmissionItem s :<| _ -> pure s _ -> noResults -- | Subscribe to a single subreddit subscribe :: MonadReddit m => SubredditName -> m () subscribe sname = runAction_ defaultAPIAction { pathSegments = [ "api", "subscribe" ] , method = POST , requestData = mkTextFormData [ ("sr_name", toQueryParam sname) , ("action", "sub") , ( "skip_initial_defaults" , toQueryParam True ) ] } -- | Unsubscribe from a single subreddit unsubscribe :: MonadReddit m => SubredditName -> m () unsubscribe sname = runAction_ defaultAPIAction { pathSegments = [ "api", "subscribe" ] , method = POST , requestData = mkTextFormData [ ("sr_name", toQueryParam sname) , ("action", "unsub") ] } -- | Allow the authenticated user to access the quarantined subreddit quarantineOptIn :: MonadReddit m => SubredditName -> m () quarantineOptIn = quarantineOpt "quarantine_opt_in" -- | Disallow the authenticated user from accessing the quarantined subreddit quarantineOptOut :: MonadReddit m => SubredditName -> m () quarantineOptOut = quarantineOpt "quarantine_opt_out" quarantineOpt :: MonadReddit m => PathSegment -> SubredditName -> m () quarantineOpt path sname = runAction_ defaultAPIAction { pathSegments = [ "api", path ] , method = POST , requestData = mkTextFormData [ ("sr_name", toQueryParam sname) ] } getDefaultSubreddits, getNewSubreddits, getPopularSubreddits :: MonadReddit m => Paginator SubredditID Subreddit -> m (Listing SubredditID Subreddit) -- | Get a @Listing@ of the default 'Subreddit's getDefaultSubreddits = subredditListing "default" -- | Get a @Listing@ of new 'Subreddit's site-wide getNewSubreddits = subredditListing "new" -- | Get a @Listing@ of popular 'Subreddit's site-wide getPopularSubreddits = subredditListing "popular" getPremiumSubreddits, getGoldSubreddits :: MonadReddit m => Paginator SubredditID Subreddit -> m (Listing SubredditID Subreddit) -- | Get a @Listing@ of premium-only 'Subreddit's getPremiumSubreddits = subredditListing "premium" -- | Same as 'getPremiumSubreddits', provided for compatibility purposes getGoldSubreddits = getPremiumSubreddits -- | Search through subreddits based on both their names and descriptions searchSubreddits :: MonadReddit m => Text -> Paginator SubredditID Subreddit -> m (Listing SubredditID Subreddit) searchSubreddits query paginator = runAction defaultAPIAction { pathSegments = [ "subreddits", "search" ] , requestData = WithForm $ toForm paginator <> mkTextForm [ ("q", query) ] } -- | Search through subreddits based on both their names searchSubredditsByName :: MonadReddit m => Maybe Bool -- ^ If NSWF subreddits should be included, defaulting to @True@ if @Nothing@ -> Maybe Bool -- ^ Only exactly match the query, defaulting to @False@ if @Nothing@ -> Text -> m (Seq SubredditName) searchSubredditsByName withNSFW exact query = runAction @NameSearchResults r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "search_reddit_names" ] , method = POST , requestData = mkTextFormData [ ("query", query) , ("exact", toQueryParam $ fromMaybe False exact) , ( "include_over_18" , toQueryParam $ fromMaybe True withNSFW ) ] } -- | Get a list of recommended subreddits based on the provided subs. Subreddits -- to exclude from the recommendation may optionally be provided. -- -- __Note__: Unfortunately, as of this writing, this action appears to only -- return an empty array for all inputs getRecommendedSubreddits :: (MonadReddit m, Foldable t) => Maybe (t SubredditName) -- ^ Subreddits to omit from the result -> t SubredditName -- ^ Subreddits to base the recommendations on -> m (Seq SubredditName) getRecommendedSubreddits omit snames = runAction @RecsList r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "recommend", "sr", joinParams snames ] , requestData = mkTextFormData [ ("omit", maybe mempty joinParams omit) ] } subredditListing :: MonadReddit m => PathSegment -> Paginator SubredditID Subreddit -> m (Listing SubredditID Subreddit) subredditListing path paginator = runAction defaultAPIAction { pathSegments = [ "subreddits", path ] , requestData = paginatorToFormData paginator } -- | Get the 'Collection's of a subreddit, given the sub ID. Collections obtained -- through this action will not have the @sortedLinks@ field -- -- __Note__: if you don't know the ID of the subreddit, you can use -- 'getNamedCollections', although this incurs an additional -- network request to get the ID from the name getCollections :: MonadReddit m => SubredditID -> m (Seq Collection) getCollections sid = runAction defaultAPIAction { pathSegments = collectionsPath "subreddit_collections" , requestData = mkTextFormData [ ("sr_fullname", fullname sid) ] } -- | Get the 'Collection's of a subreddit, given the name of the sub. Collections -- obtained through this action will not have the @sortedLinks@ field -- -- __Note__: this incurs a greater overhead than 'getCollections', -- which you may want to use if you already know the @subredditID@ getCollectionsWithName :: MonadReddit m => SubredditName -> m (Seq Collection) getCollectionsWithName sname = do Subreddit { subredditID } <- getSubreddit sname getCollections subredditID -- | Fetch the specifig 'Collection', given its ID. This includes its @sortedLinks@ getCollection :: MonadReddit m => CollectionID -> m Collection getCollection cid = catch @_ @APIException action $ \case -- An invalid UUID will cause Reddit to return an empty JSON array ErrorWithMessage EmptyError -> throwM . ErrorWithStatus $ StatusMessage 404 "getCollection: Collection does not exist" e -> throwM e where action = runAction defaultAPIAction { pathSegments = collectionsPath "collection" , requestData = mkTextFormData [ ("collection_id", cid) , ("include_links", "true") ] } -- | Get a 'Collection' given its @permalink@. This includes its @sortedLinks@ -- -- Permalink URLs should be of the form -- https:\/\/{www.}reddit.com\/r/\\/collections\/\ getCollectionByPermalink :: MonadReddit m => URL -> m Collection getCollectionByPermalink pl = splitURL pl >>= \case (_, [ "r", _, "collection", cid ]) -> getCollection cid _ -> throwM $ InvalidRequest "getCollectionByPermalink: invalid permalink provided" -- | Follow the collection for the authenticated user followCollection :: MonadReddit m => CollectionID -> m () followCollection = followUnfollow True -- | Unfollow the collection for the authenticated user unfollowCollection :: MonadReddit m => CollectionID -> m () unfollowCollection = followUnfollow False followUnfollow :: MonadReddit m => Bool -> CollectionID -> m () followUnfollow follow cid = runAction_ defaultAPIAction { pathSegments = collectionsPath "follow_collection" , method = POST , requestData = mkTextFormData [ ("collection_id", cid) , ("follow", toQueryParam follow) ] } collectionsPath :: PathSegment -> [PathSegment] collectionsPath path = [ "api", "v1", "collections", path ] -- | Get the user 'FlairTemplate's on the given subreddit. This will throw an -- 'APIException' ('ErrorWithStatus') if the sub does not allow users to set -- their own flair and the authenticated user does not have mod privileges on -- the sub getUserFlairTemplates :: MonadReddit m => SubredditName -> m (Seq FlairTemplate) getUserFlairTemplates = v2Flair "user" -- | Get the submission 'FlairTemplate's on the given subreddit getSubmissionFlairTemplates :: MonadReddit m => SubredditName -> m (Seq FlairTemplate) getSubmissionFlairTemplates = v2Flair "link" v2Flair :: MonadReddit m => Text -> SubredditName -> m (Seq FlairTemplate) v2Flair path sname = runAction defaultAPIAction { pathSegments = subAPIPath sname $ path <> "_flair_v2" } -- | Get the available 'FlairChoice's for new submissions on the given subreddit getNewSubmissionFlairChoices :: MonadReddit m => SubredditName -> m (Seq FlairChoice) getNewSubmissionFlairChoices = flairChoices (mkTextForm [ ("is_newlink", toQueryParam True) ]) -- | Get the available 'FlairChoice's for a particular submission on the given -- subreddit getSubmissionFlairChoices :: MonadReddit m => SubredditName -> SubmissionID -> m (Seq FlairChoice) getSubmissionFlairChoices sname sid = flairChoices form sname where form = mkTextForm [ ("link", fullname sid) ] -- | Get the available 'FlairChoice's for new submissions on the current subreddit getUserFlairChoices :: MonadReddit m => SubredditName -> m (Seq FlairChoice) getUserFlairChoices = flairChoices (mkTextForm mempty) flairChoices :: MonadReddit m => Form -> SubredditName -> m (Seq FlairChoice) flairChoices form sname = runAction @FlairChoiceList r <&> wrappedTo where r = defaultAPIAction { pathSegments = subAPIPath sname "flairselector" , method = POST , requestData = WithForm form } -- | Get the subreddit 'WikiPage' specified by name getWikiPage :: MonadReddit m => SubredditName -> WikiPageName -> m WikiPage getWikiPage sname wpage = runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "wiki", toUrlPiece wpage ] } -- | Get all of the 'WikiPage's on the subreddit wiki getWikiPages :: MonadReddit m => SubredditName -> m (Seq WikiPageName) getWikiPages sname = runAction @WikiPageListing r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "wiki", "pages" ] } -- | Get a specific revision of a 'WikiPage', specified by name and 'WikiRevisionID' getWikiPageRevision :: MonadReddit m => SubredditName -> WikiPageName -> WikiRevisionID -> m WikiPage getWikiPageRevision sname wpage wr = runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "wiki", toUrlPiece wpage ] , requestData = mkTextFormData [ ("v", toQueryParam wr) ] } -- | Get a 'Listing' of the 'WikiRevision's for a given wikipage getWikiPageRevisions :: MonadReddit m => SubredditName -> WikiPageName -> Paginator WikiRevisionID WikiRevision -> m (Listing WikiRevisionID WikiRevision) getWikiPageRevisions sname wpage paginator = runAction defaultAPIAction { pathSegments = [ "r" , toUrlPiece sname , "wiki" , "revisions" , toUrlPiece wpage ] , requestData = paginatorToFormData paginator } -- | Edit the given wikipage, replacing its contents with the new contents provided. -- This requires moderator privileges or editing privileges for the page in question. -- If the page corresponding to the given name does not exist, it will be created editWikiPage :: MonadReddit m => SubredditName -> WikiPageName -> Maybe Text -- ^ The reason for the edit, if any -> Body -- ^ The new content for the page -> m () editWikiPage sname wpage r txt = runAction_ defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "api", "wiki", "edit" ] , method = POST , requestData = mkTextFormData $ [ ("page", toQueryParam wpage), ("content", txt) ] <> foldMap pure (("reason", ) <$> r) } -- | Create a new wikipage. If a page with the given name already exists, its -- contents will be replaced createWikiPage :: MonadReddit m => SubredditName -> WikiPageName -> Maybe Text -- ^ The reason for creating the page, if any -> Body -- ^ The new content for the page -> m () createWikiPage = editWikiPage -- | Get a given subreddit\'s widgets getSubredditWidgets :: MonadReddit m => SubredditName -> m SubredditWidgets getSubredditWidgets sname = catchEmptyListing $ runAction defaultAPIAction { pathSegments = subAPIPath sname "widgets" } -- | Get all of a subreddit\'s 'Widget's as a non-hierarchical list getAllSubredditWidgets :: MonadReddit m => SubredditName -> m (Seq Widget) getAllSubredditWidgets sname = catchEmptyListing $ runAction @WidgetList r <&> wrappedTo where r = defaultAPIAction { pathSegments = subAPIPath sname "widgets" } -- | Get all of the emojis for the given subreddit. Note that this does not include -- the builtin \"snoomojis\" getSubredditEmojis :: MonadReddit m => SubredditName -> m (Seq Emoji) getSubredditEmojis sname = runAction @EmojiList r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "emojis", "all" ] }