Reddit.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module      : Network.Reddit
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit
    ( newClient
    , newClientWithManager
    , loadClient
    , getAuthURL
    , runReddit
    , runRedditT
    , tryReddit
    , getRateLimits
    , withRateLimitDelay
    , fileTokenManager
      -- * Actions
    , firstPage
    , nextPage
    , emptyPaginator
    , stream
      -- * Basic types
    , MonadReddit
    , RedditT
    , Client(Client)
    , RateLimits(RateLimits)
    , Listing(Listing)
    , Paginator(Paginator)
    , Paginable
    , ItemOpts(ItemOpts)
    , defaultItemOpts
    , ItemSort(..)
    , ItemReport(ItemReport)
    , Distinction(..)
    , Time(..)
    , ItemType(..)
    , UploadURL
    , Body
    , Title
    , URL
    , Subject
    , RGBText
    , Name
    , Domain
    , Modifier
      -- ** Exceptions
    , RedditException
    , ClientException(..)
    , APIException(..)
    , OAauthError(OAauthError)
    , ErrorMessage(..)
    , StatusMessage(StatusMessage)
    , StatusCode
    , JSONError(JSONError)
      -- * Auth
    , ClientState
    , AppType(..)
    , AuthConfig(AuthConfig)
    , UserAgent(UserAgent)
    , AccessToken(AccessToken)
    , Token
    , Code
    , Scope(..)
    , PasswordFlow(PasswordFlow)
    , CodeFlow(CodeFlow)
    , ClientID
    , ClientSecret
    , TokenDuration(..)
      -- * Re-exports
      -- | Only modules covering basic functionality are re-exported,
      -- including those for users, subreddits, submissions, comments,
      -- and actions for the authenticated user. For actions and types
      -- touching on moderation, collections, live threads, and more,
      -- import the respective modules directly
    , module M
    ) where

import           Conduit
                 ( (.|)
                 , ConduitT
                 , decodeUtf8LenientC
                 , encodeUtf8C
                 , mapC
                 , runConduit
                 , runConduitRes
                 , sinkFile
                 , sinkLazy
                 , sourceLazy
                 , withSourceFile
                 , yieldMany
                 )

import           Control.Monad.Catch
                 ( Exception
                 , MonadCatch(catch)
                 , MonadThrow(throwM)
                 , try
                 )
import           Control.Monad.Reader

import           Data.Bool
import           Data.Generics.Product     ( HasField(field) )
import           Data.Maybe
import           Data.Sequence             ( Seq(Empty, (:<|)) )
import qualified Data.Sequence             as Seq
import qualified Data.Text                 as T
import qualified Data.Text.Lazy            as LT
import           Data.Time.Clock.POSIX

import           Lens.Micro

import           Network.HTTP.Client.TLS   ( newTlsManager )
import           Network.Reddit.Auth
import           Network.Reddit.Comment    as M
import           Network.Reddit.Me         as M
import           Network.Reddit.Submission as M
import           Network.Reddit.Subreddit  as M
import           Network.Reddit.Types
import           Network.Reddit.User       as M
import           Network.Reddit.Utils

import           System.Random

import           UnliftIO                  ( MonadUnliftIO )
import           UnliftIO.Concurrent       ( threadDelay )
import           UnliftIO.IORef

import           Web.FormUrlEncoded        ( ToForm(toForm) )

-- | Create a new 'Client' for API access, given an 'AuthConfig'. This client is
-- required to run all actions in this library.
--
-- See 'loadClient' if you have a 'ScriptApp' or 'ApplicationOnly' app and would
-- like to load your auth details from an ini file
newClient :: (MonadUnliftIO m, MonadThrow m) => AuthConfig -> m Client
newClient ac =
    Client ac <$> newTlsManager <*> (newIORef =<< newState) <*> pure Nothing
  where
    newState = ClientState <$> getAccessToken toForm ac
        <*> liftIO getPOSIXTime
        <*> pure Nothing

-- | Create a new client with an existing refresh token, for 'WebApp's and
-- 'InstalledApp's. The initial refresh token is provided with a 'TokenManager'
-- that will also handle saving and loading refresh tokens over the life of
-- the new 'Client'
newClientWithManager :: (MonadUnliftIO m, MonadCatch m)
                     => TokenManager
                     -> AuthConfig
                     -> m Client
