{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Network.Reddit.Moderation -- Copyright : (c) 2021 Rory Tyler Hayford -- License : BSD-3-Clause -- Maintainer : rory.hayford@protonmail.com -- Stability : experimental -- Portability : GHC -- -- Actions related to moderation. Assume that each action in this module requires -- moderator privileges, unless stated otherwise -- module Network.Reddit.Moderation ( -- * Item moderation -- | These actions work on 'Item's, i.e either 'Comment's or 'Submission's. -- This module also exports variants that take unwrapped 'SubmissionID's -- and 'CommentID's to work with just one type of item (see below) distinguishItem , undistinguishItem , removeItem , sendRemovalMessage , approveItem , lockItem , unlockItem , ignoreItemReports , unignoreItemReports -- ** Removal reasons , getRemovalReasons , createRemovalReason , updateRemovalReason , deleteRemovalReason -- ** Moderation listings -- | Each of these retrieves a @Listing ItemID ModItem@. You can constrain -- the type of reports by passing the appropriate 'ItemType' to the -- paginator options , getReports , getModqueue , getSpam , getEdited , getUnmoderated , getModlog -- ** Submission moderation -- | Includes re-exports from "Network.Reddit.Submission" , distinguishSubmission , undistinguishSubmission , approveSubmission , lockSubmission , unlockSubmission , ignoreSubmissionReports , unignoreSubmissionReports , unmarkNSFW , markNSFW , setOC , unsetOC , setSpoiler , unsetSpoiler , stickySubmission , unstickySubmission , setSuggestedSort -- ** Comment moderation , showComment , distinguishComment , undistinguishComment , approveComment , lockComment , unlockComment , ignoreCommentReports , unignoreCommentReports -- ** Collections moderation , createCollection , deleteCollection , addSubmissionToCollection , removeSubmissionFromCollection , reorderCollection , updateCollectionDescription , updateCollectionTitle -- * Subreddit relationships -- ** Moderators , getModerators , getModerator , updateModerator , removeModerator , abdicateModerator -- ** Mod invitations , inviteModerator , inviteModeratorWithPerms , getInvitees , getInvitee , updateInvitation , revokeInvitation , acceptInvitation -- ** Contributors , getContributors , getContributor , addContributor , removeContributor , abdicateContributor , getWikiContributors , getWikiContributor , addWikiContributor , removeWikiContributor -- ** Bans , getBans , getBan , banUser , unbanUser , getWikibans , getWikiban , wikibanUser , wikiUnbanUser , getMuted , getMutedUser , unmuteUser , muteUser -- * Subreddit settings , getSubredditSettings , setSubredditSettings -- * Subreddit rules -- | To get a list of the current rules for a Subreddit, -- an action which does not require moderator privileges, -- see 'Network.Reddit.Actions.Subreddit.getSubredditRules'. -- Also note that a subreddit may only configure up to 15 -- individual rules at a time, and that trying to add more may -- raise an exception , addSubredditRule , deleteSubredditRule , updateSubredditRule , reorderSubredditRules -- * Flair , configureSubredditFlair , getFlairList , getUserFlair , setUserFlair , setUserFlairs , deleteUserFlair , createFlairTemplate , updateFlairTemplate , createUserFlairTemplate , createSubmissionFlairTemplate , updateSubmissionFlairTemplate , updateUserFlairTemplate , deleteFlairTemplate , clearUserFlairTemplates , clearSubmissionFlairTemplates , clearFlairTemplates -- * Stylesheets, images and widgets , getStylesheet , updateStylesheet -- ** Images -- | Reddit only allows JPEG or PNG images in stylsheets, and further requires -- that all -- uploaded images be less than 500Kb in size. Each action that -- uploads an image file to stylesheets validates both of these constraints, -- throwing a 'ClientException' in the event that they are not satisfied. -- -- Note that most of the actions that delete images will appear to succeed -- even if the named image does not exists , uploadImage , uploadHeader , uploadMobileIcon , uploadMobileHeader , deleteImage , deleteHeader , deleteMobileIcon , uploadBanner , deleteBanner , uploadBannerAdditional , deleteBannerAdditional , uploadBannerHover , deleteBannerHover -- * Wiki , addWikiEditor , removeWikiEditor , getWikiPageSettings , revertWikiPage -- * Modmail , getModmail , getModmailWithOpts , getModmailConversation , getUnreadModmailCount , replyToConversation , archiveConversation , unarchiveConversation , highlightConversation , unhighlightConversation , markConversationsRead , markConversationRead , markConversationsUnread , markConversationUnread , bulkReadConversations , muteModmailUser , unmuteModmailUser , createConversation -- * Widgets , deleteWidget , updateWidget , reorderWidgets , addButtonWidget , addCalendarWidget , addCommunityListWidget , addCustomWidget , addImageWidget , addMenuWidget , addPostFlairWidget , addTextAreaWidget , uploadWidgetImage -- * Emoji , addEmoji , deleteEmoji , updateEmoji , setCustomEmojiSize -- * Misc , getTraffic -- * Types , module M ) where import Conduit ( (.|) , runConduit , withSourceFile ) import Control.Monad ( void, when ) import Control.Monad.Catch ( MonadCatch(catch) , MonadThrow(throwM) ) import Data.Aeson ( FromJSON , KeyValue((.=)) , ToJSON(toJSON) , Value(..) ) import Data.Bifunctor ( Bifunctor(bimap) ) import Data.Bool ( bool ) import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as LB import Data.Conduit.Binary ( sinkLbs ) import qualified Data.Foldable as F import Data.Foldable ( for_ ) import Data.Generics.Wrapped import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HM import Data.Ix ( Ix(inRange) ) import Data.List.Split ( chunksOf ) import Data.Maybe ( fromMaybe ) import Data.Sequence ( Seq((:<|)) ) import qualified Data.Text as T import Data.Text ( Text ) import qualified Data.Text.Encoding as T import Lens.Micro import Network.HTTP.Client.MultipartFormData ( partBS, partFile ) import Network.Reddit.Internal import Network.Reddit.Submission import Network.Reddit.Types import Network.Reddit.Types.Account import Network.Reddit.Types.Comment import Network.Reddit.Types.Emoji import Network.Reddit.Types.Flair import Network.Reddit.Types.Flair as M ( FlairConfig(FlairConfig) , FlairPosition(..) , defaultFlairConfig ) import Network.Reddit.Types.Item import Network.Reddit.Types.Moderation import Network.Reddit.Types.Moderation as M ( Ban(Ban) , BanNotes(BanNotes) , ContentOptions(..) , CrowdControlLevel(..) , LanguageCode(..) , ModAccount(ModAccount) , ModAction(ModAction) , ModActionID , ModActionOpts(ModActionOpts) , ModActionType(..) , ModInvitee(ModInvitee) , ModInviteeList(ModInviteeList) , ModItem(..) , ModItemOpts(ModItemOpts) , ModPermission(..) , Modmail(Modmail) , ModmailAuthor(ModmailAuthor) , ModmailConversation(ModmailConversation) , ModmailID , ModmailMessage(ModmailMessage) , ModmailObjID(ModmailObjID) , ModmailOpts(ModmailOpts) , ModmailReply(ModmailReply) , ModmailSort(..) , ModmailState(..) , MuteID(MuteID) , MuteInfo(MuteInfo) , NewConversation(NewConversation) , NewRemovalReasonID , RelID(RelID) , RelInfo(RelInfo) , RelInfoOpts(RelInfoOpts) , RemovalMessage(RemovalMessage) , RemovalReason(RemovalReason) , RemovalReasonID , RemovalType(..) , S3ModerationLease(S3ModerationLease) , SpamFilter(..) , StructuredStyleImage(..) , StyleImageAlignment(..) , Stylesheet(Stylesheet) , SubredditImage(SubredditImage) , SubredditRelationship(..) , SubredditSettings(SubredditSettings) , SubredditType(..) , Traffic(Traffic) , TrafficStat(TrafficStat) , Wikimode(..) , defaultModmailOpts , mkModmailReply ) import Network.Reddit.Types.Subreddit import Network.Reddit.Types.Widget import Network.Reddit.Types.Wiki import Network.Reddit.Utils import qualified System.FilePath as FP import Web.FormUrlEncoded ( Form , ToForm(toForm) ) import Web.HttpApiData ( ToHttpApiData(..) ) --Item moderation-------------------------------------------------------------- -- | Distinguish an item. See 'distinguishComment' for further comment-specific -- options distinguishItem :: MonadReddit m => Distinction -> ItemID -> m () distinguishItem how iid = runAction_ defaultAPIAction { pathSegments = [ "api", "distinguish" ] , method = POST , requestData = mkTextFormData [ ("id", fullname iid) , ("how", toQueryParam how) ] } -- | Remove the distinction from an item, also removing the sticky flag -- for top-level comments undistinguishItem :: MonadReddit m => ItemID -> m () undistinguishItem = distinguishItem Undistinguished -- | Remove an item from the subreddit with an optional note to other mods. -- Setting the @isSpam@ parameter to @True@ will entirely remove the item -- from subreddit listings removeItem :: MonadReddit m => Maybe Body -- ^ A note for other mods. This is sent in second request -- if @Just@ -> Bool -- ^ Spam flag. Will remove the item from all listings if @True@ -> ItemID -> m () removeItem note isSpam iid = do runAction_ defaultAPIAction { pathSegments = [ "api", "remove" ] , method = POST , requestData = mkTextFormData [ ("id", fullname iid) , ("spam", toQueryParam isSpam) ] } for_ note $ \n -> runAction_ defaultAPIAction { pathSegments = [ "api", "v1", "modactions", "removal_reasons" ] , method = POST , requestData = mkTextFormData [ ( "json" , textObject [ "item_ids" .= [ fullname iid ] , "mod_note" .= n ] ) ] } -- | Send a removal message for an item. The precise action depends on the form -- of 'RemovalType' sendRemovalMessage :: MonadReddit m => RemovalMessage -> m () sendRemovalMessage rm@RemovalMessage { .. } = runAction_ defaultAPIAction { pathSegments = [ "api", "v1", "modactions" ] <> [ getPath ] , method = POST , requestData = WithForm $ toForm rm } where getPath = case itemID of CommentItemID _ -> "removal_comment_message" SubmissionItemID _ -> "removal_link_message" approveItem, lockItem, unlockItem :: MonadReddit m => ItemID -> m () -- | Approve an item, reverting a removal and resetting its report counter approveItem = withID "approve" -- | Lock an item. See also 'unlockItem' lockItem = withID "lock" -- | Unlock an item unlockItem = withID "unlock" ignoreItemReports, unignoreItemReports :: MonadReddit m => ItemID -> m () -- | Prevent all future reports on this item from sending notifications or appearing -- in moderation listings. See also 'unignoreItemReports', which reverses this action ignoreItemReports = withID "ignore_reports" -- | Re-allow the item to trigger notifications and appear in moderation listings unignoreItemReports = withID "unignore_reports" withID :: MonadReddit m => Text -> ItemID -> m () withID path iid = runAction_ defaultAPIAction { pathSegments = [ "api", path ] , method = POST , requestData = mkTextFormData [ ("id", fullname iid) ] } -- | Get a list of 'RemovalReason's for the given subreddit getRemovalReasons :: MonadReddit m => SubredditName -> m (Seq RemovalReason) getRemovalReasons sname = runAction @RemovalReasonList r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "removal_reasons" ] } -- | Create a new 'RemovalReason', returning the 'RemovalReasonID' of the newly -- created reason createRemovalReason :: MonadReddit m => SubredditName -> Title -> Body -> m RemovalReasonID createRemovalReason sname t m = runAction @NewRemovalReasonID r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "removal_reasons" ] , method = POST , requestData = mkTextFormData [ ("title", t), ("message", m) ] } -- | Update a single 'RemovalReason' updateRemovalReason :: MonadReddit m => SubredditName -> RemovalReason -> m () updateRemovalReason sname rr@RemovalReason { .. } = runAction_ defaultAPIAction { pathSegments = [ "api" , "v1" , toUrlPiece sname , "removal_reasons" , toUrlPiece removalReasonID ] , method = PUT , requestData = WithForm $ toForm rr } -- | Delete the given removal reason deleteRemovalReason :: MonadReddit m => SubredditName -> RemovalReasonID -> m () deleteRemovalReason sname rrid = runAction_ defaultAPIAction { pathSegments = [ "api" , "v1" , toUrlPiece sname , "removal_reasons" , toUrlPiece rrid ] , method = DELETE } --Moderation listings---------------------------------------------------------- getReports, getModqueue, getSpam, getEdited, getUnmoderated :: MonadReddit m => SubredditName -> Paginator ItemID ModItem -> m (Listing ItemID ModItem) -- | Get the given subreddit\'s reported items getReports = modItems "reports" -- | Get the given subreddit\'s moderation queue getModqueue = modItems "modqueue" -- | Get the given subreddit\'s items marked as spam getSpam = modItems "spam" -- | Get the given subreddit\'s recently edited items getEdited = modItems "edited" -- | Get the given subreddit\'s unmoderated items getUnmoderated = modItems "unmoderated" modItems :: MonadReddit m => Text -> SubredditName -> Paginator ItemID ModItem -> m (Listing ItemID ModItem) modItems path sname paginator = runAction defaultAPIAction { pathSegments = subAboutPath sname path , requestData = paginatorToFormData paginator } -- | Get a log of moderator actions for the given subreddit getModlog :: MonadReddit m => SubredditName -> Paginator ModActionID ModAction -> m (Listing ModActionID ModAction) getModlog sname paginator = runAction defaultAPIAction { pathSegments = subAboutPath sname "log" , requestData = paginatorToFormData paginator } --Submission moderation-------------------------------------------------------- approveSubmission, lockSubmission, unlockSubmission :: MonadReddit m => SubmissionID -> m () -- | Approve a submission. See 'approveItem' approveSubmission = approveItem . SubmissionItemID -- | Lock a submission. See 'lockItem' lockSubmission = lockItem . SubmissionItemID -- | Unlock a submission. See 'unlockItem' unlockSubmission = unlockItem . SubmissionItemID ignoreSubmissionReports, unignoreSubmissionReports :: MonadReddit m => SubmissionID -> m () -- | Ignore reports for a submission. See 'ignoreItemReports' ignoreSubmissionReports = ignoreItemReports . SubmissionItemID -- | Resume reports for a submission. See 'unignoreItemReports' unignoreSubmissionReports = unignoreItemReports . SubmissionItemID -- | Distinguish a submission distinguishSubmission :: MonadReddit m => Distinction -> SubmissionID -> m () distinguishSubmission how = distinguishItem how . SubmissionItemID -- | Remove the distinction from a submission undistinguishSubmission :: MonadReddit m => SubmissionID -> m () undistinguishSubmission = undistinguishItem . SubmissionItemID -- | Sticky the submission in the subreddit stickySubmission :: MonadReddit m => Bool -- ^ When @True@, this will set the submission as -- the \"bottom\" sticky. Otherwise, the stickied -- submission will go to the top slot -> SubmissionID -> m () stickySubmission = stickyUnsticky True -- | Unsticky the submission in the subreddit unstickySubmission :: MonadReddit m => SubmissionID -> m () unstickySubmission = stickyUnsticky False True stickyUnsticky :: MonadReddit m => Bool -> Bool -> SubmissionID -> m () stickyUnsticky state bottom sid = runAction_ defaultAPIAction { pathSegments = [ "api", "set_subreddit_sticky" ] , method = POST , requestData = mkTextFormData $ [ ("id", fullname sid) , ("state", toQueryParam state) , ("api_type", "json") ] <> bool [ ("num", "1") ] mempty bottom } -- | Set the suggested sort order for a submission setSuggestedSort :: MonadReddit m => Maybe ItemSort -- ^ If @Nothing@, will clear the existing sort -> SubmissionID -> m () setSuggestedSort isort sid = runAction_ defaultAPIAction { pathSegments = [ "api", "set_suggested_sort" ] , method = POST , requestData = mkTextFormData [ ("id", fullname sid) , ( "sort" , maybe "blank" toQueryParam isort ) , ("api_type", "json") ] } --Comment moderation----------------------------------------------------------- -- | Distinguish aa comment. If @True@, the @sticky@ param will set the comment -- at the top of the page. This only applies to top-level comments; the flg is -- otherwise ignored distinguishComment :: MonadReddit m => Distinction -> Bool -- ^ Sticky flag -> CommentID -> m () distinguishComment how sticky cid = runAction_ defaultAPIAction { pathSegments = [ "api", "distinguish" ] , method = POST , requestData = mkTextFormData [ ("id", fullname cid) , ("how", toQueryParam how) , ("sticky", toQueryParam sticky) ] } -- | Undistinguish a comment, also removing its sticky flag if applicable undistinguishComment :: MonadReddit m => CommentID -> m () undistinguishComment = undistinguishItem . CommentItemID approveComment, lockComment, unlockComment :: MonadReddit m => CommentID -> m () -- | Approve a comment. See 'approveItem' approveComment = approveItem . CommentItemID -- | Lock a comment. See 'lockItem' lockComment = lockItem . CommentItemID -- | Unlock a comment. See 'unlockItem' unlockComment = unlockItem . CommentItemID ignoreCommentReports, unignoreCommentReports :: MonadReddit m => CommentID -> m () -- | Ignore reports for a comment. See 'ignoreItemReports' ignoreCommentReports = ignoreItemReports . CommentItemID -- | Resume reports for a comment. See 'unignoreItemReports' unignoreCommentReports = unignoreItemReports . CommentItemID -- | Show a comment that has been \"collapsed\" by crowd-control showComment :: MonadReddit m => CommentID -> m () showComment cid = runAction_ defaultAPIAction { pathSegments = [ "api", "show_comment" ] , method = POST , requestData = mkTextFormData [ ("id", fullname cid) ] } -- | Create a new collection, returning the new 'Collection' upon success createCollection :: MonadReddit m => NewCollection -> m Collection createCollection nc = runAction defaultAPIAction { pathSegments = collectionsPath "create_collection" , method = POST , requestData = WithForm $ toForm nc } -- | Delete the entire collection from the subreddit deleteCollection :: MonadReddit m => CollectionID -> m () deleteCollection cid = runAction_ defaultAPIAction { pathSegments = collectionsPath "delete_collection" , method = POST , requestData = mkTextFormData [ ("collection_id", cid) ] } -- | Add a submission to a collection addSubmissionToCollection :: MonadReddit m => CollectionID -> SubmissionID -> m () addSubmissionToCollection = collectionAddRemove "add_post_to_collection" -- | Remove a submission from a collection removeSubmissionFromCollection :: MonadReddit m => CollectionID -> SubmissionID -> m () removeSubmissionFromCollection = collectionAddRemove "remove_post_in_collection" -- | Reorder the submissions that comprise the collection by providing a -- container of 'SubmissionID's in the new intended order reorderCollection :: (MonadReddit m, Foldable t) => CollectionID -> t SubmissionID -> m () reorderCollection cid ss = runAction_ defaultAPIAction { pathSegments = collectionsPath "reorder_collection" , method = POST , requestData = mkTextFormData [ ("collection_id", cid) , ("link_ids", fullname ss) ] } -- | Update the description of the collection updateCollectionDescription :: MonadReddit m => CollectionID -> Body -> m () updateCollectionDescription cid b = runAction_ defaultAPIAction { pathSegments = collectionsPath "update_collection_description" , method = POST , requestData = mkTextFormData [ ("collection_id", cid) , ("description", b) ] } -- | Update the title of the collection updateCollectionTitle :: MonadReddit m => CollectionID -> Title -> m () updateCollectionTitle cid t = runAction_ defaultAPIAction { pathSegments = collectionsPath "update_collection_title" , method = POST , requestData = mkTextFormData [ ("collection_id", cid), ("title", t) ] } collectionAddRemove :: MonadReddit m => PathSegment -> CollectionID -> SubmissionID -> m () collectionAddRemove path cid sid = runAction_ defaultAPIAction { pathSegments = collectionsPath path , method = POST , requestData = mkTextFormData [ ("collection_id", cid) , ("link_fullname", fullname sid) ] } collectionsPath :: PathSegment -> [PathSegment] collectionsPath path = [ "api", "v1", "collections", path ] --Subreddit relationships------------------------------------------------------ -- | Get a list of information on all moderators for the given subreddit getModerators :: MonadReddit m => SubredditName -> m (Seq ModAccount) getModerators sname = runAction @ModList r <&> wrappedTo where r = defaultAPIAction { pathSegments = subAboutPath sname "moderators" } -- | Get information about a single moderator, if such a moderator exists getModerator :: MonadReddit m => SubredditName -> Username -> m (Maybe ModAccount) getModerator sname uname = do mods <- runAction @ModList r <&> wrappedTo case mods of modInfo :<| _ -> pure $ Just modInfo _ -> pure Nothing where r = defaultAPIAction { pathSegments = subAboutPath sname "moderators" , requestData = mkTextFormData [ ("user", toQueryParam uname) ] } -- | Update the permissions granted to a current moderator updateModerator :: (MonadReddit m, Foldable t) => Maybe (t ModPermission) -- ^ If @Nothing@, grants all permissions. If @Just@ and empty, -- all permissions are revoked. Otherwise, each of the given container -- of permissions is granted -> SubredditName -> Username -> m () updateModerator = postUpdate Mod -- | Revoke the given user\'s mod status removeModerator :: MonadReddit m => SubredditName -> Username -> m () removeModerator = postUnfriend Mod -- | Revoke the authenticated user\'s mod status in the given subreddit. -- __Caution__! abdicateModerator :: MonadReddit m => SubredditName -> m () abdicateModerator sname = do Account { username } <- getMe postUnfriend Mod sname username -- | Invite a user to moderate the subreddit. This action will implicitly grant -- the invitee all moderator permissions on the subreddit. To control which -- specific set of permissions the invitee shall be allowed instead, see -- 'inviteModeratorWithPerms' inviteModerator :: MonadReddit m => SubredditName -> Username -> m () inviteModerator = invite $ mkTextForm [ ("permissions", "+all") ] -- | Invite a user to moderate the subreddit with a specific set of permissions inviteModeratorWithPerms :: (MonadReddit m, Foldable t) => t ModPermission -- ^ If empty, no permissions are granted -> SubredditName -> Username -> m () inviteModeratorWithPerms perms = invite $ mkTextForm [ ("permissions", joinPerms perms) ] invite :: MonadReddit m => Form -> SubredditName -> Username -> m () invite = postFriend ModInvitation -- | Get a listing of users invited to moderate the subreddit. This endpoint only -- returns 25 results at a time, and does not use the @Listing@ mechanism that -- prevails elsewhere. You can paginate through all invitees by passing previous -- 'ModInviteeList' results to subsequent invocations getInvitees :: MonadReddit m => Maybe ModInviteeList -- ^ A previously obtained 'ModInviteeList' that may contain -- @before@ and @after@ fields to paginate through entries -> SubredditName -> m ModInviteeList getInvitees mil sname = runAction defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "moderators_invited" ] , requestData = WithForm $ maybe mempty toForm mil } -- | Get information about a single invited user getInvitee :: MonadReddit m => SubredditName -> Username -> m (Maybe ModInvitee) getInvitee sname uname = do ModInviteeList { invited } <- runAction r case invited of invitee :<| _ -> pure $ Just invitee _ -> pure Nothing where r = defaultAPIAction { pathSegments = [ "api", "v1", toUrlPiece sname, "moderators_invited" ] , requestData = mkTextFormData [ ("username", toQueryParam uname) ] } -- | Update the permissions granted to the mod invitee updateInvitation :: (MonadReddit m, Foldable t) => Maybe (t ModPermission) -- ^ If @Nothing@, grants all permissions. If @Just@ and empty, -- all permissions are revoked. Otherwise, each of the given container -- of permissions is granted -> SubredditName -> Username -> m () updateInvitation = postUpdate ModInvitation postUpdate :: (MonadReddit m, Foldable t) => SubredditRelationship -> Maybe (t ModPermission) -> SubredditName -> Username -> m () postUpdate ty ps sname uname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "setpermissions" , method = POST , requestData = mkTextFormData [ ("name", toQueryParam uname) , ("type", toQueryParam ty) , ( "permissions" , maybe "+all" joinPerms ps ) , ("api_type", "json") ] } -- | Revoke an existing moderator invitation for the given user revokeInvitation :: MonadReddit m => SubredditName -> Username -> m () revokeInvitation = postUnfriend ModInvitation -- | Accept the invitation issued to the authenticated user to moderate the -- given subreddit acceptInvitation :: MonadReddit m => SubredditName -> m () acceptInvitation sname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "accept_moderator_invitation" , method = POST , requestData = mkTextFormData [ ("api_type", "json") ] } -- | Get a list of contributors on the subreddit getContributors :: MonadReddit m => SubredditName -> Paginator RelID RelInfo -> m (Listing RelID RelInfo) getContributors = relListing Contributor -- | Get a single contributor, if such a user exists getContributor :: MonadReddit m => SubredditName -> Username -> m (Maybe RelInfo) getContributor = singleRel getContributors -- | Give a user contributor status on the subreddit addContributor :: MonadReddit m => SubredditName -> Username -> m () addContributor = postFriend Contributor mempty -- | Remove a contributor from the subreddit removeContributor :: MonadReddit m => SubredditName -> Username -> m () removeContributor = postUnfriend Contributor -- | AbdicateModerator your contributor status on the given subreddit abdicateContributor :: MonadReddit m => SubredditID -> m () abdicateContributor sid = runAction_ defaultAPIAction { pathSegments = [ "api", "leavecontributor" ] , method = POST , requestData = mkTextFormData [ ("id", fullname sid) ] } -- | Get a list of wiki contributors on the subreddit getWikiContributors :: MonadReddit m => SubredditName -> Paginator RelID RelInfo -> m (Listing RelID RelInfo) getWikiContributors = relListing WikiContributor -- | Get a single wiki contributor, if such a user exists getWikiContributor :: MonadReddit m => SubredditName -> Username -> m (Maybe RelInfo) getWikiContributor = singleRel getWikiContributors -- | Give a user wiki contributor privileges on the subreddit addWikiContributor :: MonadReddit m => SubredditName -> Username -> m () addWikiContributor = postFriend WikiContributor mempty -- | Revoke wiki contributor privileges on the subreddit removeWikiContributor :: MonadReddit m => SubredditName -> Username -> m () removeWikiContributor = postUnfriend WikiContributor -- | Get the banned users for a given subreddit getBans :: MonadReddit m => SubredditName -> Paginator RelID Ban -> m (Listing RelID Ban) getBans = relListing Banned -- | Check to see if a given user is banned on a particular subreddit, -- returning the details of the 'Ban' if so getBan :: MonadReddit m => SubredditName -> Username -> m (Maybe Ban) getBan = singleRel getBans -- | Issue a ban against a user on the given subreddit, with the provided notes -- and (optional) duration banUser :: MonadReddit m => BanNotes -> SubredditName -> Username -> m () banUser ban = postFriend Banned (toForm ban) -- | Remove an existing ban on a user unbanUser :: MonadReddit m => SubredditName -> Username -> m () unbanUser = postUnfriend Banned -- | Ban a user from participating in the wiki wikibanUser :: MonadReddit m => BanNotes -> SubredditName -> Username -> m () wikibanUser ban = postFriend BannedFromWiki (toForm ban) -- | Reverse an existing wiki ban for a user wikiUnbanUser :: MonadReddit m => SubredditName -> Username -> m () wikiUnbanUser = postUnfriend BannedFromWiki -- | Get a list of users banned on the subreddit wiki getWikibans :: MonadReddit m => SubredditName -> Paginator RelID RelInfo -> m (Listing RelID RelInfo) getWikibans = relListing BannedFromWiki -- | Get information on a single user banned on the subreddit wiki, if such a ban -- exists getWikiban :: MonadReddit m => SubredditName -> Username -> m (Maybe RelInfo) getWikiban = singleRel getWikibans -- | Get a list of users muted on the subreddit wiki getMuted :: MonadReddit m => SubredditName -> Paginator MuteID MuteInfo -> m (Listing MuteID MuteInfo) getMuted = relListing Muted -- | Get information on a single user muted on the subreddit wiki, if such a ban -- exists getMutedUser :: MonadReddit m => SubredditName -> Username -> m (Maybe MuteInfo) getMutedUser = singleRel getMuted -- | Mute a single user on the subreddit muteUser :: MonadReddit m => BanNotes -> SubredditName -> Username -> m () muteUser ban = postFriend Muted (toForm ban) -- | Unmute a single user on the subreddit unmuteUser :: MonadReddit m => SubredditName -> Username -> m () unmuteUser = postUnfriend Muted postFriend :: MonadReddit m => SubredditRelationship -> Form -> SubredditName -> Username -> m () postFriend ty form sname uname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "friend" , method = POST , requestData = WithForm $ mkTextForm [ ("name", toQueryParam uname) , ("type", toQueryParam ty) , ("api_type", "json") ] <> form } postUnfriend :: MonadReddit m => SubredditRelationship -> SubredditName -> Username -> m () postUnfriend ty sname uname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "unfriend" , method = POST , requestData = mkTextFormData [ ("name", toQueryParam uname) , ("type", toQueryParam ty) , ("api_type", "json") ] } relListing :: (MonadReddit m, FromJSON a, Paginable a, FromJSON t, Thing t) => SubredditRelationship -> SubredditName -> Paginator t a -> m (Listing t a) relListing ty sname paginator = runAction defaultAPIAction { pathSegments = subAboutPath sname (toUrlPiece ty) , requestData = paginatorToFormData paginator } singleRel :: forall m a t. (MonadReddit m, Paginable a, PaginateOptions a ~ RelInfoOpts) => (SubredditName -> Paginator t a -> m (Listing t a)) -> SubredditName -> Username -> m (Maybe a) singleRel action sname uname = do Listing { children } <- action sname pag case children of child :<| _ -> pure $ Just child _ -> pure Nothing where pag = (emptyPaginator @t @a) { opts = RelInfoOpts { username = Just uname } } --Subreddit settings----------------------------------------------------------- -- | Get the configured 'SubredditSettings' for a given subreddit getSubredditSettings :: MonadReddit m => SubredditName -> m SubredditSettings getSubredditSettings sname = runAction defaultAPIAction { pathSegments = subAboutPath sname "edit" } -- | Configure a subreddit with the provided 'SubredditSettings' setSubredditSettings :: MonadReddit m => SubredditSettings -> m () setSubredditSettings ss = runAction_ defaultAPIAction { pathSegments = [ "api", "site_admin" ] , method = POST , requestData = WithForm $ toForm ss } --Subreddit rules-------------------------------------------------------------- -- | Add a rule to the subreddit. The newly created 'SubredditRule' is returned -- upon success addSubredditRule :: MonadReddit m => SubredditName -> NewSubredditRule -> m SubredditRule addSubredditRule sname nsr = runAction @PostedSubredditRule r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "add_subreddit_rule" ] , method = POST , requestData = WithForm $ mkTextForm [ ("r", toQueryParam sname), ("api_type", "json") ] <> toForm nsr } -- | Delete the rule identified by the given name from the subreddit deleteSubredditRule :: MonadReddit m => SubredditName -> Name -> m () deleteSubredditRule sname n = runAction_ defaultAPIAction { pathSegments = [ "api", "remove_subreddit_rule" ] , method = POST , requestData = mkTextFormData [ ("r", toQueryParam sname) , ("short_name", n) ] } -- | Update an existing subreddit rule. You must provide the @shortName@ of the -- existing rule as a parameter in order for Reddit to identify the rule. The -- @shortName@ can be changed by updating the 'SubredditRule' record, however updateSubredditRule :: MonadReddit m => SubredditName -> Name -- ^ The old name for the rule. This is required even if you are not -- changing the name of the rule, as Reddit has no other data to -- uniquely identify the rule -> SubredditRule -> m SubredditRule updateSubredditRule sname oldName srule = runAction @PostedSubredditRule r <&> wrappedTo where r = defaultAPIAction { pathSegments = [ "api", "update_subreddit_rule" ] , method = POST , requestData = WithForm $ mkTextForm [ ("old_short_name", oldName) , ("r", toQueryParam sname) , ("api_type", "json") ] <> toForm srule } -- | Reorder the subreddit rules reorderSubredditRules :: (MonadReddit m, Foldable t) => SubredditName -> t Name -- ^ The desired order of the rules. Must contain all of the @shortName@s -- of currently configured 'SubredditRule's on the subreddit -> m () reorderSubredditRules sname ns = runAction_ defaultAPIAction { pathSegments = [ "api", "reorder_subreddit_rules" ] , method = POST , requestData = mkTextFormData [ ("r", toQueryParam sname) , ("new_rule_order", joinParams ns) ] } --Flair------------------------------------------------------------------------ -- | Get a list of usernames and the flair currently assigned to them configureSubredditFlair :: MonadReddit m => SubredditName -> FlairConfig -> m () configureSubredditFlair sname fc = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "flairconfig" , method = POST , requestData = WithForm $ toForm fc } getFlairList :: MonadReddit m => SubredditName -> Paginator UserID AssignedFlair -> m (Listing UserID AssignedFlair) getFlairList sname paginator = flairlistToListing <$> runAction defaultAPIAction { pathSegments = subAPIPath sname "flairlist" , requestData = paginatorToFormData paginator } -- | Get the 'UserFlair' that corresponds to a 'Username' getUserFlair :: MonadReddit m => SubredditName -> Username -> m (Maybe UserFlair) getUserFlair sname uname = catch @_ @APIException action $ \case JSONParseError _ _ -> pure Nothing e -> throwM e where action = runAction @CurrentUserFlair r <&> Just . wrappedTo r = defaultAPIAction { pathSegments = subAPIPath sname "flairselector" , method = POST , requestData = mkTextFormData [ ("name", toQueryParam uname) ] } -- | Set a user\'s flair. If the 'CSSClass' is provided in the 'FlairChoice', it -- takes precedence over the 'FlairID' contained in that record setUserFlair :: MonadReddit m => FlairSelection -> Username -> m () setUserFlair (FlairSelection FlairChoice { .. } txt sname) uname = runAction_ route where route = case cssClass of Just css -> baseRoute { pathSegments = subAPIPath sname "selectflair" , requestData = WithForm $ baseForm <> mkTextForm [ ("css_class", toQueryParam css) ] } Nothing -> baseRoute { pathSegments = subAPIPath sname "flair" , requestData = WithForm $ baseForm <> mkTextForm [ ( "flair_template_id" , toQueryParam templateID ) ] } baseForm = mkTextForm $ [ ("name", toQueryParam uname) ] <> foldMap pure (("text", ) <$> txt) baseRoute = defaultAPIAction { method = POST } -- | Set, update, or deleteSRImage the flair of multiple users at once, given a -- container of 'AssignedFlair's setUserFlairs :: (MonadReddit m, Foldable t) => SubredditName -> t AssignedFlair -> m (Seq FlairResult) setUserFlairs sname afs = mconcat <$> traverse (runAction . r) (chunksOf apiRequestLimit (F.toList afs)) where r as = defaultAPIAction { pathSegments = subAPIPath sname "flaircsv" , method = POST , requestData = mkTextFormData [ ("flair_csv", T.unlines $ mkRow <$> as) ] } mkRow AssignedFlair { .. } = joinParams [ toQueryParam user , maybe mempty toQueryParam text , toQueryParam $ fromMaybe mempty cssClass ] -- | Delete a user\'s flair on the given subreddit deleteUserFlair :: MonadReddit m => SubredditName -> Username -> m () deleteUserFlair sname uname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "deleteflair" , method = POST , requestData = mkTextFormData [ ("name", toQueryParam uname) , ("api_type", "json") ] } -- | Create a new 'FlairTemplate' for either users or submissions, returning the -- newly created template createFlairTemplate :: MonadReddit m => FlairType -> SubredditName -> FlairTemplate -> m FlairTemplate createFlairTemplate fty sname tmpl = runAction $ flairRoute (toForm tmpl) fty sname -- | Create a new 'FlairTemplate' for users, returning the newly created template createUserFlairTemplate :: MonadReddit m => SubredditName -> FlairTemplate -> m FlairTemplate createUserFlairTemplate = createFlairTemplate UserFlairType -- | Create a new 'FlairTemplate' for submissions, returning the newly created -- template createSubmissionFlairTemplate :: MonadReddit m => SubredditName -> FlairTemplate -> m FlairTemplate createSubmissionFlairTemplate = createFlairTemplate SubmissionFlairType -- | Update an existing 'FlairTemplate' for either users or submissions updateFlairTemplate :: MonadReddit m => FlairType -> SubredditName -> FlairTemplate -> m () updateFlairTemplate fty sname tmpl = runAction_ $ flairRoute form fty sname where form = toForm $ wrappedFrom @PostedFlairTemplate tmpl -- | Update an existing 'FlairTemplate' for users updateUserFlairTemplate :: MonadReddit m => SubredditName -> FlairTemplate -> m () updateUserFlairTemplate = updateFlairTemplate UserFlairType -- | Update an existing 'FlairTemplate' for submissions updateSubmissionFlairTemplate :: MonadReddit m => SubredditName -> FlairTemplate -> m () updateSubmissionFlairTemplate = updateFlairTemplate SubmissionFlairType flairRoute :: Form -> FlairType -> SubredditName -> APIAction a flairRoute form fty sname = defaultAPIAction { pathSegments = subAPIPath sname "flairtemplate_v2" , method = POST , requestData = WithForm $ form <> mkTextForm [ ("flair_type", toQueryParam fty) ] } -- | Delete a user or submission flair template given its 'FlairID' deleteFlairTemplate :: MonadReddit m => SubredditName -> FlairID -> m () deleteFlairTemplate sname ftid = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "deleteflairtemplate" , method = POST , requestData = mkTextFormData [ ("flair_template_id", toQueryParam ftid) ] } -- | Clear all of the user flair templates on the subreddit clearUserFlairTemplates :: MonadReddit m => SubredditName -> m () clearUserFlairTemplates = clearFlairTemplates UserFlairType -- | Clear all of the user flair templates on the subreddit clearSubmissionFlairTemplates :: MonadReddit m => SubredditName -> m () clearSubmissionFlairTemplates = clearFlairTemplates SubmissionFlairType -- | Clear all of the user or submission flair templates on the subreddit clearFlairTemplates :: MonadReddit m => FlairType -> SubredditName -> m () clearFlairTemplates fty sname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "clearflairtemplates" , method = POST , requestData = mkTextFormData [ ("flair_type", toQueryParam fty) ] } --Wikis------------------------------------------------------------------------ -- | Get the 'WikiPageSettings' for the subreddit\'s given wikipage getWikiPageSettings :: MonadReddit m => SubredditName -> WikiPageName -> m WikiPageSettings getWikiPageSettings sname wpage = runAction defaultAPIAction { pathSegments = [ "r" , toUrlPiece sname , "wiki" , "settings" , toQueryParam wpage ] } -- | Grant editing privileges to the given 'Username' on the subreddit\'s wikipage addWikiEditor :: MonadReddit m => SubredditName -> WikiPageName -> Username -> m () addWikiEditor = allowedEditor "add" -- | Revoke the given 'Username'\'s editing privileges on the subreddit\'s wikipage removeWikiEditor :: MonadReddit m => SubredditName -> WikiPageName -> Username -> m () removeWikiEditor = allowedEditor "del" allowedEditor :: MonadReddit m => Text -> SubredditName -> WikiPageName -> Username -> m () allowedEditor path sname wpage uname = runAction_ defaultAPIAction { pathSegments = [ "r" , toQueryParam sname , "api" , "wiki" , "allowededitor" , path ] , method = POST , requestData = mkTextFormData [ ("page", toQueryParam wpage) , ("username", toQueryParam uname) ] } -- | Revert the wikipage to the given revision revertWikiPage :: MonadReddit m => SubredditName -> WikiPageName -> WikiRevisionID -> m () revertWikiPage sname wpage wr = runAction_ defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "api", "wiki", "revert" ] , method = POST , requestData = mkTextFormData [ ("page", toQueryParam wpage) , ("revision", toQueryParam wr) ] } --Stylesheets, images and widgets ---------------------------------------------- -- | Get the 'Stylesheet' that has been configured for the given subreddit getStylesheet :: MonadReddit m => SubredditName -> m Stylesheet getStylesheet sname = runAction defaultAPIAction { pathSegments = [ "r", toUrlPiece sname, "about", "stylesheet" ] } -- | Update a given subreddit\'s stylesheet with new contents, which must be -- valid CSS updateStylesheet :: MonadReddit m => SubredditName -> Maybe Text -- ^ The reason for the change, if any -> Text -- ^ The new contents of the stylesheet -> m () updateStylesheet sname r contents = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "subreddit_stylesheet" , method = POST , requestData = mkTextFormData $ [ ("stylesheet_contents", contents) , ("op", "save") , ("api_type", "json") ] <> foldMap pure (("reason", ) <$> r) } uploadImage, uploadHeader :: MonadReddit m => Text -> FilePath -> SubredditName -> m () -- | Upload an image file to add to the given subreddit\'s stylesheet uploadImage = uploadSRImage "img" -- | Upload the image header for the given subreddit\'s stylesheet uploadHeader = uploadSRImage "header" uploadMobileIcon, uploadMobileHeader :: MonadReddit m => Text -> FilePath -> SubredditName -> m () -- | Upload a mobile icon for the given subreddit uploadMobileIcon = uploadSRImage "icon" -- | Upload the mobile header for the given subreddit uploadMobileHeader = uploadSRImage "banner" -- | Delete the named image from the given subreddit\'s stylesheet deleteImage :: MonadReddit m => Text -> SubredditName -> m () deleteImage = deleteSRImage "img" -- | Delete the named image from the given subreddit\'s stylesheet deleteMobileIcon :: MonadReddit m => Text -> SubredditName -> m () deleteMobileIcon = deleteSRImage "icon" -- | Delete header image from the given subreddit deleteHeader :: MonadReddit m => SubredditName -> m () deleteHeader sname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "delete_sr_header" , method = POST , requestData = mkTextFormData [ ("api_type", "json") ] } -- | Upload a banner for the subreddit (redesign only) uploadBanner :: MonadReddit m => SubredditName -> FilePath -> m () uploadBanner sname fp = do imgURL <- uploadS3Asset sname BannerBackground fp updateStructuredStyles sname $ mkTextForm [ (toQueryParam BannerBackground, imgURL) ] -- | Delete the subreddit banner, even if it does not exist (redesign only) deleteBanner :: MonadReddit m => SubredditName -> m () deleteBanner sname = updateStructuredStyles sname $ mkTextForm [ (toQueryParam BannerBackground, mempty) ] -- | Upload the additional image banner for the subreddit (redesign only) uploadBannerAdditional :: MonadReddit m => Maybe StyleImageAlignment -> SubredditName -> FilePath -> m () uploadBannerAdditional sia sname fp = do imgURL <- uploadS3Asset sname BannerAdditional fp updateStructuredStyles sname . mkTextForm $ [ (toQueryParam BannerAdditional, imgURL) ] <> foldMap pure (("bannerPositionedImagePosition", ) . toQueryParam <$> sia) -- | Delete all additional banners, including the hover banner (redesign only) deleteBannerAdditional :: MonadReddit m => SubredditName -> m () deleteBannerAdditional sname = updateStructuredStyles sname $ mkTextForm [ (toQueryParam BannerAdditional, mempty) , (toQueryParam BannerHover, mempty) ] -- | Upload the banner hover image for the subreddit (redesign only) uploadBannerHover :: MonadReddit m => SubredditName -> FilePath -> m () uploadBannerHover sname fp = do imgURL <- uploadS3Asset sname BannerHover fp updateStructuredStyles sname $ mkTextForm [ (toQueryParam BannerHover, imgURL) ] -- | Delete the subreddit banner hover image (redesign only) deleteBannerHover :: MonadReddit m => SubredditName -> m () deleteBannerHover sname = updateStructuredStyles sname $ mkTextForm [ (toQueryParam BannerHover, mempty) ] uploadSRImage :: forall m. MonadReddit m => ByteString -> Text -> FilePath -> SubredditName -> m () uploadSRImage ty name fp sname = withSourceFile @_ @m fp $ \bs -> do img <- runConduit $ bs .| sinkLbs imageType <- getImageType img when (LB.length img > maxImageSize) . throwM $ InvalidRequest "uploadSRImage: exceeded maximum image size" runAction_ defaultAPIAction { pathSegments = subAPIPath sname "upload_sr_img" , method = POST , requestData = WithMultipart [ partBS "img_type" imageType -- This seems to work, but @partLBS img@ causes -- reddit to freak out , partFile "file" fp , partBS "name" $ T.encodeUtf8 name , partBS "upload_type" ty , partBS "api_type" "json" ] } where maxImageSize = 512000 getImageType = \case bs | LB.take 4 (LB.drop 6 bs) == "JFIF" -> pure "jpeg" | LB.isPrefixOf "\137PNG\r\n\26\n" bs -> pure "png" | otherwise -> throwM $ InvalidRequest "uploadSRImage: Can't detect image type" deleteSRImage :: MonadReddit m => Text -> Text -> SubredditName -> m () deleteSRImage path name sname = runAction_ defaultAPIAction { pathSegments = subAPIPath sname $ "delete_sr_" <> path , method = POST , requestData = mkTextFormData [ ("img_name", name) , ("api_type", "json") ] } uploadS3Asset :: MonadReddit m => SubredditName -> StructuredStyleImage -> FilePath -> m URL uploadS3Asset sname imageType fp = do mimetype <- case FP.takeExtension fp of ext | ext `elem` [ ".jpeg", ".jpg" ] -> pure "image/jpeg" | ext == ".png" -> pure "image/png" | otherwise -> throwM $ InvalidRequest "uploadS3Asset: invalid file type" S3ModerationLease { .. } <- runAction defaultAPIAction { pathSegments = [ "api" , "v1" , "style_asset_upload_s3" , toUrlPiece sname ] , method = POST , requestData = mkTextFormData [ ( "filepath" , toQueryParam $ FP.takeFileName fp ) , ("mimetype", mimetype) , ( "imagetype" , toQueryParam imageType ) ] } (url, ps) <- splitURL action void . runActionWith_ =<< mkRequest url defaultAPIAction { pathSegments = ps , method = POST , requestData = WithMultipart $ HM.foldrWithKey mkParts [ partFile "file" fp ] fields , rawJSON = False } pure $ T.intercalate "/" [ action, key ] where mkParts name value ps = partBS name (T.encodeUtf8 value) : ps updateStructuredStyles :: MonadReddit m => SubredditName -> Form -> m () updateStructuredStyles sname form = runAction_ defaultAPIAction { pathSegments = [ "api", "v1", "structured_styles", toUrlPiece sname ] , method = PATCH , requestData = WithForm form } --Modmail---------------------------------------------------------------------- -- | Get all of the authenticated user\'s modmail. See 'getModmailWithOpts' in -- order to control how modmail is sorted or filtered getModmail :: MonadReddit m => m Modmail getModmail = runAction defaultAPIAction { pathSegments = modmailPath , requestData = WithForm $ toForm defaultModmailOpts { state = Just AllModmail } } -- | Get the authenticated user\'s modmail with the provided 'ModmailOpts' getModmailWithOpts :: MonadReddit m => ModmailOpts -> m Modmail getModmailWithOpts opts = runAction defaultAPIAction { pathSegments = modmailPath , requestData = WithForm $ toForm opts } -- | Get a single 'ModmailConversation' given its ID getModmailConversation :: MonadReddit m => ModmailID -> m ModmailConversation getModmailConversation m = runAction @ConversationDetails r <&> wrappedTo where r = defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m ] } -- | Get the number of unread modmail conversations according to conversation -- state getUnreadModmailCount :: MonadReddit m => m (HashMap ModmailState Word) getUnreadModmailCount = runAction defaultAPIAction { pathSegments = modmailPath <> [ "unread", "count" ] } -- | Create a new 'ModmailConversation' createConversation :: MonadReddit m => NewConversation -> m ModmailConversation createConversation nc = runAction @ConversationDetails r <&> wrappedTo where r = defaultAPIAction { pathSegments = modmailPath , method = POST , requestData = WithForm $ toForm nc } -- | Reply to the modmail conversation replyToConversation :: MonadReddit m => ModmailReply -> ModmailID -> m ModmailConversation replyToConversation mr m = runAction @ConversationDetails r <&> wrappedTo where r = defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m ] , method = POST , requestData = WithForm $ toForm mr } -- | Archive a modmail conversation archiveConversation :: MonadReddit m => ModmailID -> m () archiveConversation m = runAction_ defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m, "archive" ] , method = POST } -- | Archive a modmail conversation unarchiveConversation :: MonadReddit m => ModmailID -> m () unarchiveConversation m = runAction_ defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m, "unarchive" ] , method = POST } -- | Highlight a given conversation highlightConversation :: MonadReddit m => ModmailID -> m () highlightConversation = highlightUnhighlight POST -- | Unhighlight a given conversation unhighlightConversation :: MonadReddit m => ModmailID -> m () unhighlightConversation = highlightUnhighlight DELETE highlightUnhighlight :: MonadReddit m => Method -> ModmailID -> m () highlightUnhighlight method m = runAction_ defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m, "highlight" ] , method } -- | Mark the conversations corresponding to a container of 'ModmailID's as read markConversationsRead :: (Foldable t, MonadReddit m) => t ModmailID -> m () markConversationsRead = readUnread "read" -- | Mark the conversation corresponding to a single 'ModmailID' as read markConversationRead :: MonadReddit m => ModmailID -> m () markConversationRead m = markConversationsRead [ m ] -- | Mark the conversations corresponding to a container of 'ModmailID's as unread markConversationsUnread :: (Foldable t, MonadReddit m) => t ModmailID -> m () markConversationsUnread = readUnread "unread" -- | Mark the conversation corresponding to a single 'ModmailID' as unread markConversationUnread :: MonadReddit m => ModmailID -> m () markConversationUnread m = markConversationsUnread [ m ] readUnread :: (Foldable t, MonadReddit m) => PathSegment -> t ModmailID -> m () readUnread path ms = runAction_ defaultAPIAction { pathSegments = modmailPath <> [ path ] , method = POST , requestData = mkTextFormData [ ("conversationIds", joinParams ms) ] } -- | Mark all mail belonging to the subreddits as read, returning the 'ModmailID's -- of the newly read conversations bulkReadConversations :: (MonadReddit m, Foldable t) => Maybe ModmailState -> t SubredditName -> m (Seq ModmailID) bulkReadConversations mms snames = runAction @BulkReadIDs r <&> wrappedTo where r = defaultAPIAction { pathSegments = modmailPath <> [ "bulk", "read" ] , method = POST , requestData = WithForm . mkTextForm $ [ ("entity", joinParams snames) ] <> foldMap pure (("state", ) . toQueryParam <$> mms) } -- | Mute the non-moderator user associated with the modmail conversation. Valid -- durations for the @days@ parameter are 3, 7, and 28 muteModmailUser :: MonadReddit m => Word -> ModmailID -> m () muteModmailUser days m = do when (days `notElem` [ 3, 7, 28 ]) . throwM $ InvalidRequest -- "muteModmailUser: mute duration must be one of 3, 7, or 28" runAction_ defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m, "mute" ] , method = POST , requestData = mkTextFormData [ ("num_hours", toQueryParam $ days * 24) ] } -- | Unmute the non-moderator user associated with the modmail conversation unmuteModmailUser :: MonadReddit m => ModmailID -> m () unmuteModmailUser m = runAction_ defaultAPIAction { pathSegments = modmailPath <> [ toUrlPiece m, "unmute" ] , method = POST } modmailPath :: [PathSegment] modmailPath = [ "api", "mod", "conversations" ] --Widgets---------------------------------------------------------------------- -- | Delete a widget, given its ID deleteWidget :: MonadReddit m => SubredditName -> WidgetID -> m () deleteWidget sname wid = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "widget" <> [ toUrlPiece wid ] , method = DELETE } -- | Reorder the widgets corresponding to a container of widget IDs in the given -- section. At the moment, reddit does not allow for the 'Topbar' to be reordered. -- If you attempt to reorder this section, you might receive an 'InvalidJSON' -- exception reorderWidgets :: (MonadReddit m, Foldable t) => Maybe WidgetSection -> SubredditName -> t WidgetID -> m () reorderWidgets sm sname ws = runAction_ defaultAPIAction { pathSegments = subAPIPath sname "widget_order" <> [ toUrlPiece section ] , method = PATCH , requestData = mkTextFormData [ ("json", textEncode $ F.toList ws) , ("section", toQueryParam section) ] } where section = fromMaybe Sidebar sm -- | Update an existing widget, given its ID. You must wrap the widget type in -- the appropriate 'Widget' constructors, as this action may be performed on -- heterogeneous widget types. The update widget is returned upon success updateWidget :: MonadReddit m => SubredditName -> WidgetID -> Widget -> m Widget updateWidget sname wid w = runAction defaultAPIAction { pathSegments = subAPIPath sname "widget" <> [ toUrlPiece wid ] , method = PUT , requestData = mkTextFormData [ ("json", textEncode w) ] } -- | Add a button widget. Returns the created widget upon success. See the docs for -- 'ButtonWidget' for the available options addButtonWidget :: MonadReddit m => SubredditName -> ButtonWidget -> m ButtonWidget addButtonWidget = addNormalWidget -- | Add a calendar widget, which requires an active Google account and public -- calendar. Returns the created widget upon success. See the docs for -- 'CalendarWidget' for the available options addCalendarWidget :: MonadReddit m => Maybe Body -- ^ A short description of the widget, in markdown -> SubredditName -> CalendarWidget -> m CalendarWidget addCalendarWidget = addDescribableWidget -- | Add a community list widget. Returns the created widget upon success. See -- the docs for 'CommunityListWidget' for the available options addCommunityListWidget :: MonadReddit m => Maybe Body -- ^ A short description of the widget, in markdown -> SubredditName -> CommunityListWidget -> m CommunityListWidget addCommunityListWidget = addDescribableWidget -- | Add a custom widget. Returns the created widget upon success. See -- the docs for 'CustomWidget' for the available options addCustomWidget :: MonadReddit m => SubredditName -> CustomWidget -> m CustomWidget addCustomWidget = addNormalWidget -- | Add an image widget. Returns the created widget upon success. See -- the docs for 'ImageWidget' for the available options addImageWidget :: MonadReddit m => SubredditName -> ImageWidget -> m ImageWidget addImageWidget = addNormalWidget -- | Add a menu widget. Returns the created widget upon success. See -- the docs for 'MenuWidget' for the available options addMenuWidget :: MonadReddit m => SubredditName -> MenuWidget -> m MenuWidget addMenuWidget = addNormalWidget -- | Add a post flair widget. Returns the created widget upon success. See -- the docs for 'PostFlairWidget' for the available options along with -- 'mkPostFlairWidget' addPostFlairWidget :: MonadReddit m => SubredditName -> PostFlairWidget -> m PostFlairWidget addPostFlairWidget = addNormalWidget -- | Add a text area widget. Returns the created widget upon success. See -- the docs for 'TextAreaWidget' for the available options as well as -- 'mkTextAreaWidget' addTextAreaWidget :: MonadReddit m => SubredditName -> TextAreaWidget -> m TextAreaWidget addTextAreaWidget = addNormalWidget addNormalWidget :: (MonadReddit m, ToJSON a, FromJSON a) => SubredditName -> a -> m a addNormalWidget sname x = runAction defaultAPIAction { pathSegments = subAPIPath sname "widget" , method = POST , requestData = mkTextFormData [ ("json", textEncode x) ] } addDescribableWidget :: (MonadReddit m, ToJSON a, FromJSON a) => Maybe Body -> SubredditName -> a -> m a addDescribableWidget desc sname x = runAction defaultAPIAction { pathSegments = subAPIPath sname "widget" , method = POST , requestData = mkTextFormData [ ( "json" , textEncode . describeWidget x $ fromMaybe mempty desc ) ] } -- Certain 'Widget's can be given markdown-formatted description field. This -- function injects the field into the widget\'s JSON 'Object' if applicable, -- otherwise returning the value as-is describeWidget :: ToJSON a => a -> Body -> Value describeWidget widget (String -> desc) = case toJSON widget of Object o -> Object $ HM.insert "description" desc o v -> v -- | Upload a widget image from a filepath. This returns the URL of the new image, -- which is required for creating certain widgets uploadWidgetImage :: MonadReddit m => SubredditName -> FilePath -> m UploadURL uploadWidgetImage sname fp = do S3ModerationLease { action, key } <- uploadS3Image True (subAPIPath sname "widget_image_upload_s3") fp pure . wrappedFrom $ T.intercalate "/" [ action, key ] uploadS3Image :: MonadReddit m => Bool -> [PathSegment] -> FilePath -> m S3ModerationLease uploadS3Image rawJSON pathSegments fp = do mimetype <- case FP.takeExtension fp of ext | ext `elem` [ ".jpeg", ".jpg" ] -> pure "image/jpeg" | ext == ".png" -> pure "image/png" | otherwise -> throwM $ InvalidRequest "uploadS3Image: invalid file type" s3@S3ModerationLease { .. } <- runAction defaultAPIAction { pathSegments , method = POST , requestData = mkTextFormData [ ( "filepath" , toQueryParam $ FP.takeFileName fp ) , ("mimetype", mimetype) ] } (url, ps) <- splitURL action void . runActionWith_ =<< mkRequest url defaultAPIAction { pathSegments = ps , method = POST , requestData = WithMultipart $ HM.foldrWithKey mkParts [ partFile "file" fp ] fields , rawJSON } pure s3 where mkParts name value ps = partBS name (T.encodeUtf8 value) : ps --Emoji------------------------------------------------------------------------ -- | Add a new emoji by uploading an image. See 'mkEmoji' to conveniently create -- new 'Emoji's to add. Also note the restrictions on the filepath argument below, -- which are not currently validated by this action. This action can also be used -- to update the image for an existing emoji (see -- 'Network.Reddit.Actions.Subreddit.getSubredditEmoji') to get a list of emojis -- for a subreddit addEmoji :: MonadReddit m => SubredditName -> FilePath -- ^ Must be an image in jpeg/png format, with maximum dimensions of -- 128 x 128px and size of 64KB -> Emoji -> m () addEmoji sname fp emoji = do S3ModerationLease { key } <- uploadS3Image False (v1Path sname "emoji_asset_upload_s3.json") fp runAction_ defaultAPIAction { pathSegments = v1Path sname "emoji.json" , method = POST , requestData = WithForm $ toForm @NewEmoji (wrappedFrom emoji) <> mkTextForm [ ("s3_key", toQueryParam key) ] } -- | Delete a single emoji and associated s3 image deleteEmoji :: MonadReddit m => SubredditName -> EmojiName -> m () deleteEmoji sname ename = runAction_ defaultAPIAction { pathSegments = v1Path sname "emoji" <> [ toUrlPiece ename ] , method = DELETE } -- | Update an emoji. Only the boolean permissions fields will be sent. If you -- would like to change the image associated with the emoji name, use 'addEmoji' -- with an updated filepath updateEmoji :: MonadReddit m => SubredditName -> Emoji -> m () updateEmoji sname emoji = runAction_ defaultAPIAction { pathSegments = v1Path sname "emoji_permissions" , method = POST , requestData = WithForm $ toForm emoji } -- | Set the (h, w) dimensions for /all/ custom emojis on the subreddit. Both -- dimensions must be between 16px and 40px. A @Nothing@ argument will disable -- custom sizes setCustomEmojiSize :: MonadReddit m => SubredditName -> Maybe (Int, Int) -> m () setCustomEmojiSize sname = \case Nothing -> runAction_ r { requestData = WithForm mempty } Just ss@(h, w) -> case bimap inR inR ss of (True, True) -> runAction_ r { requestData = mkTextFormData [ ("height", toQueryParam h) , ("width", toQueryParam w) ] } _ -> throwM . InvalidRequest $ "setCustomEmojiSize: Height and width must be between 16px and 40px" where inR = inRange (16, 40) r = defaultAPIAction { pathSegments = v1Path sname "emoji_custom_size", method = POST } v1Path :: ToHttpApiData a => a -> PathSegment -> [PathSegment] v1Path sname path = [ "api", "v1", toUrlPiece sname ] <> [ path ] --Misc------------------------------------------------------------------------- -- | Get traffic statistics for the given subreddit getTraffic :: MonadReddit m => SubredditName -> m Traffic getTraffic sname = runAction defaultAPIAction { pathSegments = subAboutPath sname "traffic" }