{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Network.Reddit.Types.Flair
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types.Flair
    ( AssignedFlair(..)
    , FlairTemplate(..)
    , defaultFlairTemplate
    , PostedFlairTemplate
    , FlairID
    , FlairText
    , mkFlairText
    , FlairSelection(..)
    , FlairChoice(..)
    , UserFlair(..)
    , ForegroundColor(..)
    , FlairResult(..)
    , CurrentUserFlair
    , FlairChoiceList
    , FlairList(..)
    , flairlistToListing
    , FlairContent(..)
    , FlairType(..)
    , CSSClass
    ) where

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

import           Data.Aeson
                 ( (.:)
                 , (.:?)
                 , FromJSON(..)
                 , Options(constructorTagModifier)
                 , ToJSON(..)
                 , Value(String)
                 , defaultOptions
                 , genericParseJSON
                 , withArray
                 , withObject
                 , withText
                 )
import           Data.Char                      ( toLower )
import           Data.HashMap.Strict            ( HashMap )
import           Data.Maybe                     ( catMaybes )
import           Data.Sequence                  ( Seq )
import           Data.Text                      ( Text )
import qualified Data.Text                      as T

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

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

import           Web.FormUrlEncoded             ( ToForm(..) )
import           Web.HttpApiData                ( ToHttpApiData(toQueryParam)
                                                , showTextData
                                                )

-- | The text displayed by the 'FlairTemplate'
newtype FlairText = FlairText Text
    deriving stock ( Show, Generic )
    deriving newtype ( Eq, FromJSON, ToJSON, ToHttpApiData, Semigroup, Monoid )

-- | Smart constructor for 'FlairText', the length of which not exceed 64
-- characters
mkFlairText :: MonadThrow m => Text -> m FlairText
mkFlairText txt
    | T.length txt > 64 = throwM
        $ OtherError "mkFlairText: Text length may not exceed 64 characters"
    | otherwise = pure $ FlairText txt

-- | CSS class for flair
type CSSClass = Text

-- | Flair that has been, or will be, assigned to a user
data AssignedFlair = AssignedFlair
    { user     :: Username
    , text     :: Maybe FlairText
    , cssClass :: Maybe CSSClass --
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON AssignedFlair where
    parseJSON = withObject "AssignedFlair" $ \o -> AssignedFlair
        <$> o .: "user"
        <*> o .:? "flair_text"
        <*> o .:? "flair_css_class"

-- The endpoints that list assigned flairs are a @Listing@, but there are no
-- additional options that can be passed to them. Giving this dummy instance at
-- least allows using a @Listing ... AssignedFlair@ with existing convenience
-- functions
instance Paginable AssignedFlair where
    type PaginateOptions AssignedFlair = ()

    type PaginateThing AssignedFlair = Text

    defaultOpts = ()

    optsToForm _ = mempty

-- | Reddit strangely does /not/ use their usual @Listing@ mechanism for paginating
-- assigned flairs, but a different data structure
data FlairList = FlairList
    { prev  :: Maybe UserID
    , next  :: Maybe UserID
    , users :: Seq AssignedFlair  --
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON FlairList where
    parseJSON = withObject "FlairList" $ \o ->
        FlairList <$> (o .:? "prev") <*> (o .:? "next") <*> (o .: "users")

-- | Convert a 'FlairList' to a 'Listing', allowing it to be used with other
-- functions/actions expecting a listing
flairlistToListing :: FlairList -> Listing UserID AssignedFlair
flairlistToListing (FlairList p n us) = Listing p n us

-- | An identifier for a 'FlairTemplate'
type FlairID = Text

-- | Flair \"templates\" that describe choices for self-assigned flair, for both
-- users and submissions
data FlairTemplate = FlairTemplate
    { flairID          :: Maybe FlairID
    , text             :: FlairText
    , textEditable     :: Bool
    , textColor        :: Maybe ForegroundColor
    , backgroundColor  :: Maybe RGBText
    , cssClass         :: Maybe CSSClass
    , overrideCSS      :: Maybe Bool
      -- | Should be between 1 and 10; 10 is the default
    , maxEmojis        :: Word
    , modOnly          :: Bool
    , allowableContent :: FlairContent
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON FlairTemplate where
    parseJSON = withObject "FlairTemplate" $ \o -> FlairTemplate <$> o .: "id"
        <*> o .: "text"
        <*> o .: "text_editable"
        <*> (nothingTxtNull =<< o .: "text_color")
        <*> (nothingTxtNull =<< o .: "background_color")
        <*> (nothingTxtNull =<< o .: "css_class")
        <*> o .:? "override_css"
        <*> o .: "max_emojis"
        <*> o .: "mod_only"
        <*> o .: "allowable_content"

-- | Wrapper around @FlairTemplates@ for posting via the API. If the @flairID@ field
-- is @Nothing@, a new template will be created. Otherwise, the template with the
-- matching ID will be updated
newtype PostedFlairTemplate = PostedFlairTemplate FlairTemplate
    deriving stock ( Show, Generic )
    deriving newtype ( Eq )

instance ToForm PostedFlairTemplate where
    toForm (PostedFlairTemplate ft@FlairTemplate { flairID }) = toForm ft
        <> fromList (foldMap pure (("flair_template_id", ) <$> flairID))

instance ToForm FlairTemplate where
    toForm FlairTemplate { .. } = fromList
        $ [ ("allowable_content", toQueryParam allowableContent)
          , ("max_emojis", toQueryParam maxEmojis)
          , ("mod_only", toQueryParam modOnly)
          , ("override_css", toQueryParam overrideCSS)
          , ("text", toQueryParam text)
          , ("text_editable", toQueryParam textEditable)
          , ("api_type", "json")
          ]
        <> catMaybes [ ("background_color", ) . toQueryParam
                       <$> backgroundColor
                     , ("text_color", ) . toQueryParam <$> textColor
                     , ("css_class", ) . toQueryParam <$> cssClass
                     ]

-- | A 'FlairTemplate' with default fields, for convenience when creating new
-- templates
defaultFlairTemplate :: FlairTemplate
defaultFlairTemplate = FlairTemplate
    { flairID          = Nothing
    , text             = mempty
    , textEditable     = False
    , textColor        = Just Light
    , backgroundColor  = Nothing
    , cssClass         = Nothing
    , overrideCSS      = Just False
    , maxEmojis        = 10
    , modOnly          = False
    , allowableContent = AllContent
    }

-- | Information about flair that a user can choose. The @templateID@ corresponds
-- to the @flairID@ field of a 'FlairTemplate'
data FlairChoice = FlairChoice
    { templateID   :: FlairID
    , text         :: FlairText
    , textEditable :: Bool
    , cssClass     :: Maybe CSSClass
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON FlairChoice where
    parseJSON = withObject "FlairChoice" $ \o -> FlairChoice
        <$> o .: "flair_template_id"
        <*> o .: "flair_text"
        <*> o .: "flair_text_editable"
        <*> (nothingTxtNull =<< o .: "flair_css_class")

-- Reddit returns both the current flair for the user along with the choices for
-- flair on the given subreddit. This wrapper extracts the possible choices from
-- the returned JSON
newtype FlairChoiceList = FlairChoiceList (Seq FlairChoice)
    deriving stock ( Show, Generic )

instance FromJSON FlairChoiceList where
    parseJSON = withObject "FlairChoiceList" $ \o ->
        FlairChoiceList . fromList <$> (flairChoiceP =<< (o .: "choices"))
      where
        flairChoiceP = withArray "[FlairChoice]" (traverse parseJSON . toList)

-- | Flair that is currently assigned to a user
data UserFlair = UserFlair
    { text     :: Maybe FlairText  --
    , cssClass :: Maybe CSSClass
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON UserFlair where
    parseJSON = withObject "UserFlair" $ \o ->
        UserFlair <$> (o .: "flair_text") <*> (o .: "flair_css_class")

-- | Wrapper around @UserFlair@ for fetching the current flair. This uses the same
-- endpoint as the @FlairChoiceList@ above
newtype CurrentUserFlair = CurrentUserFlair UserFlair
    deriving stock ( Show, Generic )

instance FromJSON CurrentUserFlair where
    parseJSON = withObject "CurrentUserFlair" $ \o -> CurrentUserFlair
        <$> (currentP =<< (o .: "current"))
      where
        currentP = parseJSON

-- | Select a 'FlairChoice' for a submission or for the user
data FlairSelection = FlairSelection
    { flairChoice :: FlairChoice
      -- | If @Just@ and if the @textEditable@ field of the 'FlairChoice' is
      -- @True@, this will be sent. It is otherwise ignored
    , text        :: Maybe Text
    , subreddit   :: SubredditName
    }
    deriving stock ( Show, Eq, Generic )

-- | The result of bulk setting of users\' flairs as a mod action. The @warnings@
-- and @errors@ fields may be dynamically generated by Reddit, so they are
-- represented here as 'HashMap's
data FlairResult = FlairResult
    {  -- | If the flair was applied or not
      ok       :: Bool
      -- | A human-readable description of the transaction
    , status   :: Text
    , warnings :: HashMap Text Text
    , errors   :: HashMap Text Text
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON FlairResult where
    parseJSON = withObject "FlairResult" $ \o -> FlairResult <$> o .: "ok"
        <*> o .: "status"
        <*> o .: "warnings"
        <*> o .: "errors"

-- | The type of flair, when creating a new template
data FlairType
    = UserFlairType
    | SubmissionFlairType
    deriving stock ( Show, Eq, Generic )

instance ToHttpApiData FlairType where
    toQueryParam = \case
        UserFlairType       -> "USER_FLAIR"
        SubmissionFlairType -> "LINK_FLAIR"

-- | The type of content that is allowed in a flair template
data FlairContent
    = AllContent
    | EmojisOnly
    | TextOnly
    deriving stock ( Show, Eq, Generic )

instance FromJSON FlairContent where
    parseJSON = withText "FlairContent" $ \case
        "all"   -> pure AllContent
        "emoji" -> pure EmojisOnly
        "text"  -> pure TextOnly
        _       -> mempty

instance ToHttpApiData FlairContent where
    toQueryParam = \case
        AllContent -> "all"
        EmojisOnly -> "emoji"
        TextOnly   -> "text"

-- | Foreground color for v2 flair
data ForegroundColor
    = Dark
    | Light
    deriving stock ( Show, Eq, Generic )

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

instance ToJSON ForegroundColor where
    toJSON = String . showTextData

instance ToHttpApiData ForegroundColor where
    toQueryParam = showTextData