{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Network.Reddit.Types.Multireddit
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types.Multireddit
    ( Multireddit(..)
    , MultiName
    , mkMultiName
    , MultiVisibility(..)
    , MultiPath(..)
    , NewMultiF(..)
    , NewMulti
    , MultiUpdate
    , multiUpdate
    , defaultMultiUpdate
    ) where

import           Control.Monad.Catch            ( MonadThrow )

import           Data.Aeson
                 ( (.:)
                 , (.:?)
                 , FromJSON(..)
                 , KeyValue((.=))
                 , ToJSON(..)
                 , Value(String)
                 , object
                 , withArray
                 , withObject
                 , withText
                 )
import           Data.Functor.Identity          ( Identity )
import           Data.Maybe                     ( catMaybes )
import           Data.Sequence                  ( Seq )
import           Data.Text                      ( Text )
import qualified Data.Text                      as T
import           Data.Time                      ( UTCTime )
import           Data.Traversable               ( for )

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

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

import           Web.HttpApiData                ( ToHttpApiData(..) )

-- | An aggregation of individual 'Subreddit's
data Multireddit = Multireddit
    { name            :: MultiName
    , displayName     :: Text
    , subreddits      :: Seq SubredditName
    , created         :: UTCTime
    , description     :: Body
    , descriptionHTML :: Body
    , keyColor        :: Maybe RGBText
    , multipath       :: MultiPath
    , visibility      :: MultiVisibility
      -- | The path to the original multireddit from which
      -- this one was copied, if any, e.g.:
      -- @\/u\/<USERNAME>\/m\/<MULTINAME>@
    , copiedFrom      :: Maybe MultiPath
      -- | Whether the authenticated user can edit this
      -- multireddit
    , canEdit         :: Bool
    , over18          :: Maybe Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Multireddit where
    parseJSON = withKind LabeledMultiKind "Multireddit" $ \o -> Multireddit
        <$> o .: "name"
        <*> o .: "display_name"
        <*> (fromList <$> (subredditsP =<< o .: "subreddits"))
        <*> (integerToUTC <$> o .: "created_utc")
        <*> o .: "description_md"
        <*> o .: "description_html"
        <*> o .:? "key_color"
        <*> o .: "path"
        <*> o .: "visibility"
        <*> o .:? "copied_from"
        <*> o .: "can_edit"
        <*> o .:? "over_18"
      where
        subredditsP = withArray "[Object]" namesP

        namesP as = for (toList as) . withObject "Object" $ \o -> o .: "name"

-- | The name of a 'Multireddit', which may only contain alphanumeric characters
newtype MultiName = MultiName Text
    deriving stock ( Show, Generic )
    deriving newtype ( FromJSON, ToHttpApiData )
    deriving ( Eq ) via CIText MultiName

-- | Smart constructor for 'MultiName's, which may only contain alphanumeric
-- characters
mkMultiName :: MonadThrow m => Text -> m MultiName
mkMultiName = validateName Nothing Nothing "MultiName"

-- | The path to a 'Multireddit', of the form @\/user\/<USERNAME>\/m\/<MULTINAME>@
data MultiPath = MultiPath { username :: Username, multiname :: MultiName }
    deriving stock ( Show, Eq, Generic )

instance FromJSON MultiPath where
    parseJSON = withText "MultiPath" $ \t -> case T.splitOn "/" t of
        _ : "user" : uname : path : mname : _
            | path `elem` [ "m", "f" ] -> MultiPath
                <$> parseJSON (String uname)
                <*> parseJSON (String mname)
            | otherwise -> mempty
        _ -> mempty

instance ToHttpApiData MultiPath where
    toUrlPiece MultiPath { .. } =
        T.intercalate "/"
                      [ "user"
                      , toUrlPiece username
                      , "m"
                      , toUrlPiece multiname
                      ]

-- | The configured visibility level for a 'Multireddit'
data MultiVisibility
    = PrivateMulti
    | PublicMulti
    | HiddenMulti
    deriving stock ( Show, Eq, Generic, Ord )

instance FromJSON MultiVisibility where
    parseJSON = withText "MultiVisibility" $ \case
        "private" -> pure PrivateMulti
        "public"  -> pure PublicMulti
        "hidden"  -> pure HiddenMulti
        _         -> mempty

instance ToJSON MultiVisibility where
    toJSON = \case
        PrivateMulti -> "private"
        PublicMulti  -> "public"
        HiddenMulti  -> "hidden"

-- | Can represent either a new multireddit when parameterized by 'Identity', or
-- a multireddit update when parameterized by 'Maybe'. In both cases, @keyColor@
-- is an optional field
data NewMultiF f = NewMultiF
    { description :: HKD f Body
    , displayName :: HKD f Text
    , subreddits  :: HKD f (Seq SubredditName)
    , visibility  :: HKD f MultiVisibility
    , keyColor    :: Maybe RGBText
    }
    deriving stock ( Generic )

-- | An new multireddit, where all fields are required
type NewMulti = NewMultiF Identity

deriving stock instance Show NewMulti

instance ToJSON NewMulti where
    toJSON NewMultiF { .. } = object
        $ [ "description_md" .= description
          , "display_name" .= displayName
          , "subreddits" .= multiSubsObject subreddits
          , "visibility" .= visibility
          ]
        <> maybe mempty (pure . (.=) "key_color") keyColor

-- | An update to a multireddit, where all fields are optional. If a field
-- is not provided, it is omitted during JSON encoding
type MultiUpdate = NewMultiF Maybe

deriving stock instance Show MultiUpdate

instance ToJSON MultiUpdate where
    toJSON NewMultiF { .. } = object
        $ catMaybes [ ("description_md" .=) <$> description
                    , ("display_name" .=) <$> displayName
                    , ("subreddits" .=) . multiSubsObject <$> subreddits
                    , ("visibility" .=) <$> visibility
                    , ("key_color" .=) <$> keyColor
                    ]

-- | Convert a 'Multireddit' to a 'MultiUpdate'
multiUpdate :: Multireddit -> MultiUpdate
multiUpdate Multireddit { .. } = NewMultiF
    { description = Just description
    , displayName = Just displayName
    , subreddits  = Just subreddits
    , visibility  = Just visibility
    , keyColor
    }

-- | A 'MultiUpdate' with all @Nothing@ fields, for convenience
defaultMultiUpdate :: MultiUpdate
defaultMultiUpdate = NewMultiF
    { description = Nothing
    , displayName = Nothing
    , subreddits  = Nothing
    , visibility  = Nothing
    , keyColor    = Nothing
    }

-- | Endpoints receiving JSON for creating or updating multireddits expect an array
-- of single-member objects, of the form @{\"name\": ...}@, instead of the far
-- more sensical array of names that one would expect
multiSubsObject :: Functor t => t SubredditName -> t Value
multiSubsObject = fmap (object . pure . ("name" .=))