Types.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.Reddit.Types
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types
    ( -- * Reddit
      RedditT
    , runRedditT
    , MonadReddit
    , UserAgent(..)
    , ClientSite
    , Client(..)
    , ClientState(..)
    , readClientState
    , WithData(..)
    , RateLimits(..)
    , readRateLimits
      -- * Auth
    , AppType(..)
    , AuthConfig(..)
    , AccessToken(..)
    , Token
    , Code
    , Scope(..)
    , PasswordFlow(..)
    , CodeFlow(..)
    , ClientID
    , ClientSecret
    , TokenDuration(..)
    , TokenManager(..)
      -- * Requests
    , APIAction(..)
    , Method(..)
    , PathSegment
      -- * Re-exports
    , module M
    ) where

import           Conduit                               ( MonadUnliftIO )

import           Control.Monad.Catch
                 ( MonadCatch
                 , MonadThrow
                 )
import           Control.Monad.Reader

import           Data.Aeson
                 ( (.:)
                 , (.:?)
                 , FromJSON(parseJSON)
                 , Options(constructorTagModifier)
                 , Value(String)
                 , defaultOptions
                 , genericParseJSON
                 , withObject
                 , withText
                 )
import qualified Data.ByteString.Char8                 as C8
import           Data.Char                             ( toLower )
import           Data.Generics.Product                 ( HasField(field) )
import           Data.Text                             ( Text )
import qualified Data.Text                             as T
import           Data.Time
import           Data.Time.Clock.POSIX

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

import           Lens.Micro

import           Network.HTTP.Client                   ( BodyReader )
import           Network.HTTP.Client.Conduit
                 ( HasHttpManager(..)
                 , Manager
                 , Request
                 , Response
                 )
import           Network.HTTP.Client.MultipartFormData ( Part )
import           Network.HTTP.Types
                 ( HeaderName
                 , ResponseHeaders
                 )
import           Network.Reddit.Types.Internal         as M

import           Text.Read                             ( readMaybe )

import           UnliftIO.IORef

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

-- | The monad tranformer in which Reddit API transactions can be executed
newtype RedditT m a = RedditT (ReaderT Client m a)
    deriving newtype ( Functor, Applicative, Monad, MonadIO, MonadUnliftIO
                     , MonadReader Client, MonadThrow, MonadCatch )

-- | Run a 'RedditT' action
runRedditT :: Client -> RedditT m a -> m a
runRedditT c (RedditT x) = runReaderT x c

-- | Synonym for constraints that 'RedditT' actions must satisfy
type MonadReddit m =
    (MonadUnliftIO m, MonadThrow m, MonadCatch m, MonadReader Client m)

-- | A client facilitating access to Reddit's API
data Client = Client
    { authConfig   :: AuthConfig
    , manager      :: Manager
    , clientState  :: IORef ClientState
    , tokenManager :: Maybe TokenManager
    }
    deriving stock ( Generic )

instance HasHttpManager Client where
    getHttpManager Client { manager } = manager

-- | Stateful data that may be updated over the course of a 'Client' lifetime
data ClientState = ClientState
    { accessToken   :: AccessToken
      -- | The approximate time at which the token was obtained. This is useful
      -- to compare against the @expiresIn@ field of the 'AccessToken'
    , tokenObtained :: POSIXTime
    , limits        :: Maybe RateLimits
    }
    deriving stock ( Show, Eq, Generic )

-- | For conveniently reading some field from the @IORef ClientState@ inside
-- a 'Client'
readClientState :: MonadReddit m => Lens' ClientState a -> m a
readClientState l = asks (^. field @"clientState") >>= readIORef <&> (^. l)

-- | A unique user agent to identify your application; Reddit applies
-- rate-limiting to common agents, and actively bans misleading ones
data UserAgent = UserAgent
    { -- | The target platform
      platform :: Text
      -- | A unique application ID
    , appID    :: Text
    , version  :: Text
      -- | Your username as contact information
    , author   :: Text
    }
    deriving stock ( Show, Eq, Generic )

-- | A client site corresponds to a field in your auth configuration ini file.
-- For instance, the 'ClientSite' \"mybot\" should map to section such as:
--
--  > [MYBOT]
--  > id = <clientID>
--  > ...
--
-- in your @auth.ini@ file.
--
-- __Note__: The 'ClientSite' and the corresponding ini section are case
-- insensitive!
type ClientSite = Text

