heddit-0.1: src/Network/Reddit/Moderation.hs
{-# 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
, 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.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_ r
where
r = 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
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" }