{-# 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.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
      -- | The description of the subreddit in markdown
    , description        :: Body
    , descriptionHTML    :: Maybe Body
      -- | Description as shown in searches
    , publicDescription  :: Body
    , subscribers        :: Integer
    , over18             :: Bool
    , userIsBanned       :: Maybe Bool
    , userIsModerator    :: Maybe Bool
    , userIsSubscriber   :: Maybe 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 subreddit is quarantined
    , quarantine         :: Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Subreddit where
    parseJSON = withKind SubredditKind "Subreddit" $ \o -> Subreddit
        <$> o .: "id"
        <*> o .: "display_name"
        <*> o .: "title"
        <*> (integerToUTC <$> o .: "created_utc")
        <*> o .: "description"
        <*> o .: "description_html"
        <*> o .: "public_description"
        <*> o .: "subscribers"
        <*> o .: "over18"
        <*> o .: "user_is_banned"
        <*> o .: "user_is_moderator"
        <*> o .: "user_is_subscriber"
        <*> o .:? "can_assign_link_flair"
        <*> o .:? "can_assign_user_flair"
        <*> o .: "quarantine"

-- 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, FromJSON )

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