{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Network.Reddit.Internal
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Internal
    ( runAction
    , runAction_
    , runActionWith
    , runActionWith_
    , mkRequest
    , getMany
    , redditURL
    , oauthURL
    ) where

import           Conduit                               ( (.|), runConduit )

import           Control.Monad
import           Control.Monad.Catch                   ( MonadThrow(throwM) )
import           Control.Monad.IO.Class                ( MonadIO(liftIO) )
import           Control.Monad.Reader                  ( asks )

import           Data.Aeson
                 ( FromJSON
                 , decode
                 , eitherDecode
                 , encode
                 )
import           Data.Bool
import           Data.ByteString                       ( ByteString )
import qualified Data.ByteString.Lazy                  as LB
import qualified Data.CaseInsensitive                  as CI
import           Data.Conduit.Binary                   ( sinkLbs )
import qualified Data.Foldable                         as F
import           Data.Foldable                         ( for_ )
import           Data.Generics.Product                 ( HasField(field) )
import           Data.Ix
import           Data.List.Split                       ( chunksOf )
import           Data.Sequence                         ( Seq )
import qualified Data.Text                             as T
import           Data.Text                             ( Text )
import qualified Data.Text.Encoding                    as T
import           Data.Time.Clock.POSIX

import           Lens.Micro

import           Network.HTTP.Client.Conduit
                 ( Request
                 , RequestBody(RequestBodyLBS)
                 , Response
                 , withResponse
                 )
import qualified Network.HTTP.Client.Conduit           as H
import           Network.HTTP.Client.MultipartFormData ( formDataBody )
import qualified Network.HTTP.Conduit                  as H
import qualified Network.HTTP.Types                    as H
import           Network.Reddit.Auth
import           Network.Reddit.Types
import           Network.Reddit.Utils

import           UnliftIO.IORef

import           Web.FormUrlEncoded
                 ( ToForm(toForm)
                 , urlEncodeFormStable
                 )
import           Web.HttpApiData                       ( ToHttpApiData(..) )

-- | Run an 'APIAction' and decode the response JSON, governed by the type
-- parameterizing the action
runAction :: forall a m. (MonadReddit m, FromJSON a) => APIAction a -> m a
runAction :: APIAction a -> m a
runAction action :: APIAction a
action@APIAction { Bool
[PathSegment]
WithData
Method
Request -> Response BodyReader -> IO ()
$sel:checkResponse:APIAction :: forall a. APIAction a -> Request -> Response BodyReader -> IO ()
$sel:rawJSON:APIAction :: forall a. APIAction a -> Bool
$sel:followRedirects:APIAction :: forall a. APIAction a -> Bool
$sel:needsAuth:APIAction :: forall a. APIAction a -> Bool
$sel:requestData:APIAction :: forall a. APIAction a -> WithData
$sel:pathSegments:APIAction :: forall a. APIAction a -> [PathSegment]
$sel:method:APIAction :: forall a. APIAction a -> Method
checkResponse :: Request -> Response BodyReader -> IO ()
rawJSON :: Bool
followRedirects :: Bool
needsAuth :: Bool
requestData :: WithData
pathSegments :: [PathSegment]
method :: Method
.. } = do
    m ()
forall (m :: * -> *). MonadReddit m => m ()
ensureToken
    (Response (RawBody m)
resp, a
x) <- Bool -> Request -> m (Response (RawBody m), a)
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
Bool -> Request -> m (Response (RawBody m), a)
runActionWith Bool
followRedirects (Request -> m (Response (RawBody m), a))
-> m Request -> m (Response (RawBody m), a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< APIAction a -> m Request
forall (m :: * -> *) a. MonadReddit m => APIAction a -> m Request
prepareRequest APIAction a
action
    Response (RawBody m) -> m ()
forall (m :: * -> *). MonadReddit m => Response (RawBody m) -> m ()
updateRateLimits Response (RawBody m)
resp
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Run an action, discarding the response body
runAction_ :: forall m. MonadReddit m => APIAction () -> m ()
runAction_ :: APIAction () -> m ()
runAction_ APIAction ()
action = do
    m ()
forall (m :: * -> *). MonadReddit m => m ()
ensureToken
    Response (RawBody m) -> m ()
forall (m :: * -> *). MonadReddit m => Response (RawBody m) -> m ()
updateRateLimits (Response (RawBody m) -> m ()) -> m (Response (RawBody m)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> m (Response (RawBody m))
forall (m :: * -> *).
MonadReddit m =>
Request -> m (Response (RawBody m))
runActionWith_ (Request -> m (Response (RawBody m)))
-> m Request -> m (Response (RawBody m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< APIAction () -> m Request
forall (m :: * -> *) a. MonadReddit m => APIAction a -> m Request
prepareRequest APIAction ()
action

ensureToken :: MonadReddit m => m ()
ensureToken :: m ()
ensureToken = do
    POSIXTime
expiresIn <- Lens' ClientState POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadReddit m => Lens' ClientState a -> m a
readClientState (Lens' ClientState POSIXTime -> m POSIXTime)
-> Lens' ClientState POSIXTime -> m POSIXTime
forall a b. (a -> b) -> a -> b
$ forall s t a b. HasField "accessToken" 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 @"accessToken" ((AccessToken -> f AccessToken) -> ClientState -> f ClientState)
-> ((POSIXTime -> f POSIXTime) -> AccessToken -> f AccessToken)
-> (POSIXTime -> f POSIXTime)
-> ClientState
-> f ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. HasField "expiresIn" 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 @"expiresIn"
    POSIXTime
obtained <- Lens' ClientState POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadReddit m => Lens' ClientState a -> m a
readClientState (Lens' ClientState POSIXTime -> m POSIXTime)
-> Lens' ClientState POSIXTime -> m POSIXTime
forall a b. (a -> b) -> a -> b
$ forall s t a b. HasField "tokenObtained" 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 @"tokenObtained"
    POSIXTime
now <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (POSIXTime
now POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> (POSIXTime
obtained POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
10) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
expiresIn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        AccessToken
newToken <- m AccessToken
forall (m :: * -> *). MonadReddit m => m AccessToken
refreshAccessToken
        IORef ClientState
state <- (Client -> IORef ClientState) -> m (IORef ClientState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Client
-> Getting (IORef ClientState) Client (IORef ClientState)
-> IORef ClientState
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "clientState" 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 @"clientState")
        IORef ClientState -> (ClientState -> (ClientState, ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef ClientState
state ((ClientState -> (ClientState, ())) -> m ())
-> (ClientState -> (ClientState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \ClientState
s ->
            ( ClientState
s
              ClientState -> (ClientState -> ClientState) -> ClientState
forall a b. a -> (a -> b) -> b
& (forall s t a b. HasField "tokenObtained" 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 @"tokenObtained" ((POSIXTime -> Identity POSIXTime)
 -> ClientState -> Identity ClientState)
-> POSIXTime -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ POSIXTime
now)
              (ClientState -> ClientState)
-> (ClientState -> ClientState) -> ClientState -> ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s t a b. HasField "accessToken" 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 @"accessToken" ((AccessToken -> Identity AccessToken)
 -> ClientState -> Identity ClientState)
-> AccessToken -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AccessToken
newToken)
            , ()
            )

-- | Update the current rate limit info, reading it from Reddit\'s response
-- headers
updateRateLimits :: MonadReddit m => Response (RawBody m) -> m ()
updateRateLimits :: Response (RawBody m) -> m ()
updateRateLimits Response (RawBody m)
resp = do
    POSIXTime
now <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
    Maybe RateLimits -> (RateLimits -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Response (RawBody m)
resp Response (RawBody m)
-> (Response (RawBody m) -> ResponseHeaders) -> ResponseHeaders
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
H.responseHeaders ResponseHeaders
-> (ResponseHeaders -> Maybe RateLimits) -> Maybe RateLimits
forall a b. a -> (a -> b) -> b
& POSIXTime -> ResponseHeaders -> Maybe RateLimits
readRateLimits POSIXTime
now) ((RateLimits -> m ()) -> m ()) -> (RateLimits -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \RateLimits
rls -> do
        IORef ClientState
state <- (Client -> IORef ClientState) -> m (IORef ClientState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Client
-> Getting (IORef ClientState) Client (IORef ClientState)
-> IORef ClientState
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "clientState" 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 @"clientState")
        IORef ClientState -> (ClientState -> (ClientState, ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef ClientState
state ((ClientState -> (ClientState, ())) -> m ())
-> (ClientState -> (ClientState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \ClientState
s -> (ClientState
s ClientState -> (ClientState -> ClientState) -> ClientState
forall a b. a -> (a -> b) -> 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" ((Maybe RateLimits -> Identity (Maybe RateLimits))
 -> ClientState -> Identity ClientState)
-> RateLimits -> ClientState -> ClientState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ RateLimits
rls, ())

runActionWith :: forall a m.
              (MonadReddit m, FromJSON a)
              => Bool
              -> Request
              -> m (Response (RawBody m), a)
runActionWith :: Bool -> Request -> m (Response (RawBody m), a)
runActionWith Bool
followRedirects Request
req = Request
-> (Response (RawBody m) -> m (Response (RawBody m), a))
-> m (Response (RawBody m), a)
forall (m :: * -> *) (n :: * -> *) env i a.
(MonadUnliftIO m, MonadIO n, MonadReader env m,
 HasHttpManager env) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse @_ @m Request
req ((Response (RawBody m) -> m (Response (RawBody m), a))
 -> m (Response (RawBody m), a))
-> (Response (RawBody m) -> m (Response (RawBody m), a))
-> m (Response (RawBody m), a)
forall a b. (a -> b) -> a -> b
$ \Response (RawBody m)
resp -> do
    let body :: RawBody m
body       = Response (RawBody m)
resp Response (RawBody m)
-> (Response (RawBody m) -> RawBody m) -> RawBody m
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> RawBody m
forall body. Response body -> body
H.responseBody
        status :: Status
status     = Response (RawBody m)
resp Response (RawBody m) -> (Response (RawBody m) -> Status) -> Status
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> Status
forall body. Response body -> Status
H.responseStatus
        statusCode :: Int
statusCode = Status
status Status -> (Status -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Status -> Int
H.statusCode
        headers :: ResponseHeaders
headers    = Response (RawBody m)
resp Response (RawBody m)
-> (Response (RawBody m) -> ResponseHeaders) -> ResponseHeaders
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
H.responseHeaders
        cookies :: CookieJar
cookies    = Response (RawBody m)
resp Response (RawBody m)
-> (Response (RawBody m) -> CookieJar) -> CookieJar
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> CookieJar
forall body. Response body -> CookieJar
H.responseCookieJar
    ByteString
bodyBS <- ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m ByteString -> m ByteString)
-> ConduitT () Void m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ RawBody m
body RawBody m
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m ByteString
sinkLbs
    if
        | (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
300, Int
308) Int
statusCode Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
followRedirects -> APIException -> m (Response (RawBody m), a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
            (APIException -> m (Response (RawBody m), a))
-> (Maybe Request -> APIException)
-> Maybe Request
-> m (Response (RawBody m), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Request -> APIException
Redirected
            (Maybe Request -> m (Response (RawBody m), a))
-> Maybe Request -> m (Response (RawBody m), a)
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders -> CookieJar -> Int -> Maybe Request
H.getRedirectedRequest Request
req ResponseHeaders
headers CookieJar
cookies Int
statusCode
        | Bool
otherwise -> case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode @a ByteString
bodyBS of
            Right a
x  -> (Response (RawBody m), a) -> m (Response (RawBody m), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response (RawBody m)
resp, a
x)
            Left String
err -> case ByteString -> Maybe APIException
forall a. FromJSON a => ByteString -> Maybe a
decode @APIException ByteString
bodyBS of
                Just APIException
e  -> APIException -> m (Response (RawBody m), a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e
                Maybe APIException
Nothing -> APIException -> m (Response (RawBody m), a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (APIException -> m (Response (RawBody m), a))
-> (PathSegment -> APIException)
-> PathSegment
-> m (Response (RawBody m), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathSegment -> ByteString -> APIException)
-> ByteString -> PathSegment -> APIException
forall a b c. (a -> b -> c) -> b -> a -> c
flip PathSegment -> ByteString -> APIException
JSONParseError ByteString
bodyBS
                    (PathSegment -> m (Response (RawBody m), a))
-> PathSegment -> m (Response (RawBody m), a)
forall a b. (a -> b) -> a -> b
$ PathSegment
"runAction: Error parsing JSON - " PathSegment -> PathSegment -> PathSegment
forall a. Semigroup a => a -> a -> a
<> String -> PathSegment
T.pack String
err

runActionWith_
    :: forall m. MonadReddit m => Request -> m (Response (RawBody m))
runActionWith_ :: Request -> m (Response (RawBody m))
runActionWith_ Request
req = Request
-> (Response (RawBody m) -> m (Response (RawBody m)))
-> m (Response (RawBody m))
forall (m :: * -> *) (n :: * -> *) env i a.
(MonadUnliftIO m, MonadIO n, MonadReader env m,
 HasHttpManager env) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse @_ @m Request
req ((Response (RawBody m) -> m (Response (RawBody m)))
 -> m (Response (RawBody m)))
-> (Response (RawBody m) -> m (Response (RawBody m)))
-> m (Response (RawBody m))
forall a b. (a -> b) -> a -> b
$ \Response (RawBody m)
resp -> do
    let body :: RawBody m
body       = Response (RawBody m)
resp Response (RawBody m)
-> (Response (RawBody m) -> RawBody m) -> RawBody m
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> RawBody m
forall body. Response body -> body
H.responseBody
        status :: Status
status     = Response (RawBody m)
resp Response (RawBody m) -> (Response (RawBody m) -> Status) -> Status
forall a b. a -> (a -> b) -> b
& Response (RawBody m) -> Status
forall body. Response body -> Status
H.responseStatus
        statusCode :: Int
statusCode = Status
status Status -> (Status -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Status -> Int
H.statusCode
    ByteString
bodyBS <- ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m ByteString -> m ByteString)
-> ConduitT () Void m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ RawBody m
body RawBody m
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m ByteString
sinkLbs
    if
        | (Int
statusCode Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300) -> case ByteString -> Maybe APIException
forall a. FromJSON a => ByteString -> Maybe a
decode @APIException ByteString
bodyBS of
            Just APIException
e  -> APIException -> m (Response (RawBody m))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e
            Maybe APIException
Nothing -> APIException -> m (Response (RawBody m))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                (APIException -> m (Response (RawBody m)))
-> APIException -> m (Response (RawBody m))
forall a b. (a -> b) -> a -> b
$ PathSegment -> ByteString -> APIException
JSONParseError PathSegment
"runAction_: Failed to parse error JSON"
                                 ByteString
bodyBS
        | Bool
otherwise -> Response (RawBody m) -> m (Response (RawBody m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response (RawBody m)
resp

prepareRequest :: MonadReddit m => APIAction a -> m Request
prepareRequest :: APIAction a -> m Request
prepareRequest act :: APIAction a
act@APIAction { Bool
[PathSegment]
WithData
Method
Request -> Response BodyReader -> IO ()
checkResponse :: Request -> Response BodyReader -> IO ()
rawJSON :: Bool
followRedirects :: Bool
needsAuth :: Bool
requestData :: WithData
pathSegments :: [PathSegment]
method :: Method
$sel:checkResponse:APIAction :: forall a. APIAction a -> Request -> Response BodyReader -> IO ()
$sel:rawJSON:APIAction :: forall a. APIAction a -> Bool
$sel:followRedirects:APIAction :: forall a. APIAction a -> Bool
$sel:needsAuth:APIAction :: forall a. APIAction a -> Bool
$sel:requestData:APIAction :: forall a. APIAction a -> WithData
$sel:pathSegments:APIAction :: forall a. APIAction a -> [PathSegment]
$sel:method:APIAction :: forall a. APIAction a -> Method
.. } =
    m Request -> m Request -> Bool -> m Request
forall a. a -> a -> Bool -> a
bool (ByteString -> APIAction a -> m Request
forall (m :: * -> *) a.
MonadIO m =>
ByteString -> APIAction a -> m Request
mkRequest ByteString
redditURL APIAction a
act)
         (Request -> m Request
forall (m :: * -> *). MonadReddit m => Request -> m Request
setHeaders (Request -> m Request) -> m Request -> m Request
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> APIAction a -> m Request
forall (m :: * -> *) a.
MonadIO m =>
ByteString -> APIAction a -> m Request
mkRequest ByteString
oauthURL APIAction a
act)
         Bool
needsAuth

mkRequest :: MonadIO m => ByteString -> APIAction a -> m Request
mkRequest :: ByteString -> APIAction a -> m Request
mkRequest ByteString
host APIAction { Bool
[PathSegment]
WithData
Method
Request -> Response BodyReader -> IO ()
checkResponse :: Request -> Response BodyReader -> IO ()
rawJSON :: Bool
followRedirects :: Bool
needsAuth :: Bool
requestData :: WithData
pathSegments :: [PathSegment]
method :: Method
$sel:checkResponse:APIAction :: forall a. APIAction a -> Request -> Response BodyReader -> IO ()
$sel:rawJSON:APIAction :: forall a. APIAction a -> Bool
$sel:followRedirects:APIAction :: forall a. APIAction a -> Bool
$sel:needsAuth:APIAction :: forall a. APIAction a -> Bool
$sel:requestData:APIAction :: forall a. APIAction a -> WithData
$sel:pathSegments:APIAction :: forall a. APIAction a -> [PathSegment]
$sel:method:APIAction :: forall a. APIAction a -> Method
.. } = case WithData
requestData of
    WithJSON Value
d       -> Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ case Method
method of
        Method
p
            | Method
p Method -> [Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Method
POST, Method
PUT, Method
PATCH ] -> Request
request
                { requestBody :: RequestBody
H.requestBody    = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
d
                , requestHeaders :: ResponseHeaders
H.requestHeaders =
                      [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"content-type", ByteString
"application/json") ]
                }
            | Bool
otherwise -> Request
request
    WithForm Form
fd      -> Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ case Method
method of
        Method
GET -> Request
request
            { queryString :: ByteString
H.queryString = (Request
request Request -> (Request -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Request -> ByteString
H.queryString)
                  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"&"
                  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
LB.toStrict (Form -> ByteString
urlEncodeFormStable Form
fd)
            }

        Method
p
            | Method
p Method -> [Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Method
POST, Method
PUT, Method
PATCH ] -> Request
request
                { requestBody :: RequestBody
H.requestBody    = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Form -> ByteString
urlEncodeFormStable Form
fd
                , requestHeaders :: ResponseHeaders
H.requestHeaders = [ ( ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"content-type"
                                       , ByteString
"application/x-www-form-urlencoded"
                                       )
                                     ]
                }
        Method
_   -> Request
request
    WithMultipart [Part]
ps -> case Method
method of
        Method
POST -> [Part] -> Request -> m Request
forall (m :: * -> *). MonadIO m => [Part] -> Request -> m Request
formDataBody [Part]
ps Request
request
        Method
_    -> Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
request
    WithData
NoData           -> Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
request
  where
    request :: Request
request      = Request
H.defaultRequest
        { host :: ByteString
H.host          = ByteString
host
        , secure :: Bool
H.secure        = Bool
True
        , port :: Int
H.port          = Int
443
        , method :: ByteString
H.method        = Method -> ByteString
forall a. Show a => a -> ByteString
bshow Method
method
        , path :: ByteString
H.path          = [PathSegment] -> ByteString
forall (t :: * -> *). Foldable t => t PathSegment -> ByteString
joinPathSegments [PathSegment]
pathSegments
          -- add @raw_json@ param to get unescaped HTML in response bodies
        , queryString :: ByteString
H.queryString   = ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool ByteString
forall a. Monoid a => a
mempty ByteString
rawJSONQuery Bool
rawJSON
        , redirectCount :: Int
H.redirectCount = Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
10 Bool
followRedirects
        , checkResponse :: Request -> Response BodyReader -> IO ()
H.checkResponse = Request -> Response BodyReader -> IO ()
checkResponse
        }

    rawJSONQuery :: ByteString
rawJSONQuery =
        Bool -> Query -> ByteString
H.renderQuery Bool
True (Query -> ByteString) -> Query -> ByteString
forall a b. (a -> b) -> a -> b
$ [(PathSegment, PathSegment)] -> Query
forall a. QueryLike a => a -> Query
H.toQuery @[(Text, Text)] [ (PathSegment
"raw_json", PathSegment
"1") ]

setHeaders :: MonadReddit m => Request -> m Request
setHeaders :: Request -> m Request
setHeaders Request
req = do
    UserAgent
userAgent <- (Client -> UserAgent) -> m UserAgent
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Client -> Getting UserAgent Client UserAgent -> UserAgent
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "authConfig" 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 @"authConfig" ((AuthConfig -> Const UserAgent AuthConfig)
 -> Client -> Const UserAgent Client)
-> ((UserAgent -> Const UserAgent UserAgent)
    -> AuthConfig -> Const UserAgent AuthConfig)
-> Getting UserAgent Client UserAgent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. HasField "userAgent" 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 @"userAgent")
    PathSegment
token <- Lens' ClientState PathSegment -> m PathSegment
forall (m :: * -> *) a. MonadReddit m => Lens' ClientState a -> m a
readClientState (Lens' ClientState PathSegment -> m PathSegment)
-> Lens' ClientState PathSegment -> m PathSegment
forall a b. (a -> b) -> a -> b
$ forall s t a b. HasField "accessToken" 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 @"accessToken" ((AccessToken -> f AccessToken) -> ClientState -> f ClientState)
-> ((PathSegment -> f PathSegment) -> AccessToken -> f AccessToken)
-> (PathSegment -> f PathSegment)
-> ClientState
-> f ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. HasField "token" 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 @"token"

    let newHeaders :: ResponseHeaders
newHeaders = [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"authorization", ByteString
auth)
                     , (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"user-agent", UserAgent -> ByteString
writeUA UserAgent
userAgent)
                     ]
        auth :: ByteString
auth       = ByteString
"bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PathSegment -> ByteString
T.encodeUtf8 PathSegment
token
        headers :: ResponseHeaders
headers    = Request
req Request -> (Request -> ResponseHeaders) -> ResponseHeaders
forall a b. a -> (a -> b) -> b
& Request -> ResponseHeaders
H.requestHeaders
    Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req { requestHeaders :: ResponseHeaders
H.requestHeaders = ResponseHeaders
newHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers }

-- | Get the items that correspond to a container of 'Thing' instances, for example
-- a sequence of 'Network.Reddit.Types.Comment.CommentID's, which will evaluate to a
-- 'Seq' of 'Network.Reddit.Types.Comment.Comment's
getMany :: forall a b t m.
        (MonadReddit m, Foldable t, Thing b, FromJSON a, FromJSON b)
        => ItemOpts a
        -> t b
        -> m (Seq a)
getMany :: ItemOpts a -> t b -> m (Seq a)
getMany ItemOpts a
opts t b
ids = [Seq a] -> Seq a
forall a. Monoid a => [a] -> a
mconcat ([Seq a] -> Seq a) -> m [Seq a] -> m (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([b] -> m (Seq a)) -> [[b]] -> m [Seq a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [b] -> m (Seq a)
getChunk (t b -> [[b]]
forall e. t e -> [[e]]
chunked t b
ids)
  where
    chunked :: t e -> [[e]]
chunked = Int -> [e] -> [[e]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
forall n. Num n => n
apiRequestLimit ([e] -> [[e]]) -> (t e -> [e]) -> t e -> [[e]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t e -> [e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

    getChunk :: [b] -> m (Seq a)
getChunk [b]
chunk = APIAction (Listing b a) -> m (Listing b a)
forall a (m :: * -> *).
(MonadReddit m, FromJSON a) =>
APIAction a -> m a
runAction ([b] -> APIAction (Listing b a)
forall c. [b] -> APIAction c
mkAction @(Listing b a) [b]
chunk)
        m (Listing b a) -> (Listing b a -> Seq a) -> m (Seq a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Listing b a -> Getting (Seq a) (Listing b 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")

    mkAction :: forall c. [b] -> APIAction c
    mkAction :: [b] -> APIAction c
mkAction [b]
cs = (APIAction c
forall a. APIAction a
defaultAPIAction @c)
        { $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [ PathSegment
"api", PathSegment
"info" ]
        , $sel:requestData:APIAction :: WithData
requestData  = Form -> WithData
WithForm
              (Form -> WithData) -> Form -> WithData
forall a b. (a -> b) -> a -> b
$ ItemOpts a -> Form
forall a. ToForm a => a -> Form
toForm ItemOpts a
opts
              Form -> Form -> Form
forall a. Semigroup a => a -> a -> a
<> [(PathSegment, PathSegment)] -> Form
mkTextForm [ (PathSegment
"id", [b] -> PathSegment
forall a. Thing a => a -> PathSegment
fullname [b]
cs)
                            , (PathSegment
"limit", Int -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam @Int Int
forall n. Num n => n
apiRequestLimit)
                            ]
        }