{-# 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)
    , 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 :: AuthConfig -> m Client
newClient AuthConfig
ac =
    AuthConfig
-> Manager -> IORef ClientState -> Maybe TokenManager -> Client
Client AuthConfig
ac (Manager -> IORef ClientState -> Maybe TokenManager -> Client)
-> m Manager
-> m (IORef ClientState -> Maybe TokenManager -> Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager m (IORef ClientState -> Maybe TokenManager -> Client)
-> m (IORef ClientState) -> m (Maybe TokenManager -> Client)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClientState -> m (IORef ClientState)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (ClientState -> m (IORef ClientState))
-> m ClientState -> m (IORef ClientState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ClientState
newState) m (Maybe TokenManager -> Client)
-> m (Maybe TokenManager) -> m Client
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe TokenManager -> m (Maybe TokenManager)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TokenManager
forall a. Maybe a
Nothing
  where
    newState :: m ClientState
newState = AccessToken -> POSIXTime -> Maybe RateLimits -> ClientState
ClientState (AccessToken -> POSIXTime -> Maybe RateLimits -> ClientState)
-> m AccessToken
-> m (POSIXTime -> Maybe RateLimits -> ClientState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppType -> Form) -> AuthConfig -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
(AppType -> Form) -> AuthConfig -> m AccessToken
getAccessToken AppType -> Form
forall a. ToForm a => a -> Form
toForm AuthConfig
ac
        m (POSIXTime -> Maybe RateLimits -> ClientState)
-> m POSIXTime -> m (Maybe RateLimits -> ClientState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
        m (Maybe RateLimits -> ClientState)
-> m (Maybe RateLimits) -> m ClientState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe RateLimits -> m (Maybe RateLimits)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RateLimits
forall a. Maybe a
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 :: TokenManager -> AuthConfig -> m Client
newClientWithManager mgr :: TokenManager
mgr@TokenManager { forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe Token -> m ()
$sel:putToken:TokenManager :: TokenManager
-> forall (m :: * -> *).
   (MonadIO m, MonadThrow m) =>
   Maybe Token -> m ()
$sel:loadToken:TokenManager :: TokenManager
-> forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token
putToken :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe Token -> m ()
loadToken :: forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token
.. } AuthConfig
ac = AuthConfig
-> Manager -> IORef ClientState -> Maybe TokenManager -> Client
Client AuthConfig
ac (Manager -> IORef ClientState -> Maybe TokenManager -> Client)
-> m Manager
-> m (IORef ClientState -> Maybe TokenManager -> Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
    m (IORef ClientState -> Maybe TokenManager -> Client)
-> m (IORef ClientState) -> m (Maybe TokenManager -> Client)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClientState -> m (IORef ClientState)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (ClientState -> m (IORef ClientState))
-> m ClientState -> m (IORef ClientState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ClientState
newState)
    m (Maybe TokenManager -> Client)
-> m (Maybe TokenManager) -> m Client
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe TokenManager -> m (Maybe TokenManager)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenManager -> Maybe TokenManager
forall a. a -> Maybe a
Just TokenManager
mgr)
  where
    newState :: m ClientState
newState = do
        AccessToken
token <- (Token -> AuthConfig -> m AccessToken)
-> AuthConfig -> Token -> m AccessToken
forall a b c. (a -> b -> c) -> b -> a -> c
flip Token -> AuthConfig -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
Token -> AuthConfig -> m AccessToken
getAccessTokenWith AuthConfig
ac (Token -> m AccessToken) -> m Token -> m AccessToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Token
forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token
loadToken
        Maybe Token -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe Token -> m ()
putToken (Maybe Token -> m ()) -> Maybe Token -> m ()
forall a b. (a -> b) -> a -> b
$ AccessToken
token AccessToken
-> Getting (Maybe Token) AccessToken (Maybe Token) -> Maybe Token
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "refreshToken" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"refreshToken"
        AccessToken -> POSIXTime -> Maybe RateLimits -> ClientState
ClientState AccessToken
token (POSIXTime -> Maybe RateLimits -> ClientState)
-> m POSIXTime -> m (Maybe RateLimits -> ClientState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime m (Maybe RateLimits -> ClientState)
-> m (Maybe RateLimits) -> m ClientState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe RateLimits -> m (Maybe RateLimits)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RateLimits
forall a. Maybe a
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 :: Maybe Token -> m Client
loadClient Maybe Token
cs = AuthConfig -> m Client
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
AuthConfig -> m Client
newClient (AuthConfig -> m Client) -> m AuthConfig -> m Client
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Token -> m AuthConfig
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
Token -> m AuthConfig
loadAuthConfig (Token -> Maybe Token -> Token
forall a. a -> Maybe a -> a
fromMaybe Token
"default" Maybe Token
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 -> RedditT m a -> m a
runReddit Client
client RedditT m a
action =
    m a -> (APIException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch @_ @APIException (Client -> RedditT m a -> m a
forall (m :: * -> *) a. Client -> RedditT m a -> m a
runRedditT Client
client RedditT m a
action) ((APIException -> m a) -> m a) -> (APIException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \case
        ErrorWithMessage (Ratelimited Integer
duration Token
_) -> do
            Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
duration Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
            Client -> RedditT m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
Client -> RedditT m a -> m a
runReddit Client
client RedditT m a
action
        APIException
e -> APIException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
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 :: Client -> RedditT m a -> m (Either e a)
tryReddit Client
c = forall a. (MonadCatch m, Exception e) => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @e (m a -> m (Either e a))
-> (RedditT m a -> m a) -> RedditT m a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client -> RedditT m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
Client -> RedditT m a -> m a
runReddit Client
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 :: (Paginator t a -> m (Listing t a)) -> m (Seq a)
firstPage Paginator t a -> m (Listing t a)
f = Paginator t a -> m (Listing t a)
f Paginator t a
forall t a. Paginable a => Paginator t a
emptyPaginator m (Listing t a) -> (Listing t a -> Seq a) -> m (Seq a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Listing t a -> Getting (Seq a) (Listing t a) (Seq a) -> Seq a
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "children" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
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 :: Maybe (Paginator t a) -> Listing t a -> Paginator t a
nextPage (Just Paginator t a
p) Listing { Maybe t
Seq a
$sel:children:Listing :: forall t a. Listing t a -> Seq a
$sel:after:Listing :: forall t a. Listing t a -> Maybe t
$sel:before:Listing :: forall t a. Listing t a -> Maybe t
children :: Seq a
after :: Maybe t
before :: Maybe t
.. } = Paginator t a
p { Maybe t
$sel:before:Paginator :: Maybe t
before :: Maybe t
before, Maybe t
$sel:after:Paginator :: Maybe t
after :: Maybe t
after }
nextPage (Paginator t a -> Maybe (Paginator t a) -> Paginator t a
forall a b. a -> b -> a
const (Paginable a => Paginator t a
forall t a. Paginable a => Paginator t a
emptyPaginator @t @a) -> Paginator t a
p) -- Default paginator
         Listing { Maybe t
Seq a
children :: Seq a
after :: Maybe t
before :: Maybe t
$sel:children:Listing :: forall t a. Listing t a -> Seq a
$sel:after:Listing :: forall t a. Listing t a -> Maybe t
$sel:before:Listing :: forall t a. Listing t a -> Maybe t
.. } = Paginator t a
p { Maybe t
before :: Maybe t
$sel:before:Paginator :: Maybe t
before, Maybe t
after :: Maybe t
$sel:after:Paginator :: Maybe t
after }

-- | Get current information on rate limiting, if any
getRateLimits :: MonadReddit m => m (Maybe RateLimits)
getRateLimits :: m (Maybe RateLimits)
getRateLimits = Lens' ClientState (Maybe RateLimits) -> m (Maybe RateLimits)
forall (m :: * -> *) a. MonadReddit m => Lens' ClientState a -> m a
readClientState (Lens' ClientState (Maybe RateLimits) -> m (Maybe RateLimits))
-> Lens' ClientState (Maybe RateLimits) -> m (Maybe RateLimits)
forall a b. (a -> b) -> a -> b
$ forall s t a b. HasField "limits" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
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 :: m a -> m a
withRateLimitDelay m a
action = m (Maybe RateLimits)
forall (m :: * -> *). MonadReddit m => m (Maybe RateLimits)
getRateLimits m (Maybe RateLimits) -> (Maybe RateLimits -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RateLimits
Nothing                -> m a
action
    Just RateLimits { Integer
POSIXTime
$sel:nextRequest:RateLimits :: RateLimits -> POSIXTime
$sel:reset:RateLimits :: RateLimits -> POSIXTime
$sel:used:RateLimits :: RateLimits -> Integer
$sel:remaining:RateLimits :: RateLimits -> Integer
nextRequest :: POSIXTime
reset :: POSIXTime
used :: Integer
remaining :: Integer
.. } -> do
        POSIXTime
now <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
        let duration :: POSIXTime
duration = POSIXTime
nextRequest POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
now
            sleep :: m ()
sleep    = Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round POSIXTime
duration Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
        m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) m ()
sleep (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ POSIXTime
duration POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
0
        m a
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 them 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 :: Maybe Bool
-> (Paginator t a -> m (Listing t a)) -> ConduitT () a m ()
stream (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False -> Bool
skip) Paginator t a -> m (Listing t a)
action =
    Bool -> Double -> Paginator t a -> ConduitT () a m ()
forall i b. Bool -> Double -> Paginator t a -> ConduitT i a m b
go Bool
skip Double
1 Paginator t a
forall t a. Paginable a => Paginator t a
emptyPaginator { $sel:limit:Paginator :: Word
limit = Word
100 }
  where
    go :: Bool -> Double -> Paginator t a -> ConduitT i a m b
    go :: Bool -> Double -> Paginator t a -> ConduitT i a m b
go Bool
skipInit Double
n Paginator t a
paginator = do
        Listing { Seq a
children :: Seq a
$sel:children:Listing :: forall t a. Listing t a -> Seq a
children } <- m (Listing t a) -> ConduitT i a m (Listing t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Listing t a) -> ConduitT i a m (Listing t a))
-> m (Listing t a) -> ConduitT i a m (Listing t a)
forall a b. (a -> b) -> a -> b
$ Paginator t a -> m (Listing t a)
action Paginator t a
paginator
        case Seq a
children of
            Seq a
Empty   -> do
                (Double
delay, Double
nextBase) <- Double -> ConduitT i a m (Double, Double)
forall (m :: * -> *). MonadIO m => Double -> m (Double, Double)
backoff Double
n
                Int -> ConduitT i a m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> ConduitT i a m ())
-> (Double -> Int) -> Double -> ConduitT i a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> ConduitT i a m ()) -> Double -> ConduitT i a m ()
forall a b. (a -> b) -> a -> b
$ Double
delay Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000
                Bool -> Double -> Paginator t a -> ConduitT i a m b
forall i b. Bool -> Double -> Paginator t a -> ConduitT i a m b
go Bool
False Double
nextBase Paginator t a
paginator { $sel:after:Paginator :: Maybe t
after = Maybe t
forall a. Maybe a
Nothing }
            a
t :<| Seq a
_ -> do
                ConduitT i a m () -> ConduitT i a m () -> Bool -> ConduitT i a m ()
forall a. a -> a -> Bool -> a
bool (Seq a -> ConduitT i (Element (Seq a)) m ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany (Seq a -> ConduitT i (Element (Seq a)) m ())
-> Seq a -> ConduitT i (Element (Seq a)) m ()
forall a b. (a -> b) -> a -> b
$ Seq a -> Seq a
forall a. Seq a -> Seq a
Seq.reverse Seq a
children) (() -> ConduitT i a m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Bool
skipInit
                Bool -> Double -> Paginator t a -> ConduitT i a m b
forall i b. Bool -> Double -> Paginator t a -> ConduitT i a m b
go Bool
False
                   Double
1
                   Paginator t a
paginator
                   { $sel:before:Paginator :: Maybe t
before = t -> Maybe t
forall a. a -> Maybe a
Just (t -> Maybe t) -> t -> Maybe t
forall a b. (a -> b) -> a -> b
$ a -> PaginateThing a
forall a. Paginable a => a -> PaginateThing a
getFullname a
t --
                   , $sel:after:Paginator :: Maybe t
after  = Maybe t
forall a. Maybe a
Nothing
                   }

    backoff :: Double -> m (Double, Double)
backoff Double
base = do
        Double
jitter <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
forall (m :: * -> *). (Random Double, MonadIO m) => m Double
randomIO @Double
        (Double, Double) -> m (Double, Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Double
base Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
jitter Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
maxJitter Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
maxJitter Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
             , Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
base Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2) Double
maxBase
             )
      where
        maxJitter :: Double
maxJitter = Double
base Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
16

        maxBase :: Double
maxBase   = Double
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 -> FilePath -> TokenManager
fileTokenManager e
e FilePath
fp = (forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token)
-> (forall (m :: * -> *).
    (MonadIO m, MonadThrow m) =>
    Maybe Token -> m ())
-> TokenManager
TokenManager forall (m :: * -> *). MonadIO m => m Token
forall (m :: * -> *). (MonadIO m, MonadThrow m) => m Token
load forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe Token -> m ()
put
  where
    load :: MonadIO m => m Token
    load :: m Token
load = IO Token -> m Token
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Token -> m Token)
-> ((ConduitM () ByteString IO () -> IO Token) -> IO Token)
-> (ConduitM () ByteString IO () -> IO Token)
-> m Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (ConduitM () ByteString IO () -> IO Token) -> IO Token
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile @_ @IO FilePath
fp ((ConduitM () ByteString IO () -> IO Token) -> m Token)
-> (ConduitM () ByteString IO () -> IO Token) -> m Token
forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
b -> Text -> Token
LT.toStrict
        (Text -> Token) -> IO Text -> IO Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void IO Text -> IO Text
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
b ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO Text -> ConduitT () Void IO Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Token IO ()
forall (m :: * -> *). Monad m => ConduitT ByteString Token m ()
decodeUtf8LenientC ConduitT ByteString Token IO ()
-> ConduitM Token Void IO Text -> ConduitM ByteString Void IO Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Token -> Token) -> ConduitT Token Token IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC Token -> Token
T.strip ConduitT Token Token IO ()
-> ConduitM Token Void IO Text -> ConduitM Token Void IO Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Token Void IO Text
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy)

    put :: (MonadIO m, MonadThrow m) => Maybe Token -> m ()
    put :: Maybe Token -> m ()
put = m () -> (Token -> m ()) -> Maybe Token -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e) Token -> m ()
writeToken
      where
        writeToken :: Token -> m ()
writeToken Token
rt = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
            (ConduitT () Void (ResourceT IO) () -> m ())
-> ConduitT () Void (ResourceT IO) () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ConduitT () Token (ResourceT IO) ()
forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy (Token -> Text
LT.fromStrict Token
rt) ConduitT () Token (ResourceT IO) ()
-> ConduitM Token Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Token ByteString (ResourceT IO) ()
forall (m :: * -> *) text binary.
(Monad m, Utf8 text binary) =>
ConduitT text binary m ()
encodeUtf8C ConduitT Token ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) ()
-> ConduitM Token Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| FilePath -> ConduitM ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
sinkFile FilePath
fp