Submission.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module      : Network.Reddit.Submission
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Submission
    (  -- * Reading submissions
      getSubmissions
    , getSubmission
    , getSubmissionByURL
    , getSubmissionsByDomain
    , getBest
    , getChildComments
    , getDuplicateSubmissions
    , saveSubmission
    , unsaveSubmission
    , hideSubmissions
    , hideSubmission
    , unhideSubmissions
    , unhideSubmission
      -- * Creating, editing, and deleting
    , deleteSubmission
    , editSubmission
    , replyToSubmission
    , submitSelfPost
    , submitWithInlineMedia
    , submitLink
    , submitImage
    , submitVideo
    , submitPoll
    , submitGallery
    , submit
    , crosspost
    , setSubmissionReplies
      -- * Submission flair
    , getSubmissionFlairChoices
    , selectSubmissionFlair
      -- * Searching
    , search
      -- * Voting
      -- $vote
    , upvoteSubmission
    , downvoteSubmission
    , unvoteSubmission
      -- * Awards
    , awardSubmission
    , gildSubmission
      -- * Misc
    , reportSubmission
    , unmarkNSFW
    , markNSFW
    , setOC
    , unsetOC
    , setSpoiler
    , unsetSpoiler
      -- * Types
    , module M'
    ) where

import           Control.Monad                         ( void, when )
import           Control.Monad.Catch                   ( MonadThrow(throwM) )
import           Control.Monad.IO.Class                ( MonadIO(liftIO) )

import           Data.Aeson                            ( ToJSON(toJSON) )
import           Data.Generics.Product                 ( HasField(field) )
import           Data.Generics.Wrapped
                 ( wrappedFrom
                 , wrappedTo
                 )
import qualified Data.HashMap.Strict                   as HM
import qualified Data.Map                              as M
import           Data.Maybe                            ( fromMaybe )
import           Data.Sequence                         ( Seq((:<|), Empty) )
import           Data.Text                             ( Text )
import qualified Data.Text                             as T
import qualified Data.Text.Encoding                    as T
import           Data.Traversable                      ( for )

import           Lens.Micro

import           Network.HTTP.Client.MultipartFormData ( partBS, partFile )
import           Network.Reddit.Internal
import           Network.Reddit.Item
import           Network.Reddit.Subreddit
import           Network.Reddit.Types
import           Network.Reddit.Types.Comment
import           Network.Reddit.Types.Flair
import           Network.Reddit.Types.Submission
import           Network.Reddit.Types.Submission       as M'
                 ( Collection(Collection)
                 , CollectionID
                 , CollectionLayout(..)
                 , CrosspostOptions(CrosspostOptions)
                 , Fancypants
                 , GalleryImage(GalleryImage)
                 , InlineMedia(InlineMedia)
                 , InlineMediaType(..)
                 , NewCollection(NewCollection)
                 , NewSubmission(..)
                 , Poll(Poll)
                 , PollData(PollData)
                 , PollOption(PollOption)
                 , PollOptionID
                 , PostedSubmission
                 , ResultID(ResultID)
                 , S3UploadLease(S3UploadLease)
                 , Search(Search)
                 , SearchCategory
                 , SearchOpts(SearchOpts)
                 , SearchSort(..)
                 , SearchSyntax(..)
                 , Submission(Submission)
                 , SubmissionContent(..)
                 , SubmissionID(SubmissionID)
                 , SubmissionOptions(SubmissionOptions)
                 , mkCrosspostOptions
                 , mkGalleryImage
                 , mkPoll
                 , mkSearch
                 , mkSearchCategory
                 , mkSubmissionOptions
                 , writeInlineMedia
                 )
import           Network.Reddit.Utils

import           Paths_heddit

import qualified System.FilePath                       as FP

import           Web.FormUrlEncoded                    ( ToForm(toForm) )
import           Web.HttpApiData                       ( ToHttpApiData(..) )
import           Web.Internal.FormUrlEncoded           ( Form )

-- | Get a information on 'Submission's given a container of 'SubmissionID's
getSubmissions :: (MonadReddit m, Foldable t)
               => ItemOpts
               -> t SubmissionID
               -> m (Seq Submission)
getSubmissions = getMany

