Comment.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module      : Network.Reddit.Comment
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Comment
    (  -- * Reading comments
      getComments
    , getComment
    , getCommentByURL
    , withReplies
    , loadMoreComments
    , loadMoreCommentsDef
    , unsaveComment
    , saveComment
      -- * Creating, editing, and deleting
    , deleteComment
    , editComment
    , replyToComment
    , getNewComments
    , setCommentReplies
      -- * Voting
      -- $vote
    , upvoteComment
    , downvoteComment
    , unvoteComment
      -- * Awarding
    , awardComment
    , gildComment
      -- * Misc
    , reportComment
      -- * Types
    , module M
    ) where

import           Control.Monad.Catch             ( MonadThrow(throwM) )

import           Data.Generics.Wrapped           ( wrappedTo )
import           Data.Sequence                   ( Seq((:<|)) )
import qualified Data.Sequence                   as Seq

import           Lens.Micro

import           Network.Reddit.Internal
import           Network.Reddit.Item
import           Network.Reddit.Types
import           Network.Reddit.Types.Comment
import           Network.Reddit.Types.Comment    as M
                 ( ChildComment(..)
                 , Comment(Comment)
                 , CommentID(CommentID)
                 , MoreComments(MoreComments)
                 )
import           Network.Reddit.Types.Submission
import           Network.Reddit.Types.Subreddit
import           Network.Reddit.Utils

import           Web.FormUrlEncoded              ( ToForm(toForm) )
import           Web.HttpApiData                 ( ToHttpApiData(toQueryParam)
                                                 )

-- | Get the 'Comment's corresponding to a container of 'CommentID's
getComments :: (MonadReddit m, Foldable t)
            => ItemOpts 
            -> t CommentID
            -> m (Seq Comment)
getComments = getMany

-- | Get information on a single 'CommentID'. Throws an exception if no such
-- 'Comment' exists
getComment :: MonadReddit m => CommentID -> m Comment
getComment cid = getComments defaultItemOpts [ cid ] >>= \case
    comment :<| _ -> pure comment
    _             -> throwM $ InvalidResponse "getComment: No results"

-- | Get a comment based on its permalink URL, which must be of the form
-- https:\/\/{www.}reddit.com\/r\/\<SUB\>\/comments\/\<SID\>\/\<NAME\>/\<ID\>
getCommentByURL :: MonadReddit m => URL -> m Comment
getCommentByURL url = getComment =<< commentIDFromURL url

-- | Get new 'Comment's, either for the site as a whole or for a single subreddit,
-- given its 'SubredditName'
getNewComments :: MonadReddit m
               => Maybe SubredditName
               -> Paginator CommentID Comment
               -> m (Listing CommentID Comment)
getNewComments sname paginator =
    runAction defaultAPIAction
              { requestData  = paginatorToFormData paginator
              , pathSegments = [ "comments" ]
                    & maybe id (\s -> (<>) [ "r", toQueryParam s ]) sname
              }

-- | Update a 'Comment' to include its 'ChildComment's, returning the updated
-- 'Comment'. This will probably be necessary if the original 'Comment' was obtained
-- by getting a 'Username'\'s or 'Subreddit'\'s comments, etc...
withReplies :: MonadReddit m => ItemOpts -> Comment -> m Comment
withReplies ItemOpts { .. } Comment { .. } =
    runAction @WithReplies r <&> wrappedTo
  where
    r = defaultAPIAction
        { pathSegments =
              [ "comments", toQueryParam linkID, "_", toQueryParam commentID ]
        , requestData  = mkTextFormData
              $ [ ("context", "100") ] -- asking for extra context
              <> foldMap pure (("sort", ) . toQueryParam <$> itemSort)
        }

-- | Save a comment
saveComment :: MonadReddit m => CommentID -> m ()
saveComment = save . CommentItemID

-- | Unsave a comment
unsaveComment :: MonadReddit m => CommentID -> m ()
unsaveComment = unsave . CommentItemID

-- | Delete a comment that the currently authenticated user has authored, given its
-- 'CommentID'
deleteComment :: MonadReddit m => CommentID -> m ()
deleteComment = delete . CommentItemID