newClientWithManager mgr@TokenManager { .. } ac = Client ac <$> newTlsManager
    <*> (newIORef =<< newState)
    <*> pure (Just mgr)
  where
    newState = do
        token <- flip getAccessTokenWith ac =<< loadToken
        putToken $ token ^. field @"refreshToken"
        ClientState token <$> liftIO getPOSIXTime <*> pure Nothing

-- | Load a client from saved credentials, which are stored in an ini file. Files
-- should conform to the following formats:
--
-- For 'ScriptApp's:
--
-- > [NAME]
-- > id = <clientID>
-- > secret = <clientSecret>
-- > username = <username>
-- > password = <password>
-- > agent = <platform>,<appID>,<version>,<author>
--
-- For 'ApplicationOnly' apps without a user context:
--
-- > [NAME]
-- > id = <clientID>
-- > secret = <clientSecret>
-- > agent = <platform>,<appID>,<version>,<author>
--
-- Where NAME corresponds to a 'ClientSite' that you pass to this function.
-- You can have various different distinct sites in a single ini file. When
-- invoking this function, if the provided client site is @Nothing@, a section
-- labeled @[DEFAULT]@ will be used. If none is provided, an exception will be
-- thrown. Note that all section labels are case-insensitive.
--
-- The following locations are searched for an ini file, in order:
--
--      * $PWD\/auth.ini
--      * $XDG_CONFIG_HOME\/heddit\/auth.ini
--
-- __Note__: Only 'ScriptApp's and 'ApplicationOnly' are supported via this method
loadClient :: (MonadUnliftIO m, MonadThrow m) => Maybe ClientSite -> m Client
loadClient cs = newClient =<< loadAuthConfig (fromMaybe "default" cs)

-- | Run an action with your Reddit 'Client'. This will catch any exceptions
-- related to POST rate-limiting for you. After sleeping for the indicated
-- duration, it will attempt to re-run the action that triggered the exception.
-- If you do not wish to catch these exceptions, or would like to handle them
-- in a different way, use 'runRedditT', which simply runs the provided action
--
-- __Note__: Confusingly, Reddit uses /two/ different rate-limiting mechanisms.
-- This action only catches rate limiting applied to POST requests. Another form
-- of rate limiting is applied to API requests in general. This library does not
-- automatically deal with this second type. If you wish to deal with this
-- yourself, see the action 'withRateLimitDelay', which automatically applies a
-- delay based on the most recent rate limit headers returned from Reddit
runReddit :: (MonadCatch m, MonadIO m) => Client -> RedditT m a -> m a
runReddit client action =
    catch @_ @APIException (runRedditT client action) $ \case
        ErrorWithMessage (Ratelimited duration _) -> do
            threadDelay $ fromInteger duration * 1000000
            runReddit client action
        e -> throwM e

-- | Run an action with your Reddit 'Client', catching the exception specified and
-- returning an @Either@ in case of failure. It may be best to use @TypeApplications@
-- to specify the exception type.
--
-- For example, to try to see the user 'FlairTemplate's for a subreddit which may or
-- may not allow user flair:
--
-- >>> tryReddit @APIException c $ getUserFlairTemplates =<< mkSubredditName "haskell"
-- Left (ErrorWithStatus (StatusMessage {statusCode = 403, message = "Forbidden"}))
--
tryReddit :: forall e a m.
          (Exception e, MonadCatch m, MonadIO m)
          => Client
          -> RedditT m a
          -> m (Either e a)
tryReddit c = try @_ @e . runReddit c

-- | Convenience wrapper for actions taking a 'Paginator' and which return a
-- 'Listing'. This runs the action with a default initial paginator, and extracts
-- the @children@ from the returned 'Listing'. This discards all of the pagination
-- controls that are returned in the @Listing@. This is useful if you only care
-- about the child contents of the first \"page\" of results
--
-- For example, to get only the first page of results for a user's comments,
-- you could use the following:
--
-- > runReddit yourClient . firstPage $ getUserComments someUsername
--
firstPage :: (MonadReddit m, Paginable a)
          => (Paginator t a -> m (Listing t a))
          -> m (Seq a)
firstPage f = f emptyPaginator { limit = 100 } <&> (^. field @"children")