-- | Get information on a single submission. Throws an exception if no such
-- 'Submission' exists
getSubmission :: MonadReddit m => SubmissionID -> m Submission
getSubmission sid = getSubmissions defaultItemOpts [ sid ] >>= \case
    sub :<| _ -> pure sub
    _         -> throwM $ InvalidResponse "getSubmission: No results"

-- | Get a 'Submission' from a URL pointing to it, in one of the following forms:
--
--      * http{s}:\/\/redd.it\/\<ID\>
--      * http{s}:\/\/{www.}reddit.com\/comments\/\<ID\>\/
--      * http{s}:\/\/{www.}reddit.com\/r\/\<SUBREDDIT\>\/comments\/\<ID\>\/{NAME}
--      * http{s}:\/\/{www.}reddit.com\/gallery\/\<ID\>
--
getSubmissionByURL :: MonadReddit m => URL -> m Submission
getSubmissionByURL url = getSubmission =<< submissionIDFromURL url

-- | Get a @Listing@ of submissions based on their domain
getSubmissionsByDomain :: MonadReddit m
                       => Domain
                       -> Paginator SubmissionID Submission
                       -> m (Listing SubmissionID Submission)
getSubmissionsByDomain dm paginator =
    runAction defaultAPIAction
              { pathSegments = [ "domain", dm ]
              , requestData  = paginatorToFormData paginator
              }

-- | Get the \"best\" 'Submission's from the frontpage
getBest :: MonadReddit m
        => Paginator SubmissionID Submission
        -> m (Listing SubmissionID Submission)
getBest paginator = runAction defaultAPIAction
                              { pathSegments = [ "best" ]
                              , requestData  = paginatorToFormData paginator
                              }

-- | Get a submission\'s 'ChildComment's
getChildComments :: MonadReddit m => SubmissionID -> m (Seq ChildComment)
getChildComments sid = runAction @WithChildren r <&> wrappedTo
  where
    r = defaultAPIAction { pathSegments = [ "comments", toUrlPiece sid ] }

-- | Get a @Listing@ of 'Submission's that are marked as duplicates of the given
-- submission
getDuplicateSubmissions :: MonadReddit m => SubmissionID -> m (Seq Submission)
getDuplicateSubmissions sid =
    -- This endpoint is very strange. It returns an /array/ of @Listing@s, each of
    -- which contains a single submission in its @children@ field. Having tested it,
    -- it appears that the @after@ field is always @null@. Not sure if this is the
    -- correct way to deal with this, but getting a @Seq@ of subsmissions is a lot
    -- more ergonomic than a nested mess of @Listing@s
    runAction @[Listing SubmissionID Submission] r >>= \case
        []   -> pure Empty
        dups -> pure . mconcat $ dups <&> (^. field @"children")
  where
    r = defaultAPIAction { pathSegments = [ "duplicates", toUrlPiece sid ] }

-- | Save a submission
saveSubmission :: MonadReddit m => SubmissionID -> m ()
saveSubmission = save . SubmissionItemID

-- | Unsave a submission
unsaveSubmission :: MonadReddit m => SubmissionID -> m ()
unsaveSubmission = unsave . SubmissionItemID

-- | Hide the submissions corresponding to a container of 'SubmissionID's. The
-- submissions will no longer appear in your default view of submissions on the
-- subdreddit
hideSubmissions :: (MonadReddit m, Foldable t) => t SubmissionID -> m ()
hideSubmissions = hide "hide"

-- | Hide a single submission
hideSubmission :: MonadReddit m => SubmissionID -> m ()
hideSubmission sid = hideSubmissions [ sid ]

-- | Unhide the submissions corresponding to a container of 'SubmissionID's,
-- returning them to your default view
unhideSubmissions :: (MonadReddit m, Foldable t) => t SubmissionID -> m ()
unhideSubmissions = hide "unhide"

-- | Unhide a single submission
unhideSubmission :: MonadReddit m => SubmissionID -> m ()
unhideSubmission sid = unhideSubmissions [ sid ]

hide :: (MonadReddit m, Foldable t) => Text -> t SubmissionID -> m ()
hide path ss =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", path ]
               , method       = POST
               , requestData  = mkTextFormData [ ("id", fullname ss) ]
               }

-- | Delete a submission that the currently authenticated user has authored
deleteSubmission :: MonadReddit m => SubmissionID -> m ()
deleteSubmission = delete . SubmissionItemID

