{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.Reddit.Me
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- Actions related to the currently logged-in user, such as accounts, friends,
-- etc... For actions related to other users, see "Network.Reddit.User"
--
module Network.Reddit.Me
    (  -- * Actions
      getMe
    , getPreferences
    , updatePreferences
    , getMyOverview
    , getMySaved
    , getMyComments
    , getMySubmissions
    , getMyHidden
    , getMyFriends
    , getMyBlocked
    , getMyKarma
    , makeFriend
    , unFriend
    , blockUser
    , needsCaptcha
    , getMyFlair
    , setMyFlair
    , getMySubscribed
    , getMyModerated
    , getMyContributing
    , getMyMultireddits
    ) where

import           Control.Monad.Catch
                 ( MonadCatch(catch)
                 , MonadThrow(throwM)
                 )

import           Data.Aeson                       ( KeyValue((.=)), object )
import           Data.Bool                        ( bool )
import           Data.Generics.Wrapped            ( wrappedTo )
import           Data.Sequence                    ( Seq )
import           Data.Text                        ( Text )

import           Lens.Micro

import           Network.Reddit.Internal
import           Network.Reddit.Types
import           Network.Reddit.Types.Account
import           Network.Reddit.Types.Comment
import           Network.Reddit.Types.Flair
import           Network.Reddit.Types.Item
import           Network.Reddit.Types.Multireddit
import           Network.Reddit.Types.Submission
import           Network.Reddit.Types.Subreddit
import           Network.Reddit.User
import           Network.Reddit.Utils

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

-- | Get account information for the currently logged-in user
getMe :: MonadReddit m => m Account
getMe :: m Account
getMe = APIAction Account -> m Account
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [PathSegment]
forall a. Monoid a => a
mempty }

-- | Get the user 'Preferences' for the currently authenticated user
getPreferences :: MonadReddit m => m Preferences
getPreferences :: m Preferences
getPreferences =
    APIAction Preferences -> m Preferences
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"prefs" ] }

-- | Update the authenticated users 'Preferences'. Returns the new preferences
-- upon success
--
-- __Warning__: Invalid fields or values are silently discarded by this
-- endpoint. If you wish to check that an update has succeeded, consider
-- an equality test between the existing preferences and the value returned
-- by this action
updatePreferences :: MonadReddit m => Preferences -> m Preferences
updatePreferences :: Preferences -> m Preferences
updatePreferences Preferences
prefs =
    APIAction Preferences -> m Preferences
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction
              { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"prefs" ]
              , $sel:method:APIAction :: Method
method       = Method
PATCH
              , $sel:requestData:APIAction :: WithData
requestData  = [(PathSegment, PathSegment)] -> WithData
mkTextFormData [ (PathSegment
"json", Preferences -> PathSegment
forall a. ToJSON a => a -> PathSegment
textEncode Preferences
prefs) ]
              }

-- | Get an overview of the authenticated user\'s 'Comment's and 'Submission's
getMyOverview
    :: MonadReddit m => Paginator ItemID Item -> m (Listing ItemID Item)