-- | Update a 'Paginator' with a 'Listing' to make a query for the next \"page\"
-- of content. If the first argument is @Nothing@, defaults will be used for
-- the options, partially depending on the type of paginator
--
-- __Note__: You cannot supply both the @before@ and @after@ fields when making
-- requests to API endpoints. If both fields are @Just@ in the @Paginator@ you
-- get back from this function, the @after@ field will take precedence. If you
-- want to use @before@ in such a scenario, make sure to set it to @Nothing@
-- before using the paginator in an action
--
-- Example:
--
-- >>> best1 <- runReddit yourClient $ getBest emptyPaginator
-- >>> best2 <- runReddit yourClient . getBest $ nextPage Nothing best1
--
nextPage :: forall t a.
         Paginable a
         => Maybe (Paginator t a)
         -> Listing t a
         -> Paginator t a
nextPage (Just p) Listing { .. } = p { before, after }
nextPage (const (emptyPaginator @t @a) -> p) -- Default paginator
         Listing { .. } = p { before, after }

-- | Get current information on rate limiting, if any
getRateLimits :: MonadReddit m => m (Maybe RateLimits)
getRateLimits = readClientState $ field @"limits"

-- | Run the provided 'MonadReddit' action with a delay, if rate-limiting
-- information is currently available
withRateLimitDelay :: MonadReddit m => m a -> m a
withRateLimitDelay action = getRateLimits >>= \case
    Nothing                -> action
    Just RateLimits { .. } -> do
        now <- liftIO getPOSIXTime
        let duration = nextRequest - now
            sleep    = threadDelay $ round duration * 1000000
        bool (pure ()) sleep $ duration > 0
        action

-- | Transform an action producing a @Listing@ of items into an infinite stream.
-- Items are pushed to the stream as they are fetched, with oldest items yielded
-- first. New items are fetched in 100-item batches. If nothing new arrives in
-- the stream, a jittered exponential backoff is applied, up to a cap of ~16s,
-- resetting once new items arrive again.
--
-- For example, to fetch new submissions published to \"r/haskell\", as they
-- are created, and print their IDs to the console:
--
-- >>> import Conduit
-- >>> subName <- mkSubredditName "haskell"
-- >>> action = getNewSubmissions subName
-- >>> printTitle = liftIO . print . (^. #title)
-- >>> runReddit c . runConduit $ stream Nothing action  .| mapM_C printTitle
-- SubmissionID "o6948i"
-- SubmissionID "o6b0w0"
-- SubmissionID "o6cqof"
-- SubmissionID "o6ddl9"
-- SubmissionID "o6dlas"
-- ...
--
stream :: forall m t a.
       ( MonadReddit m  --
       , Paginable a
       , t ~ PaginateThing a
       )
       => Maybe Bool
       -- ^ When @True@, will only yield items that have
       -- newly arrived, thus skipping items from the first
       -- request that already existed
       -> (Paginator t a -> m (Listing t a))
       -> ConduitT () a m ()
stream (fromMaybe False -> skip) action =
    go skip 1 emptyPaginator { limit = 100 }
  where
    go :: Bool -> Double -> Paginator t a -> ConduitT i a m b
    go skipInit n paginator = do
        Listing { children } <- lift $ action paginator
        case children of
            Empty   -> do
                (delay, nextBase) <- backoff n
                threadDelay . round $ delay * 1000000
                go False nextBase paginator { after = Nothing }
            t :<| _ -> do
                bool (yieldMany $ Seq.reverse children) (pure ()) skipInit
                go False
                   1
                   paginator
                   { before = Just $ getFullname t --
                   , after  = Nothing
                   }

    backoff base = do
        jitter <- randomIO @Double
        pure ( base + jitter * maxJitter - maxJitter / 2
             , min (base * 2) maxBase
             )
      where
        maxJitter = base / 16

        maxBase   = 16

-- | This is an example 'TokenManager' that can be used to store and retrieve
-- OAUth refresh tokens, which could be used with 'newClientWithManager'. For
-- a real application, you would probably want to use a more sophisticated
-- manager
fileTokenManager
    :: Exception e
    => e
    -- ^ An exception that will be thrown when Reddit doesn\'t return a
    -- new refresh token
    -> FilePath -- ^ The location of the stored tokens
    -> TokenManager
fileTokenManager e fp = TokenManager load put
  where
    load :: MonadIO m => m Token
    load = liftIO . withSourceFile @_ @IO fp $ \b -> LT.toStrict
        <$> runConduit (b .| decodeUtf8LenientC .| mapC T.strip .| sinkLazy)

    put :: (MonadIO m, MonadThrow m) => Maybe Token -> m ()
    put = maybe (throwM e) writeToken
      where
        writeToken rt = liftIO . runConduitRes
            $ sourceLazy (LT.fromStrict rt) .| encodeUtf8C .| sinkFile fp