-- | Edit a submission, receving an updated 'Submission' in response
editSubmission :: MonadReddit m => SubmissionID -> Body -> m Submission
editSubmission (SubmissionItemID -> sid) txt = edit sid txt >>= \case
    SubmissionItem s -> pure s
    CommentItem _    -> throwM
        $ InvalidResponse "editSubmission: Expected a Submission, got a Comment"

-- | Leave a reply on a submission, returning the new 'Comment' that has been
-- created
replyToSubmission :: MonadReddit m => SubmissionID -> Body -> m Comment
replyToSubmission = reply . SubmissionItemID

-- | Submit a new self-post (with no inline media)
submitSelfPost
    :: MonadReddit m => SubredditName -> Title -> Body -> m Submission
submitSelfPost sname t b = submit $ SelfPost b (mkSubmissionOptions sname t)

-- | Submit a new self-post with inline media. The @Body@ must be markdown-
-- formatted text containing placeholders. Each placeholder must correspond to
-- exactly one of the 'InlineMedia's\' @key@ field. For example, given the
-- following:
--
-- >>> gif = InlineMedia InlineGIF "/path/to/a.gif" "gif" Nothing
-- >>> vid = InlineMedia InlineVideo "/path/to/a.mp4" "vid" (Just "my video")
-- >>> body = "Body with an inline gif #gif# and video #vid#"
-- >>> submitWithInlineMedia Nothing body [gif, vid] myOptions
--
-- Will automatically produce (internally) the following markdown body for
-- the submission, after uploading the media to Reddit\'s servers:
--
-- @
--    Body with an inline gif
--
--    ![gif](j2k2xmfl3 \"\")
--
--     and video
--
--    ![video](ccdoe02xu \"my video\")
-- @
--
submitWithInlineMedia
    :: (MonadReddit m, Traversable t)
    => Maybe Char
    -- ^ Delimiter for the placeholders in the body, defaults to @#@
    -> Body -- ^ Should contain the placeholders, as described above
    -> t InlineMedia
    -- ^ The @key@ field in each 'InlineMedia' must correspond to
    -- exactly one of the placeholders in the body
    -> SubmissionOptions
    -> m Submission
submitWithInlineMedia (T.singleton . fromMaybe '#' -> delim) b media sos = do
    uploaded <- for media $ \m@InlineMedia { mediaPath } ->
        inlineMediaToUpload m <$> uploadMedia SelfPostUpload mediaPath
    rtjson <- putOnTheFancypants $ foldr replacePlaceholders b uploaded
    getSubmissionByURL . wrappedTo
        =<< runAction @PostedSubmission
                      (submissionAction . toForm $ WithInlineMedia rtjson sos)
  where
    replacePlaceholders im@InlineMediaUpload { .. } md =
        T.replace (delim <> key <> delim) (writeInlineMedia im) md

putOnTheFancypants :: MonadReddit m => Body -> m Fancypants
putOnTheFancypants b =
    runAction defaultAPIAction
              { pathSegments = [ "api", "convert_rte_body_format" ]
              , method       = POST
              , requestData  = mkTextFormData [ ("output_mode", "rtjson")
                                              , ("markdown_text", b)
                                              ]
              }

-- | Submit a new link post
submitLink :: MonadReddit m => SubredditName -> Title -> URL -> m Submission
submitLink sname t u = submit $ Link u (mkSubmissionOptions sname t)

-- | Post an image submission to the subreddit, uploading the image file. This
-- action does not currently return the posted submission upon success
submitImage :: MonadReddit m
            => FilePath -- ^ Must be a valid image file
            -> SubmissionOptions
            -> m ()
submitImage fp sos = do
    url <- uploadMedia LinkUpload fp
    runAction_ . submissionAction . toForm $ ImagePost url sos

-- | Post an image submission to the subreddit, uploading the image file. This
-- action does not currently return the posted submission upon success
submitVideo :: MonadReddit m
            => Bool -- ^ If @True@, creates a silent \"videogif\"
            -> FilePath -- ^ Must be a valid video file
            -> Maybe FilePath
            -- ^ Must be a valid image file, for the video thumbnail. If
            -- @Nothing@, a PNG of the Haskell logo will be used
            -> SubmissionOptions
            -> m ()
submitVideo videogif fp thmbFP sos = do
    url <- uploadMedia LinkUpload fp
    thmbURL <- uploadMedia LinkUpload =<< maybe defaultPNG pure thmbFP
    runAction_ . submissionAction . toForm
        $ VideoPost url thmbURL videogif sos
  where
    defaultPNG = liftIO $ getDataFileName "assets/haskell.png"

-- | Post a poll to the subreddit. See 'mkPoll' to create a new 'Poll'
submitPoll
    :: (MonadReddit m, Foldable t) => Poll t -> SubmissionOptions -> m ()
submitPoll poll sos =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "submit_poll_post.json" ]
               , method       = POST
               , requestData  = WithJSON . toJSON $ PollSubmission poll sos
               }