getMyOverview :: Paginator ItemID Item -> m (Listing ItemID Item)
getMyOverview Paginator ItemID Item
paginator = do
    Account { Username
$sel:username:Account :: Account -> Username
username :: Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    Username -> Paginator ItemID Item -> m (Listing ItemID Item)
forall (m :: * -> *).
MonadReddit m =>
Username -> Paginator ItemID Item -> m (Listing ItemID Item)
getUserOverview Username
username Paginator ItemID Item
paginator

-- | Get items that the authenticated user has saved
getMySaved
    :: MonadReddit m => Paginator ItemID Item -> m (Listing ItemID Item)
getMySaved :: Paginator ItemID Item -> m (Listing ItemID Item)
getMySaved Paginator ItemID Item
paginator = do
    Account { Username
username :: Username
$sel:username:Account :: Account -> Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    Username -> Paginator ItemID Item -> m (Listing ItemID Item)
forall (m :: * -> *).
MonadReddit m =>
Username -> Paginator ItemID Item -> m (Listing ItemID Item)
getUserSaved Username
username Paginator ItemID Item
paginator

-- | Get an overview of the authenticated user\'s 'Comment's
getMyComments :: MonadReddit m
              => Paginator CommentID Comment
              -> m (Listing CommentID Comment)
getMyComments :: Paginator CommentID Comment -> m (Listing CommentID Comment)
getMyComments Paginator CommentID Comment
paginator = do
    Account { Username
username :: Username
$sel:username:Account :: Account -> Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    Username
-> Paginator CommentID Comment -> m (Listing CommentID Comment)
forall (m :: * -> *).
MonadReddit m =>
Username
-> Paginator CommentID Comment -> m (Listing CommentID Comment)
getUserComments Username
username Paginator CommentID Comment
paginator

-- | Get an overview of the authenticated user\'s 'Submission's
getMySubmissions :: MonadReddit m
                 => Paginator SubmissionID Submission
                 -> m (Listing SubmissionID Submission)
getMySubmissions :: Paginator SubmissionID Submission
-> m (Listing SubmissionID Submission)
getMySubmissions Paginator SubmissionID Submission
paginator = do
    Account { Username
username :: Username
$sel:username:Account :: Account -> Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    Username
-> Paginator SubmissionID Submission
-> m (Listing SubmissionID Submission)
forall (m :: * -> *).
MonadReddit m =>
Username
-> Paginator SubmissionID Submission
-> m (Listing SubmissionID Submission)
getUserSubmissions Username
username Paginator SubmissionID Submission
paginator

-- | Get items that the authenticated user has hidden
getMyHidden
    :: MonadReddit m => Paginator ItemID Item -> m (Listing ItemID Item)
getMyHidden :: Paginator ItemID Item -> m (Listing ItemID Item)
getMyHidden Paginator ItemID Item
paginator = do
    Account { Username
username :: Username
$sel:username:Account :: Account -> Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    Username -> Paginator ItemID Item -> m (Listing ItemID Item)
forall (m :: * -> *).
MonadReddit m =>
Username -> Paginator ItemID Item -> m (Listing ItemID Item)
getUserHidden Username
username Paginator ItemID Item
paginator

-- | Get the 'Friend's of the currently logged-in user
getMyFriends :: MonadReddit m => m (Seq Friend)
getMyFriends :: m (Seq Friend)
getMyFriends = APIAction FriendList -> m FriendList
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction @FriendList APIAction FriendList
forall a. APIAction a
r m FriendList -> (FriendList -> Seq Friend) -> m (Seq Friend)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FriendList -> Seq Friend
forall s t a b. Wrapped s t a b => s -> a
wrappedTo
  where
    r :: APIAction a
r = APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"friends" ] }

-- | Get blocked users (as 'Friend's) of the currently logged-in user
getMyBlocked :: MonadReddit m => m (Seq Friend)
getMyBlocked :: m (Seq Friend)
getMyBlocked = APIAction FriendList -> m FriendList
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction @FriendList APIAction FriendList
forall a. APIAction a
r m FriendList -> (FriendList -> Seq Friend) -> m (Seq Friend)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FriendList -> Seq Friend
forall s t a b. Wrapped s t a b => s -> a
wrappedTo
  where
    r :: APIAction a
r = APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"prefs", PathSegment
"blocked" ] }

-- | Get a breakdown of the current user\'s karma
getMyKarma :: MonadReddit m => m (Seq Karma)
getMyKarma :: m (Seq Karma)
getMyKarma = APIAction KarmaList -> m KarmaList
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction @KarmaList APIAction KarmaList
forall a. APIAction a
r m KarmaList -> (KarmaList -> Seq Karma) -> m (Seq Karma)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> KarmaList -> Seq Karma
forall s t a b. Wrapped s t a b => s -> a
wrappedTo
  where
    r :: APIAction a
r = APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"karma" ] }

-- | Make friends with another user
makeFriend :: MonadReddit m => Maybe Text -> Username -> m Friend
makeFriend :: Maybe PathSegment -> Username -> m Friend
makeFriend Maybe PathSegment
note Username
uname =
    APIAction Friend -> m Friend
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction
              { $sel:method:APIAction :: Method
method       = Method
PUT
              , $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"friends", Username -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toUrlPiece Username
uname ]
              , $sel:requestData:APIAction :: WithData
requestData  = Value -> WithData
WithJSON (Value -> WithData) -> ([Pair] -> Value) -> [Pair] -> WithData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object
                    ([Pair] -> WithData) -> [Pair] -> WithData
forall a b. (a -> b) -> a -> b
$ [ PathSegment
"name" PathSegment -> PathSegment -> Pair
forall kv v. (KeyValue kv, ToJSON v) => PathSegment -> v -> kv
.= Username -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam Username
uname ]
                    [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> (PathSegment -> [Pair]) -> Maybe PathSegment -> [Pair]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Pair -> [Pair]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> [Pair]) -> (PathSegment -> Pair) -> PathSegment -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathSegment
"note" PathSegment -> PathSegment -> Pair
forall kv v. (KeyValue kv, ToJSON v) => PathSegment -> v -> kv
.=)) Maybe PathSegment
note
              }