-- | Edit a comment given its 'CommentID', receving an updated 'Comment' in response
editComment :: MonadReddit m => CommentID -> Body -> m Comment
editComment (CommentItemID -> cid) txt = edit cid txt >>= \case
    CommentItem c    -> pure c
    SubmissionItem _ -> throwM
        $ InvalidResponse "editComment: Expected a Comment, got a Submission"

-- | Reply to a comment given its 'CommentID', returning the newly created 'Comment'
replyToComment :: MonadReddit m => CommentID -> Body -> m Comment
replyToComment = reply . CommentItemID

-- | Enable/disable inbox replies for a comment
setCommentReplies :: MonadReddit m => Bool -> CommentID -> m ()
setCommentReplies p (CommentItemID -> cid) = setInboxReplies p cid

-- | Upvote a comment.
upvoteComment :: MonadReddit m => CommentID -> m ()
upvoteComment = vote Upvote . CommentItemID

-- | Downvote a comment.
downvoteComment :: MonadReddit m => CommentID -> m ()
downvoteComment = vote Downvote . CommentItemID

-- | Remove an existing vote on a comment.
unvoteComment :: MonadReddit m => CommentID -> m ()
unvoteComment = vote Unvote . CommentItemID

-- | Grant an 'Award' to a comment. See 'mkAward' for creating an award with
-- default values, as well as the pattern synonyms for common awards
awardComment :: MonadReddit m => Award -> CommentID -> m AwardingsSummary
awardComment a = award a . CommentItemID

-- | Convenience action to anonymously give 'Gold' to the author of a comment,
-- without a message. See 'awardComment' if you need more fine-grained control
gildComment :: MonadReddit m => CommentID -> m AwardingsSummary
gildComment = gild . CommentItemID

-- | Report a comment to the subreddit\'s mods
reportComment :: MonadReddit m => Report -> CommentID -> m ()
reportComment r = report r . CommentItemID

{- HLINT ignore "Use mconcat" -}
-- | Transform 'MoreComments', loading the actual comments they refer to, up to
-- the limit passed in (pass 'Nothing' for no limit). If 'CommentID's still remain
-- from the original 'MoreComments', they will be returned in a new 'MoreComments'
-- inserted into the resulting sequence of 'ChildComment's, along with an updated
-- count
loadMoreComments
    :: forall m.
    MonadReddit m
    => Maybe Word
    -> ItemOpts 
    -> SubmissionID
    -> MoreComments
    -> m (Seq ChildComment)
loadMoreComments limitM opts sid MoreComments { .. } = foldr (<>) mempty
    <$> traverse fetchMore (Seq.chunksOf 100 toFetch)
    <&> (<> more) -- appending this way, after the fold, will put @more@ at the end
  where
    fetchMore :: Seq CommentID -> m (Seq ChildComment)
    fetchMore cids = runAction @LoadedChildren r <&> wrappedTo
      where
        r = defaultAPIAction
            { pathSegments = [ "api", "morechildren" ]
            , method       = POST
            , requestData  = WithForm
                  $ toForm opts
                  <> mkTextForm [ ("link_id", fullname sid)
                                , ("api_type", "json")
                                , ("children", joinParams cids)
                                ]
            }

    more = case remaining of
        Seq.Empty -> mempty
        cids      -> Seq.singleton . More . MoreComments cids
            $ count - fromIntegral limit

    (toFetch, remaining) = Seq.splitAt limit childIDs

    limit = maybe (length childIDs) fromIntegral limitM

-- | A version of 'loadMoreComments' with default parameters for the limit
-- (@Nothing@) and options ('defaultItemOpts')
loadMoreCommentsDef
    :: MonadReddit m => SubmissionID -> MoreComments -> m (Seq ChildComment)
loadMoreCommentsDef = loadMoreComments Nothing defaultItemOpts
--
-- $vote
-- __Note__: According to Reddit\'s API rules:
--
-- votes must be cast by humans. That is, API clients proxying a human's
-- action one-for-one are OK, but bots deciding how to vote on content or amplifying
-- a human's vote are not. See the reddit rules for more details on what constitutes
-- vote cheating.
--