-- | Post a gallery to the subreddit, given a container of 'GalleryImage's. See
-- 'mkGalleryImage' to create the images with default values. This action also
-- ensures that the image container has at least two elements
submitGallery :: (MonadReddit m, Traversable t)
              => t GalleryImage
              -> SubmissionOptions
              -> m ()
submitGallery imgs sos = do
    when (length imgs < 2) . throwM
        $ InvalidRequest --
        "submitGallery: Galleries must consist of at least 2 images"
    gallery <- for imgs $ \img@GalleryImage { imagePath } ->
        galleryImageToUpload img <$> uploadMedia GalleryUpload imagePath
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "submit_gallery_post.json" ]
               , method       = POST
               , requestData  =
                     WithJSON . toJSON $ GallerySubmission gallery sos
               }

-- | Submit a new submission, returning the 'Submission' that has been created.
-- This action allows for more fine-grained control over submission options. You
-- can use 'mkSubmissionOptions' for defaults and update it as needed. See also
-- 'submitImage', 'submitPoll', and 'submitGallery', which should be used when
-- submitting anything beyond a self-text or link post
submit :: MonadReddit m => NewSubmission -> m Submission
submit (toForm -> n) = getSubmissionByURL . wrappedTo
    =<< runAction @PostedSubmission (submissionAction n)

-- | Crosspost an existing submission. You must be a subscriber of the subreddit
-- you are posting into. See also 'mkCrosspostOptions'
crosspost :: MonadReddit m => SubmissionID -> CrosspostOptions -> m Submission
crosspost sid cpos = getSubmission
    =<< (runAction @PostedCrosspost r <&> wrappedTo)
  where
    r = submissionAction
        $ toForm cpos <> mkTextForm [ ("crosspost_fullname", fullname sid) ]

submissionAction :: Form -> APIAction a
submissionAction form = defaultAPIAction
    { pathSegments = [ "api", "submit" ]
    , method       = POST
    , requestData  = WithForm form
    }

-- Calls an undocumented API endpoint to upload media to an s3 bucket. It returns
-- the URL of the uploaded media along with a a websocket URL that can be used
-- to detect the upload completion
uploadMedia :: MonadReddit m => UploadType -> FilePath -> m UploadURL
uploadMedia uty fp = do
    mimetype <- case FP.takeExtension fp of
        ext
            | Just mt <- M.lookup ext mimeMap -> pure mt
            | otherwise ->
                throwM $ InvalidRequest "uploadMedia: invalid media file type"

    S3UploadLease { .. }
        <- runAction defaultAPIAction
                     { pathSegments = [ "api", "media", "asset.json" ]
                     , 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      = False
                      }
    pure $ case uty of
        LinkUpload -> wrappedFrom $ T.intercalate "/" [ action, key ]
        _          -> assetID
  where
    mimeMap               =
        M.fromList [ (".png", "image/png")
                   , (".mov", "video/quicktime")
                   , (".mp4", "video/mp4")
                   , (".jpg", "image/jpeg")
                   , (".jpeg", "image/jpeg")
                   , (".gif", "image/gif")
                   ]

    mkParts name value ps = partBS name (T.encodeUtf8 value) : ps

-- | Enable/disable inbox replies for a submission
setSubmissionReplies :: MonadReddit m => Bool -> SubmissionID -> m ()
setSubmissionReplies p = setInboxReplies p . SubmissionItemID

-- | Select a 'FlairChoice' for a submission.
selectSubmissionFlair
    :: MonadReddit m => FlairSelection -> SubmissionID -> m ()
selectSubmissionFlair (FlairSelection FlairChoice { .. } _ sname) sid =
    runAction_ defaultAPIAction
               { pathSegments = subAPIPath sname "flairselector"
               , method       = POST
               , requestData  = WithForm
                     $ mkTextForm [ ("link", fullname sid)
                                  , ( "flair_template_id"
                                    , toQueryParam templateID
                                    )
                                  ]
               }