-- | Remove an existing friend
unFriend :: MonadReddit m => Username -> m ()
unFriend :: Username -> m ()
unFriend Username
uname =
    APIAction () -> m ()
forall (m :: * -> *). MonadReddit m => APIAction () -> m ()
runAction_ APIAction Any
forall a. APIAction a
defaultAPIAction
               { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment] -> [PathSegment]
mePath [ PathSegment
"friends", Username -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toUrlPiece Username
uname ]
               , $sel:method:APIAction :: Method
method       = Method
DELETE
               }

-- | Block another user. Note that this cannot be reversed through the API; the
-- logged-in user would need to manually revoke the block by visiting Reddit's
-- website
blockUser :: MonadReddit m => UserID -> m ()
blockUser :: UserID -> m ()
blockUser UserID
uid =
    APIAction () -> m ()
forall (m :: * -> *). MonadReddit m => APIAction () -> m ()
runAction_ APIAction Any
forall a. APIAction a
defaultAPIAction
               { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"api", PathSegment
"block_user" ]
               , $sel:method:APIAction :: Method
method       = Method
POST
               , $sel:requestData:APIAction :: WithData
requestData  = Form -> WithData
WithForm
                     (Form -> WithData) -> Form -> WithData
forall a b. (a -> b) -> a -> b
$ [(PathSegment, PathSegment)] -> Form
forall a. ToForm a => a -> Form
toForm @[(Text, Text)] [ (PathSegment
"account_id", UserID -> PathSegment
forall a. Thing a => a -> PathSegment
fullname UserID
uid) ]
               }

-- | Get the authenticated user\'s current flair for the given subreddit, if such
-- flair exists
getMyFlair :: MonadReddit m => SubredditName -> m (Maybe UserFlair)
getMyFlair :: SubredditName -> m (Maybe UserFlair)
getMyFlair SubredditName
sname = m (Maybe UserFlair)
-> (APIException -> m (Maybe UserFlair)) -> m (Maybe UserFlair)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch @_ @APIException m (Maybe UserFlair)
action ((APIException -> m (Maybe UserFlair)) -> m (Maybe UserFlair))
-> (APIException -> m (Maybe UserFlair)) -> m (Maybe UserFlair)
forall a b. (a -> b) -> a -> b
$ \case
    JSONParseError PathSegment
_ ByteString
_ -> Maybe UserFlair -> m (Maybe UserFlair)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserFlair
forall a. Maybe a
Nothing
    APIException
e                  -> APIException -> m (Maybe UserFlair)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e
  where
    action :: m (Maybe UserFlair)
action = APIAction CurrentUserFlair -> m CurrentUserFlair
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction @CurrentUserFlair APIAction CurrentUserFlair
forall a. APIAction a
r m CurrentUserFlair
-> (CurrentUserFlair -> Maybe UserFlair) -> m (Maybe UserFlair)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UserFlair -> Maybe UserFlair
forall a. a -> Maybe a
Just (UserFlair -> Maybe UserFlair)
-> (CurrentUserFlair -> UserFlair)
-> CurrentUserFlair
-> Maybe UserFlair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrentUserFlair -> UserFlair
forall s t a b. Wrapped s t a b => s -> a
wrappedTo

    r :: APIAction a
r      = APIAction Any
forall a. APIAction a
defaultAPIAction
        { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = SubredditName -> PathSegment -> [PathSegment]
subAPIPath SubredditName
sname PathSegment
"flairselector"  --
        , $sel:method:APIAction :: Method
method       = Method
POST
        }

-- | Set the flair for the authenticated user, provided that the given subreddit
-- allows users to perform this action. The @text@ field is ignored unless it is
-- @Just@ /and/ the @textEditable@ field of the contained 'FlairChoice' is @True@
setMyFlair :: MonadReddit m => FlairSelection -> m ()
setMyFlair :: FlairSelection -> m ()
setMyFlair (FlairSelection FlairChoice { Bool
Maybe PathSegment
PathSegment
FlairText
$sel:cssClass:FlairChoice :: FlairChoice -> Maybe PathSegment
$sel:textEditable:FlairChoice :: FlairChoice -> Bool
$sel:text:FlairChoice :: FlairChoice -> FlairText
$sel:templateID:FlairChoice :: FlairChoice -> PathSegment
cssClass :: Maybe PathSegment
textEditable :: Bool
text :: FlairText
templateID :: PathSegment
.. } Maybe PathSegment
txt SubredditName
sname) = do
    Account { Username
username :: Username
$sel:username:Account :: Account -> Username
username } <- m Account
forall (m :: * -> *). MonadReddit m => m Account
getMe
    APIAction () -> m ()
