{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Network.Reddit.Types.Account
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types.Account
    ( Username
    , mkUsername
    , UserID(UserID)
    , Account(..)
    , AccountSearchOpts(..)
    , AccountSearchSort(..)
    , Friend(..)
    , FriendList
    , Karma(..)
    , KarmaList
    , Trophy(..)
    , TrophyList
    , UserSummary(..)
    , UserSummaryList
    , Preferences(..)
    , MediaPreference(..)
    , AcceptPMs(..)
    ) where

import           Control.Monad                  ( (<=<) )
import           Control.Monad.Catch            ( MonadThrow )

import           Data.Aeson
                 ( (.:)
                 , (.:?)
                 , Array
                 , FromJSON(..)
                 , Options(fieldLabelModifier, constructorTagModifier)
                 , ToJSON(toJSON)
                 , Value(..)
                 , defaultOptions
                 , genericParseJSON
                 , genericToJSON
                 , withArray
                 , withObject
                 , withText
                 )
import           Data.Aeson.Casing              ( snakeCase )
import           Data.Char                      ( toLower )
import           Data.Coerce                    ( coerce )
import           Data.Foldable                  ( asum )
import           Data.Generics.Product          ( HasField(field) )
import qualified Data.HashMap.Strict            as HM
import           Data.Maybe                     ( catMaybes )
import           Data.Sequence                  ( Seq )
import           Data.Text                      ( Text )
import           Data.Time                      ( UTCTime )
import           Data.Traversable               ( for )

import           GHC.Exts                       ( IsList(toList), fromList )
import           GHC.Generics                   ( Generic )

import           Lens.Micro

import           Network.Reddit.Types.Internal
import           Network.Reddit.Types.Subreddit

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

-- | Reddit username
newtype Username = Username Text
    deriving stock ( Show, Generic )
    deriving newtype ( FromJSON, ToJSON, ToHttpApiData )
    deriving ( Eq ) via CIText Username

-- | Smart constructor for 'Username', which must be between 3 and 20 chars,
-- and may only include upper/lowercase alphanumeric chars, underscores, or
-- hyphens
mkUsername :: MonadThrow m => Text -> m Username
mkUsername = validateName Nothing Nothing "Username"

-- | A unique, site-wide ID for an account
newtype UserID = UserID Text
    deriving stock ( Show, Generic )
    deriving newtype ( Eq )

instance FromJSON UserID where
    parseJSON = withText "UserID" (coerce . dropTypePrefix AccountKind)

instance Thing UserID where
    fullname (UserID uid) = prependType AccountKind uid

-- | Account information. @Maybe@ fields denote data that Reddit sets to null if
-- the requester does not own the account in question. Note that this does /not/
-- include all of the possible fields that may be present in Reddit's response -
-- which are quite numerous in total and poorly documented
data Account = Account
    { userID           :: UserID
    , username         :: Username
    , created          :: UTCTime
    , commentKarma     :: Int
    , isGold           :: Bool
    , isMod            :: Bool
    , linkKarma        :: Int
    , inboxCount       :: Maybe Integer
    , modHash          :: Maybe Text
    , over18           :: Maybe Bool
    , hasMail          :: Maybe Bool
    , hasModMail       :: Maybe Bool
    , hasVerifiedEmail :: Maybe Bool
    }
    deriving stock ( Show, Generic )

instance FromJSON Account where
    parseJSON v = asum [ withObject "Account" accountP v
                       , withKind AccountKind "Account" accountP v
                       ]
      where
        accountP o = Account <$> (o .: "id")
            <*> o .: "name"
            <*> (integerToUTC <$> o .: "created_utc")
            <*> o .: "comment_karma"
            <*> o .: "is_gold"
            <*> o .: "is_mod"
            <*> o .: "link_karma"
            <*> o .:? "inbox_count"
            <*> o .:? "modhash"
            <*> o .:? "over_18"
            <*> o .:? "has_mail"
            <*> o .:? "has_mod_mail"
            <*> o .:? "has_verified_email"

instance Paginable Account where
    type PaginateOptions Account = AccountSearchOpts

    type PaginateThing Account = UserID

    defaultOpts = AccountSearchOpts
        { resultSort      = RelevantAccounts
        , typeaheadActive = Nothing
        , searchQueryID   = Nothing
        }

    getFullname Account { userID } = userID

-- | Options for search @Listing@s of 'Account's
data AccountSearchOpts = AccountSearchOpts
    { resultSort      :: AccountSearchSort
    , typeaheadActive :: Maybe Bool
      -- | A UUID. This is not clearly documented in the API docs. Presumably,
      -- it refers to an identifier for an existing search
    , searchQueryID   :: Maybe Text
    }
    deriving stock ( Show, Eq, Generic )

instance ToForm AccountSearchOpts where
    toForm AccountSearchOpts { .. } = fromList
        $ [ ("sort", toQueryParam resultSort) ]
        <> catMaybes [ ("typeahead_active", ) . toQueryParam
                       <$> typeaheadActive
                     , ("search_query_id", ) . toQueryParam <$> searchQueryID
                     ]

-- | The item sort for 'Account' searches
data AccountSearchSort
    = RelevantAccounts
    | ActiveAccounts
    deriving stock ( Show, Eq, Generic )

instance ToHttpApiData AccountSearchSort where
    toQueryParam = \case
        RelevantAccounts -> "relevance"
        ActiveAccounts   -> "activity"

-- | A user\'s friend
data Friend = Friend
    { username :: Username
    , userID   :: UserID
    , since    :: UTCTime
    , note     :: Maybe Text
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Friend where
    parseJSON = withObject "Friend" $ \o -> Friend <$> o .: "name"
        <*> o .: "id"
        <*> (integerToUTC <$> o .: "date")
        <*> (maybe (pure Nothing) nothingTxtNull =<< o .:? "note")

-- | Wrapper for parsing JSON objects listing 'Friend's
newtype FriendList = FriendList (Seq Friend)
    deriving stock ( Show, Generic )

instance FromJSON FriendList where
    parseJSON = withKind UserListKind "FriendList"
        $ fmap (FriendList . fromList) . (friendsP <=< (.: "children"))
      where
        friendsP = withArray "[Friend]" (traverse parseJSON . toList)

-- | Information about a user\'s karma
data Karma = Karma
    { subreddit    :: SubredditName
    , commentKarma :: Integer
    , linkKarma    :: Integer
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Karma where
    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier }
      where
        fieldLabelModifier = \case
            "subreddit" -> "sr"
            s           -> snakeCase s

-- | Wrapper for parsing JSON array of 'Karma'
newtype KarmaList = KarmaList (Seq Karma)
    deriving stock ( Show, Generic )

instance FromJSON KarmaList where
    parseJSON = withKind @Array KarmaListKind "KarmaList"
        $ fmap (KarmaList . fromList) . traverse parseJSON . toList

-- | A Reddit award, such as the \"one-year club\"
data Trophy = Trophy
    { name        :: Name
    , trophyID    :: Maybe Text
    , awardID     :: Maybe Text
    , description :: Maybe Body
    , grantedAt   :: Maybe UTCTime
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Trophy where
    parseJSON = withKind AwardKind "Trophy" $ \o -> Trophy <$> o .: "name"
        <*> o .:? "id"
        <*> o .:? "award_id"
        <*> o .:? "description"
        <*> (fmap integerToUTC <$> o .:? "granted_at")

-- | Wrapper for parsing JSON objects listing 'Trophy's
newtype TrophyList = TrophyList (Seq Trophy)
    deriving stock ( Show, Generic )

instance FromJSON TrophyList where
    parseJSON = withKind TrophyListKind "TrophyList"
        $ fmap (TrophyList . fromList) . (trophiesP <=< (.: "trophies"))
      where
        trophiesP = withArray "[Trophy]" (traverse parseJSON . toList)

-- | A brief summary of a user, with significantly less information than a
-- 'Account'
data UserSummary = UserSummary
    { -- | This field will be absent unless the 'UserSummary' is obtained from a
      -- specific endpoint using 'Network.Reddit.Actions.Account.getUserSummaries'.
      -- User summaries are sent as a JSON object with the user IDs as keys, so
      -- this field doesn't exist until the larger structure is parsed
      userID         :: Maybe UserID
    , name           :: Username
    , commentKarma   :: Integer
    , linkKarma      :: Integer
    , created        :: UTCTime
    , profilePicture :: URL
    , profileColor   :: Maybe RGBText
    , profileOver18  :: Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON UserSummary where
    parseJSON = withObject "UserSummary" $ \o -> UserSummary Nothing
        <$> o .: "name"
        <*> o .: "comment_karma"
        <*> o .: "link_karma"
        <*> (integerToUTC <$> o .: "created_utc")
        <*> (o .: "profile_img")
        <*> (nothingTxtNull =<< o .: "profile_color")
        <*> o .: "profile_over_18"

-- | Wrapper for parsing a JSON object of 'UserSummary's which has user IDs as
-- keys
newtype UserSummaryList = UserSummaryList (Seq UserSummary)
    deriving stock ( Show, Generic )

instance FromJSON UserSummaryList where
    parseJSON = withObject "UserSummaryList"
        $ fmap (UserSummaryList . fromList) . userSummariesP
      where
        userSummariesP o = for (HM.toList o) $ \(usid, us) -> do
            uid <- parseJSON (String usid)
            u <- parseJSON us
            pure $ u & field @"userID" ?~ uid

-- | User preferences
data Preferences = Preferences
    {  -- | Default comment sort
      defaultCommentSort :: ItemSort
      -- | Thumbnail preference
    , media :: MediaPreference
      -- | Media preview preference
    , mediaPreview :: MediaPreference
      -- | Minimum score for displaying comments, must be between -100 and 100
    , minCommentScore :: Int
      -- | Minimum score for displaying submissions, must be between -100 and 100
    , minLinkScore :: Int
      -- | Default number of comments to display, must be between 1 and 500
    , numComments :: Int
      -- | Number of submissions to display at once, must be between 1 and 100
    , numSites :: Int
      -- | Interface language, should be in IETF format, with components
      -- separated with underscores
    , lang :: Text
      -- | If @True@, all users can send PMs. Otherwise, only whitelisted
      -- users can
    , acceptPMs :: AcceptPMs
      -- | Allows Reddit to use activity to show more relevant ads
    , activityRelevantAds :: Bool
      -- | Allows Reddit to log outbound clicks for personalization
    , allowClicktracking :: Bool
      -- | Enrolls user in beta testing Reddit features
    , beta :: Bool
      -- | Show recently viewed links
    , clickGadget :: Bool
      -- | Collapse messages after reading them
    , collapseReadMessages :: Bool
      -- | Compress link display
    , compress :: Bool
      -- | Use creddit to automatically renew gold upon expiration
    , credditAutorenew :: Maybe Bool
      -- | Show additional details in domain text if applicable (e.g.
      -- source subreddit, author URL, etc...)
    , domainDetails :: Bool
      -- | Send email notifications for chat requests
    , emailChatRequest :: Bool
      -- | Send email notifications for comments replies
    , emailCommentReply :: Bool
      -- | Send email digests
    , emailDigests :: Bool
      -- | Send email notifications for messages
    , emailMessages :: Bool
      -- | Send email notifications for submission replies
    , emailPostReply :: Bool
      -- | Send email notifications for PMs
    , emailPrivateMessage :: Bool
      -- | Unsubscribe from all emails
    , emailUnsubscribeAll :: Bool
      -- | Send email notifications for comment upvotes
    , emailUpvoteComment :: Bool
      -- | Send email notifications for submission upvotes
    , emailUpvotePost :: Bool
      -- | Send email notifications for new followers
    , emailUserNewFollower :: Bool
      -- | Send email notifications for user mentions
    , emailUsernameMention :: Bool
    , enableDefaultThemes :: Bool
      -- | Enable feed recommendations
    , feedRecommendationsEnabled :: Bool
    , hideAds :: Bool
      -- | Don't show submissions after downvoting them
    , hideDowns :: Bool
      -- | Disallow search engine profile indexing
    , hideFromRobots :: Bool
      -- | Don't show submissions after upvoting them
    , hideUps :: Bool
      -- | Show a dagger on comments voted controversial
    , highlightControversial :: Bool
      -- | Highlight new comments
    , highlightNewComments :: Bool
      -- | Ignore suggested sorts
    , ignoreSuggestedSort :: Bool
    , inRedesignBeta :: Maybe Bool
      -- | Label NSFTW submissions
    , labelNSFW :: Bool
      -- | Show the legacy search page
    , legacySearch :: Bool
      -- | Send browser message notifications
    , liveOrangereds :: Bool
      -- | Mark messages as read after opening the inbox
    , markMessagesRead :: Bool
      -- | Receive a notification when your username is mentioned by others
    , monitorMentions :: Bool
      -- | Open links in a new window
    , newWindow :: Bool
      -- | Enable night mode
    , nightMode :: Bool
      -- | Hide thumbnails and media previews for NSFW content
    , noProfanity :: Bool
      -- | Show the spotlight box on the home feed
    , organic :: Maybe Bool
      -- | Affirm age and willingness to view adult content
    , over18 :: Bool
      -- | Enable private RSS feeds
    , privateFeeds :: Bool
      -- | View user profiles on desktop using legacy mode
    , profileOptOut :: Bool
      -- | Make votes public
    , publicVotes :: Bool
      -- | Allow data to be used for \"research\" purposes
    , research :: Bool
      -- | Include NSFW content in search results
    , searchIncludeOver18 :: Bool
      -- | Send crosspost messages
    , sendCrosspostMessages :: Bool
      -- | Send welcome messages
    , sendWelcomeMessages :: Bool
      -- | Show user flair
    , showFlair :: Bool
      -- | Show remaining gold on userpage
    , showGoldExpiration :: Bool
      -- | Show link flair
    , showLinkFlair :: Bool
      -- | Show location-based recommendations
    , showLocationBasedRecommendations :: Bool
      -- | Show presence
    , showPresence :: Bool
    , showPromote :: Maybe Bool
      -- | Allow subreddits to display custom themes
    , showStylesheets :: Bool
      -- | Show trending subreddits
    , showTrending :: Bool
      -- | Show a link to your Twitter account on your profile
    , showTwitter :: Bool
      -- | Store visits
    , storeVisits :: Bool
      -- | Allow Reddit to use 3rd-party data to show more relevant ads
    , thirdPartyDataPersonalizedAds :: Bool
      -- | Allow ad personalization
    , thirdPartyPersonalizedAds :: Bool
      -- | Allow ad personalization using 3rd-party data
    , thirdPartySiteDataPersonalizedAds :: Bool
      -- | Allow content personalization using 3rd-party data
    , thirdPartySiteDataPersonalizedContent :: Bool
      -- | Show message conversations in the inbox
    , threadedMessages :: Bool
      -- | Enable threaded modmail display
    , threadedModmail :: Bool
    , topKarmaSubreddits :: Bool
    , useGlobalDefaults :: Bool
      -- | Autoplay Reddit videos on the desktop comments page
    , videoAutoplay :: Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Preferences where
    parseJSON = genericParseJSON --
        defaultOptions { fieldLabelModifier = preferencesModifier }

instance ToJSON Preferences where
    toJSON = genericToJSON --
        defaultOptions { fieldLabelModifier = preferencesModifier }

preferencesModifier :: Modifier
preferencesModifier = \case
    "nightMode" -> "nightmode"
    "over18" -> "over_18"
    "searchIncludeOver18" -> "search_include_over_18"
    "numSites" -> "numsites"
    "newWindow" -> "newwindow"
    "acceptPMs" -> "accept_pms"
    "clickGadget" -> "clickgadget"
    "labelNSFW" -> "label_nsfw"
    s -> snakeCase s

-- | How to deal with media previews and thumbnails in your 'Preferences'
data MediaPreference
    = TurnOn
    | TurnOff
    | FollowSubreddit
    deriving stock ( Show, Eq, Generic )

instance FromJSON MediaPreference where
    parseJSON = genericParseJSON --
        defaultOptions { constructorTagModifier = mediaPreferenceModifier }

instance ToJSON MediaPreference where
    toJSON = genericToJSON --
        defaultOptions { constructorTagModifier = mediaPreferenceModifier }

mediaPreferenceModifier :: Modifier
mediaPreferenceModifier = \case
    "TurnOn"          -> "on"
    "TurnOff"         -> "off"
    "FollowSubreddit" -> "subreddit"
    s                 -> s

-- | Policy for accepting private messages, for use in user 'Preferences'
data AcceptPMs
    = Everyone
    | Whitelisted
    deriving stock ( Show, Eq, Generic )

instance FromJSON AcceptPMs where
    parseJSON = genericParseJSON --
        defaultOptions { constructorTagModifier = fmap toLower }

instance ToJSON AcceptPMs where
    toJSON = genericToJSON --
        defaultOptions { constructorTagModifier = fmap toLower }