-- | 'Search' through Reddit 'Submission's, either side-wide or constrained to
-- one subreddit. See 'mkSearch' to create the initial 'Search'
search :: MonadReddit m
       => Search
       -> Paginator ResultID Submission
       -> m (Listing ResultID Submission)
search sch@Search { .. } paginator =
    runAction defaultAPIAction { pathSegments, requestData }
  where
    pathSegments = [ "search" ]
        & maybe id (\s -> (<>) [ "r", toUrlPiece s ]) subreddit

    requestData  = WithForm $ toForm paginator <> toForm sch

-- | Upvote a submission
upvoteSubmission :: MonadReddit m => SubmissionID -> m ()
upvoteSubmission = vote Upvote . SubmissionItemID

-- | Downvote a submission
downvoteSubmission :: MonadReddit m => SubmissionID -> m ()
downvoteSubmission = vote Downvote . SubmissionItemID

-- | Remove an existing vote on a submission
unvoteSubmission :: MonadReddit m => SubmissionID -> m ()
unvoteSubmission = vote Unvote . SubmissionItemID

-- | Grant an 'Award' to a submission. See 'mkAward' for creating an award with
-- default values, as well as the pattern synonyms for common awards
awardSubmission
    :: MonadReddit m => Award -> SubmissionID -> m AwardingsSummary
awardSubmission a = award a . SubmissionItemID

-- | Convenience action to anonymously give 'Gold' to the author of a submission,
-- without a message. See 'awardSubmission' if you need more fine-grained control
gildSubmission :: MonadReddit m => SubmissionID -> m AwardingsSummary
gildSubmission = gild . SubmissionItemID

-- | Report a submission to the subreddit\'s mods
reportSubmission :: MonadReddit m => Report -> SubmissionID -> m ()
reportSubmission r = report r . SubmissionItemID

-- | Mark a submission NSFW. The submission author can use this as well as the
-- subreddit moderators
markNSFW :: MonadReddit m => SubmissionID -> m ()
markNSFW sid =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "marknsfw" ]
               , method       = POST
               , requestData  = mkTextFormData [ ("id", fullname sid) ]
               }

-- | Unmark a submission NSFW. The submission author can use this as well as the
-- subreddit moderators
unmarkNSFW :: MonadReddit m => SubmissionID -> m ()
unmarkNSFW sid =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "unmarknsfw" ]
               , method       = POST
               , requestData  = mkTextFormData [ ("id", fullname sid) ]
               }

-- | Mark a submission as original content. In order for normal users to use
-- this feature in addition to mods, the beta \"Original Content\" feature must
-- be enabled in the subreddit settings
setOC :: MonadReddit m => SubredditName -> SubmissionID -> m ()
setOC = setUnsetOC True

-- | Unmark a submission as original content. In order for normal users to use
-- this feature in addition to mods, the beta \"Original Content\" feature must
-- be enabled in the subreddit settings
unsetOC :: MonadReddit m => SubredditName -> SubmissionID -> m ()
unsetOC = setUnsetOC False

setUnsetOC :: MonadReddit m => Bool -> SubredditName -> SubmissionID -> m ()
setUnsetOC shouldSet sname sid =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "set_original_content" ]
               , method       = POST
               , requestData  =
                     mkTextFormData [ ("id", toQueryParam sid)
                                    , ("fullname", fullname sid)
                                    , ( "should_set_oc"
                                      , toQueryParam shouldSet
                                      )
                                    , ("execute", toQueryParam False)
                                    , ("r", toQueryParam sname)
                                    ]
               }

-- | Mark the submission as containing spoilers
setSpoiler :: MonadReddit m => SubmissionID -> m ()
setSpoiler sid =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "spoiler" ]
               , method       = POST
               , requestData  = mkTextFormData [ ("id", fullname sid) ]
               }

-- | Unmark the submission as containing spoilers
unsetSpoiler :: MonadReddit m => SubmissionID -> m ()
unsetSpoiler sid =
    runAction_ defaultAPIAction
               { pathSegments = [ "api", "unspoiler" ]
               , method       = POST
               , requestData  = mkTextFormData [ ("id", fullname sid) ]
               }
--
-- $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.
--