-- | Rate limit info
data RateLimits = RateLimits
    { -- | The number of requests remaining in the current rate-limiting
      -- window
      remaining   :: Integer
    , used        :: Integer
      -- | Timestamp of the upper bound on rate-limiting counter reset
    , reset       :: POSIXTime
      -- | Epoch time at which the next request should be made in order
      -- to stay within the current rate limit bounds
    , nextRequest :: POSIXTime
    }
    deriving stock ( Show, Eq, Generic )

-- | Extract rate limit info from response headers. This should only be called
-- after making a request
readRateLimits :: POSIXTime -> ResponseHeaders -> Maybe RateLimits
readRateLimits time hs = do
    remaining <- round <$> lookupHeader @Double "x-ratelimit-remaining"
    used <- lookupHeader "x-ratelimit-used"
    reset <- (time +) . fromInteger
        <$> lookupHeader @Integer "x-ratelimit-reset"
    let nextTimeStamp = max 0 . min 10 $ (reset - fromInteger remaining) / 2
        nextRequest   = min reset $ time + nextTimeStamp
    pure RateLimits { .. }
  where
    lookupHeader :: forall a. Read a => HeaderName -> Maybe a
    lookupHeader v = readMaybe @a . C8.unpack =<< lookup v hs

--Auth-------------------------------------------------------------------------
-- | A configuration
data AuthConfig = AuthConfig
    { -- | Your application's client ID
      clientID  :: ClientID
      -- | The type of your application. This will determine how OAuth
      -- credentials are obtained
    , appType   :: AppType
      -- | Your unique user agent; will be used in the client
      -- that is obtained after authenticating
    , userAgent :: UserAgent
    }
    deriving stock ( Show, Eq, Generic )

-- | The three forms of application that may use the Reddit API, each having
-- different API access patterns
data AppType
    = -- | The simplest type of application. May only be used by the developer
      -- who owns the account. This requires supplying the usernme and password
      -- associated with the account
      ScriptApp ClientSecret PasswordFlow
      -- | For applications running on a server backend
    | WebApp ClientSecret CodeFlow
      -- | For applications installed on devices that the developer does not own
      -- (e.g., a mobile application)
    | InstalledApp CodeFlow
      -- Get an access token for read-only access without a user context. This
      -- will grant an 'Unlimited' OAuth scope, but most endpoints will not work.
      -- If accessing endpoints that require a user context, expect HTTP status
      -- exceptions. Additionally, JSON parsing may fail unexpectedly for various
      -- actions.
      --
      -- Note that although this app type is not associated with a user account, it
      -- is still necessary to register the application using your reddit account
    | ApplicationOnly ClientSecret
    deriving stock ( Show, Eq, Generic )

instance ToForm AppType where
    toForm = \case
        ScriptApp _ pf    -> toForm pf
        ApplicationOnly _ -> fromList [ ("grant_type", "client_credentials") ]
        WebApp _ cf       -> toForm cf
        InstalledApp cf   -> toForm cf

-- | Type synonym for client IDs
type ClientID = Text

-- | Type synonym for client secrets
type ClientSecret = Text

-- | Type synonym for the text of a token
type Token = Text

-- | Type synonym for the text of codes returned from auth URLs, for 'WebApp's
-- and 'InstalledApp's
type Code = Text

