{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Network.Reddit.Types.Subreddit
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types.Subreddit
    ( SubredditName
    , mkSubredditName
    , SubredditID(SubredditID)
    , Subreddit(..)
    , RecsList
    , NameSearchResults
      -- * Rules\/requirements
    , SubredditRule(..)
    , RuleList
    , NewSubredditRule(..)
    , PostedSubredditRule
    , RuleType(..)
    , PostRequirements(..)
    , BodyRestriction(..)
    ) where

import           Control.Applicative           ( Alternative((<|>)) )
import           Control.Monad                 ( (<=<) )
import           Control.Monad.Catch           ( MonadThrow )

import           Data.Aeson
                 ( (.!=)
                 , (.:)
                 , (.:?)
                 , FromJSON(..)
                 , Options(..)
                 , ToJSON
                 , ToJSON(..)
                 , Value(Object)
                 , decodeStrict
                 , defaultOptions
                 , genericParseJSON
                 , withArray
                 , withObject
                 , withText
                 )
import           Data.Aeson.Casing             ( snakeCase )
import           Data.Coerce                   ( coerce )
import           Data.Foldable                 ( asum )
import           Data.Maybe                    ( catMaybes, fromMaybe )
import           Data.Sequence                 ( Seq )
import           Data.Text                     ( Text )
import qualified Data.Text.Encoding            as T
import           Data.Time                     ( UTCTime )

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

import           Lens.Micro

import           Network.Reddit.Types.Internal

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

-- | Information about a subreddit. Fields prefixed with @userIs@ below apply to
-- the currently authenticated user
data Subreddit = Subreddit
    { subredditID        :: SubredditID
    , name               :: SubredditName
    , title              :: Title
    , created            :: UTCTime
    , subredditType      :: SubredditType
    , subscribers        :: Integer
      -- | Description as shown in searches
    , publicDescription  :: Body
      -- | The description of the subreddit in markdown
    , keyColor           :: Maybe RGBText
    , description        :: Body
    , descriptionHTML    :: Maybe Body
      -- | Text shown when submitting, in markdown
    , submitText         :: Maybe Text
    , submitTextHTML     :: Maybe Text
      -- | The label shown on the submit button
    , submitTextLabel    :: Maybe Text
    , iconImg            :: Maybe URL
      -- -- | The sub banner image
    , bannerImg          :: Maybe URL
      -- | The dimensions (w, h) for the banner image, if it exists
    , bannerSize         :: Maybe (Int, Int)
    , headerImg          :: Maybe URL
      -- | The dimensions (w, h) for the header image, if it exists
    , headerSize         :: Maybe (Int, Int)
    , over18             :: Bool
      -- | Whether the subreddit is quarantined
    , quarantine         :: Bool
    , userIsBanned       :: Bool
    , userIsMuted        :: Bool
    , userIsModerator    :: Bool
    , userIsContributor  :: Bool
    , userIsSubscriber   :: Bool
    , allowImages        :: Bool
    , allowPolls         :: Bool
    , allowVideos        :: Bool
    , allowVideoGIFs     :: Bool
      -- | Whether users can specify custom reasons in reports
    , freeFormReports    :: Bool
      -- | Whether users are forbidden from posting submissions
    , restrictPosting    :: Bool
      -- | Whether users are forbidden from posting comments
    , restrictCommenting :: Bool
      -- | Whether link flair is enabled at all
    , linkFlairEnabled   :: Bool
      -- | Whether users can assign their own link flair
    , canAssignLinkFlair :: Maybe Bool
      -- | Whether users can assign their own user flair
    , canAssignUserFlair :: Maybe Bool
      -- | Whether the sub supports marking posts with the
      -- spoiler tag
    , spoilersEnabled    :: Maybe Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Subreddit where
    parseJSON v = asum [ withKind SubredditKind "Subreddit" subredditP v
                       , withObject "Subreddit" subredditP v
                       ]
      where
        subredditP o = do
            subredditID <- o .: "id" <|> o .: "name"
            name <- o .: "display_name"
            title <- o .: "title"
            -- This field is only missing when getting a user's subreddit.
            -- We can use the user's creation date in that case, after
            -- setting an (arbitrary) default here
            created <- integerToUTC <$> o .:? "created_utc" .!= 0
            subredditType <- o .: "subreddit_type"
            keyColor <- nothingTxtNull =<< o .: "key_color"
            description <- o .:? "description" .!= mempty
            descriptionHTML <- o .:? "description_html"
            publicDescription <- o .:? "public_description" .!= mempty
            submitTextLabel <- o .:? "submit_text_label"
            submitText <- o .:? "submit_text"
            submitTextHTML <- o .:? "submit_text_html"
            subscribers <- o .: "subscribers"
            iconImg <- maybe (pure Nothing) nothingTxtNull
                =<< o .:? "icon_img"
            bannerImg <- maybe (pure Nothing) nothingTxtNull
                =<< o .:? "banner_img"
            bannerSize <- o .:? "banner_size"
            headerImg <- o .:? "header_img"
            headerSize <- o .:? "header_size"
            over18 <- o .: "over_18" <|> o .: "over18"
            quarantine <- o .:? "quarantine" .!= False
            userIsBanned <- o .:? "user_is_banned" .!= False
            userIsMuted <- o .:? "user_is_muted".!= False
            userIsModerator <- o .:? "user_is_moderator".!= False
            userIsContributor <- o .:? "user_is_contributor".!= False
            userIsSubscriber <- o .: "user_is_subscriber"
            allowImages <- o .:? "allow_images" .!= True
            allowVideos <- o .:? "allow_videos" .!= True
            allowPolls <- o .:? "allow_polls" .!= True
            allowVideoGIFs <- o .:? "allow_videogifs" .!= True
            freeFormReports <- o .:? "free_form_reports" .!= True
            restrictPosting <- o .:? "restrict_posting".!= False
            restrictCommenting <- o .:? "restrict_commenting".!= False
            linkFlairEnabled <- o .:? "link_flair_enabled".!= False
            canAssignLinkFlair <- o .:? "can_assign_link_flair"
            canAssignUserFlair <- o .:? "can_assign_user_flair"
            spoilersEnabled <- o .:? "spoilers_enabled"
            pure Subreddit { .. }

-- Dummy instance so that @Listing ... Subreddit@ can work with convenience
-- actions
instance Paginable Subreddit where
    type PaginateOptions Subreddit = ()

    type PaginateThing Subreddit = SubredditID

    defaultOpts = ()

    optsToForm _ = mempty

    getFullname Subreddit { subredditID } = subredditID

-- | The name of a subreddit
newtype SubredditName = SubredditName Text
    deriving stock ( Show, Generic )
    deriving newtype ( FromJSON, ToJSON, ToHttpApiData )
    deriving ( Eq ) via CIText SubredditName

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

-- | Unique site-wide identifier for a subreddit
newtype SubredditID = SubredditID Text
    deriving stock ( Show, Generic )
    deriving newtype ( Eq )

instance FromJSON SubredditID where
    parseJSON = withText "SubredditID" $ coerce . dropTypePrefix SubredditKind

instance Thing SubredditID where
    fullname (SubredditID sid) = prependType SubredditKind sid

-- | Wrapper for parsing an array of recommended @SubredditName@s, which are
-- given as single-field JSON objects
newtype RecsList = RecsList (Seq SubredditName)
    deriving stock ( Show, Generic )

instance FromJSON RecsList where
    parseJSON = withArray "RecsList"
        $ fmap (RecsList . fromList) . traverse snameP . toList
      where
        snameP = withObject "Object" (.: "sr_name")

-- | Wrapper for parsing an object of @SubredditName@ results when searching
-- subreddits by name
newtype NameSearchResults = NameSearchResults (Seq SubredditName)
    deriving stock ( Show, Generic )

instance FromJSON NameSearchResults where
    parseJSON = withObject "NameSearchResults"
        $ fmap NameSearchResults . (.: "names")

-- | A 'Subreddit' rule. If you are a moderator, you can update the @shortName@,
-- @description@, @violationReason@, and @ruleType@ fields. See
-- 'Network.Reddit.Actions.Moderation.reorderSubredditRules'. New rules may also
-- be created with 'NewSubredditRule's
data SubredditRule = SubredditRule
    { description     :: Body
    , descriptionHTML :: Body
    , shortName       :: Name
    , created         :: UTCTime
    , priority        :: Word
    , violationReason :: Maybe Text
    , ruleType        :: Maybe RuleType
    }
    deriving stock ( Show, Eq, Generic )

-- | Depending on the endpoint, the JSON fields are either camel- or
-- snake-cased
instance FromJSON SubredditRule where
    parseJSON = withObject "SubredditRule" $ \o -> SubredditRule
        <$> o .: "description"
        <*> (o .: "description_html" <|> o .: "descriptionHtml")
        <*> (o .: "short_name" <|> o .: "shortName")
        <*> (integerToUTC <$> (o .: "created_utc" <|> o .: "createdUtc"))
        <*> o .: "priority"
        <*> (o .: "violation_reason" <|> o .: "violationReason")
        <*> o .:? "kind"

instance ToForm SubredditRule where
    toForm SubredditRule { .. } = fromList
        $ [ ("description", description), ("short_name", shortName) ]
        <> catMaybes [ ("violation_reason", ) <$> violationReason
                     , ("kind", ) . toQueryParam <$> ruleType
                     ]

-- | Wrapper to parse JSON from endpoints that list 'SubredditRule's
newtype RuleList = RuleList (Seq SubredditRule)
    deriving stock ( Show, Generic )

instance FromJSON RuleList where
    parseJSON = withObject "RuleList"
        $ fmap (RuleList . fromList) . (parseRules <=< (.: "rules"))
      where
        parseRules = withArray "[SubredditRule]" (traverse parseJSON . toList)

-- | Represents a new 'SubredditRule' that can be created by moderators
data NewSubredditRule = NewSubredditRule
    { shortName       :: Name
    , ruleType        :: RuleType
    , description     :: Body
      -- | If @Nothing@, will be set to the same text as
      -- the @shortName@ provided
    , violationReason :: Maybe Text
    }
    deriving stock ( Show, Eq, Generic )

instance ToForm NewSubredditRule where
    toForm NewSubredditRule { .. } =
        fromList [ ("description", description)
                 , ("short_name", shortName)
                 , ("kind", toQueryParam ruleType)
                 , ("violation_reason", fromMaybe shortName violationReason)
                 ]

-- | Wrapper for parsing newly created 'SubredditRule's, after POSTing a
-- 'NewSubredditRule'. Rather unbelievably, Reddit transmits these new
-- rules as a JSON object ... in a single element array ... /encoded as a string/
-- ... inside another object!
newtype PostedSubredditRule = PostedSubredditRule SubredditRule
    deriving stock ( Show, Generic )

instance FromJSON PostedSubredditRule where
    parseJSON = withObject "PostedSubredditRule" $ \o ->
        (o .: "json" >>= (.: "data") >>= (.: "rules"))
        <&> decodeStrict . T.encodeUtf8
        >>= \case
            Just [ r@(Object _) ] -> PostedSubredditRule <$> parseJSON r
            _ -> mempty

-- | The type of item that a 'SubredditRule' applies to
data RuleType
    = CommentRule
    | LinkRule
    | AllRule
    deriving stock ( Show, Eq, Generic, Ord )

instance FromJSON RuleType where
    parseJSON = genericParseJSON defaultOptions { constructorTagModifier }
      where
        constructorTagModifier = \case
            "CommentRule" -> "comment"
            "LinkRule"    -> "link"
            "AllRule"     -> "all"
            _             -> mempty

instance ToHttpApiData RuleType where
    toQueryParam = \case
        CommentRule -> "comment"
        LinkRule    -> "link"
        AllRule     -> "all"

-- | Mod-created requirements for posting in a subreddit
data PostRequirements = PostRequirements
    { bodyBlacklistedStrings  :: [Text]
    , bodyRestrictionPolicy   :: BodyRestriction
    , domainBlacklist         :: [Text]
      -- | If present, submissions must be from one of the listed domains
    , domainWhitelist         :: [Text]
    , isFlairRequired         :: Bool
    , titleBlacklistedStrings :: [Text]
      -- |If present, submission titles must contain one of the given strings
    , titleRequiredStrings    :: [Text]
    , titleTextMaxLength      :: Maybe Word
    , titleTextMinLength      :: Maybe Word
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON PostRequirements where
    parseJSON =
        genericParseJSON defaultOptions { fieldLabelModifier = snakeCase }

-- | Rules concerning the presence of self-text bodies in posts
data BodyRestriction
    = BodyRequired
    | BodyNotAllowed
    | NoRestriction
    deriving stock ( Show, Eq, Generic )

instance FromJSON BodyRestriction where
    parseJSON = withText "BodyRestriction" $ \case
        "required"   -> pure BodyRequired
        "notAllowed" -> pure BodyNotAllowed
        "none"       -> pure NoRestriction
        _            -> mempty