forall (m :: * -> *). MonadReddit m => APIAction () -> m ()
runAction_ APIAction Any
forall a. APIAction a
defaultAPIAction
               { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = SubredditName -> PathSegment -> [PathSegment]
subAPIPath SubredditName
sname PathSegment
"selectflair"
               , $sel:method:APIAction :: Method
method       = Method
POST
               , $sel:requestData:APIAction :: WithData
requestData  = Form -> WithData
WithForm
                     (Form -> WithData) -> Form -> WithData
forall a b. (a -> b) -> a -> b
$ [(PathSegment, PathSegment)] -> Form
mkTextForm [ ( PathSegment
"flair_template_id"
                                    , PathSegment -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam PathSegment
templateID
                                    )
                                  , (PathSegment
"name", Username -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam Username
username)
                                  ]
                     Form -> Form -> Form
forall a. Semigroup a => a -> a -> a
<> Form -> (PathSegment -> Form) -> Maybe PathSegment -> Form
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Form
forall a. Monoid a => a
mempty PathSegment -> Form
forall a. ToHttpApiData a => a -> Form
sendText Maybe PathSegment
txt
               }
  where
    sendText :: a -> Form
sendText a
t =
        [(PathSegment, PathSegment)] -> Form
mkTextForm ([(PathSegment, PathSegment)] -> Form)
-> [(PathSegment, PathSegment)] -> Form
forall a b. (a -> b) -> a -> b
$ [(PathSegment, PathSegment)]
-> [(PathSegment, PathSegment)]
-> Bool
-> [(PathSegment, PathSegment)]
forall a. a -> a -> Bool -> a
bool [(PathSegment, PathSegment)]
forall a. Monoid a => a
mempty [ (PathSegment
"text", a -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam a
t) ] Bool
textEditable

-- | Find out if the authenticated user needs to complete a captcha when performing
-- certain transactions, such as submitting a link or sending a private message
needsCaptcha :: MonadReddit m => m Bool
needsCaptcha :: m Bool
needsCaptcha = APIAction Bool -> m Bool
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction
                         { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"api", PathSegment
"needs_captcha.json" ]
                         , $sel:needsAuth:APIAction :: Bool
needsAuth    = Bool
False
                         }

getMySubscribed, getMyModerated, getMyContributing
    :: MonadReddit m
    => Paginator SubredditID Subreddit
    -> m (Listing SubredditID Subreddit)

-- | Get a listing of subreddits the currently authenticated user is subscribed to
getMySubscribed :: Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
getMySubscribed = PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
forall (m :: * -> *).
MonadReddit m =>
PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
mySubreddits PathSegment
"subscriber"

-- | Get a listing of subreddits the currently authenticated user is a mod in
getMyModerated :: Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
getMyModerated = PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
forall (m :: * -> *).
MonadReddit m =>
PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
mySubreddits PathSegment
"moderator"

-- | Get a listing of subreddits the currently authenticated user is an approved
-- user in
getMyContributing :: Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
getMyContributing = PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
forall (m :: * -> *).
MonadReddit m =>
PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
mySubreddits PathSegment
"contributor"

mySubreddits :: MonadReddit m
             => PathSegment
             -> Paginator SubredditID Subreddit
             -> m (Listing SubredditID Subreddit)
mySubreddits :: PathSegment
-> Paginator SubredditID Subreddit
-> m (Listing SubredditID Subreddit)
mySubreddits PathSegment
path Paginator SubredditID Subreddit
paginator =
    APIAction (Listing SubredditID Subreddit)
-> m (Listing SubredditID Subreddit)
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction
              { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"subreddits", PathSegment
"mine", PathSegment
path ]
              , $sel:requestData:APIAction :: WithData
requestData  = Paginator SubredditID Subreddit -> WithData
forall t a. (Thing t, Paginable a) => Paginator t a -> WithData
paginatorToFormData Paginator SubredditID Subreddit
paginator
              }

-- | Get all of the multireddits of the authenticated user
getMyMultireddits :: MonadReddit m => m (Seq Multireddit)
getMyMultireddits :: m (Seq Multireddit)
getMyMultireddits =
    APIAction (Seq Multireddit) -> m (Seq Multireddit)
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction APIAction Any
forall a. APIAction a
defaultAPIAction { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"api", PathSegment
"multi", PathSegment
"mine" ] }

mePath :: [PathSegment] -> [PathSegment]
mePath :: [PathSegment] -> [PathSegment]
mePath [PathSegment]
ps = [ PathSegment
"api", PathSegment
"v1", PathSegment
"me" ] [PathSegment] -> [PathSegment] -> [PathSegment]
forall a. Semigroup a => a -> a -> a
<> [PathSegment]
ps