-- | Token received after authentication
data AccessToken = AccessToken
    { token        :: Token
      -- |
    , expiresIn    :: NominalDiffTime
    , scope        :: [Scope]
    , refreshToken :: Maybe Token
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON AccessToken where
    parseJSON = withObject "AccessToken" $ \o -> AccessToken
        <$> o .: "access_token"
        <*> o .: "expires_in"
        <*> (scopeP =<< o .: "scope")
        <*> o .:? "refresh_token"
      where
        scopeP = withText "Scope"
            $ traverse (parseJSON . String) . splitScopes
          where
            splitScopes t = T.split (`elem` [ ' ', ',' ]) t

-- | Simple user credentials for authenticating via 'ScriptApp's
--
-- __Note__: These credentials will be kept in memory!
data PasswordFlow = PasswordFlow
    { -- | The name of the user you are authenticating as
      username :: Text
      -- | The password of the user you are authenticating as
    , password :: Text
    }
    deriving stock ( Show, Eq, Generic )

instance ToForm PasswordFlow where
    toForm PasswordFlow { .. } =
        fromList [ ("grant_type", "password")
                 , ("username", username)
                 , ("password", password)
                 ]

-- | Details for OAuth \"code flow\", for 'WebApp's and 'InstalledApp's
data CodeFlow = CodeFlow
    { -- | This must exactly match the redirect URL you entered when making
      -- your application on Reddit
      redirectURI :: URL
      -- | This is the code that is obtained after a user grants permissions
      -- by visiting the URL generated by 'Network.Reddit.Auth.getAuthURL'.
      -- If you are using a 'TokenManager' with 'Network.Reddit.newClientWithManager',
      -- you can leave this field as empty text, since it won't be used to
      -- get the initial refresh token
    , code        :: Code
    }
    deriving stock ( Show, Eq, Generic )

instance ToForm CodeFlow where
    toForm CodeFlow { .. } = fromList [ ("code", code)
                                      , ("redirect_uri", redirectURI)
                                      , ("grant_type", "authorization_code")
                                      ]

-- | The duration of the access token for 'WebApp's and 'InstalledApp's
data TokenDuration
    = -- | Generates one-hour access tokens without a refresh token
      Temporary
      -- | Generates a one-hour access tokens with a refresh token
      -- that can be used to indefinitely obtain new access tokens
    | Permanent
    deriving stock ( Show, Eq, Generic )

instance ToHttpApiData TokenDuration where
    toQueryParam = showTextData

-- | Monadic actions to load and save 'Token's, specifically refresh tokens, when
-- creating new 'Client's for 'WebApp's and 'InstalledApp's
data TokenManager = TokenManager
    { -- | Load an existing refresh token, for instance from a file or database
      loadToken :: forall m. (MonadIO m, MonadThrow m) => m Token
      -- | Store the new refresh token that is received when exchanging the
      -- existing one for a new 'AccessToken'.
      --
      -- This action must take a @Maybe Token@ as its argument, as it is possible
      -- (albeit perhaps unlikely) that Reddit does not return a new token when
      -- exchanging the existing refresh token for a new access token
    , putToken  :: forall m. (MonadIO m, MonadThrow m) => Maybe Token -> m ()
    }

-- | Represents a specific Reddit functionality that must be explicitly
-- requested
data Scope
    = Accounts -- ^ Corresponds to \"account\" in text form
    | Creddits
    | Edit
    | Flair
    | History
    | Identity
    | LiveManage
    | ModConfig
    | ModContributors
    | ModFlair
    | ModLog
    | ModMail
    | ModOthers
    | ModPosts
    | ModSelf
    | ModTraffic
    | ModWiki
    | MySubreddits
    | PrivateMessages
    | Read
    | Report
    | Save
    | StructuredStyles
    | Submit
    | Subscribe
    | Vote
    | WikiEdit
    | WikiRead
    | Unlimited -- ^ For all scopes, corresponds to \"*\"
    deriving stock ( Generic, Eq, Show, Ord, Enum )

instance FromJSON Scope where
    parseJSON = genericParseJSON defaultOptions { constructorTagModifier }
      where
        constructorTagModifier = \case
            "Unlimited" -> "*"
            "Accounts"  -> "account"
            scope       -> toLower <$> scope

instance ToHttpApiData Scope where
    toQueryParam = \case
        Unlimited -> "*"
        Accounts  -> "account"
        s         -> showTextData s

--Requests---------------------------------------------------------------------
-- | HTTP method, excluding those not used in the Reddit API
data Method
    = GET
    | POST
    | DELETE
    | PUT
    | PATCH
    deriving stock ( Show, Eq, Generic )

-- | Data, either as JSON or URL-encoded form, to be attached to requests
data WithData
    = WithJSON Value
    | WithForm Form
    | WithMultipart [Part]
    | NoData
    deriving stock ( Show, Generic )

-- | An API request parameterized by the type it evaluates to when executed
data APIAction a = APIAction
    { method          :: Method
    , pathSegments    :: [PathSegment]
    , requestData     :: WithData
    , needsAuth       :: Bool
    , followRedirects :: Bool
    , rawJSON         :: Bool
    , checkResponse   :: Request -> Response BodyReader -> IO ()
    }
    deriving stock ( Generic )

-- | Type synonym for a segment of a URL path
type PathSegment = Text