Internal.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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_
    , updateToken
    , mkRequest
    , getMany
    , redditURL
    , oauthURL
    , getMe
    ) 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.Types.Account
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 action@APIAction { .. } = do
    ensureToken
    (resp, x) <- runActionWith followRedirects =<< prepareRequest action
    updateRateLimits resp
    pure x

-- | Run an action, discarding the response body
runAction_ :: forall m. MonadReddit m => APIAction () -> m ()
runAction_ action = do
    ensureToken
    updateRateLimits =<< runActionWith_ =<< prepareRequest action

ensureToken :: MonadReddit m => m ()
ensureToken = do
    expiresIn <- readClientState $ field @"accessToken" . field @"expiresIn"
    obtained <- readClientState $ field @"tokenObtained"
    now <- liftIO getPOSIXTime
    when (now > (obtained - 10) + expiresIn) $ updateToken now

updateToken :: MonadReddit m => POSIXTime -> m ()
updateToken now = do
    newToken <- refreshAccessToken
    state <- asks (^. field @"clientState")
    atomicModifyIORef' state $ \s ->
        ( s
          & (field @"tokenObtained" .~ now)
          . (field @"accessToken" .~ newToken)
        , ()
        )

-- | Update the current rate limit info, reading it from Reddit\'s response
-- headers
updateRateLimits :: MonadReddit m => Response (RawBody m) -> m ()
updateRateLimits resp = do
    now <- liftIO getPOSIXTime
    for_ (resp & H.responseHeaders & readRateLimits now) $ \rls -> do
        state <- asks (^. field @"clientState")
        atomicModifyIORef' state $ \s -> (s & field @"limits" ?~ rls, ())

runActionWith :: forall a m.
              (MonadReddit m, FromJSON a)
              => Bool
              -> Request
              -> m (Response (RawBody m), a)
runActionWith followRedirects req = withResponse @_ @m req $ \resp -> do
    let body       = resp & H.responseBody
        status     = resp & H.responseStatus
        statusCode = status & H.statusCode
        headers    = resp & H.responseHeaders
        cookies    = resp & H.responseCookieJar
    bodyBS <- runConduit $ body .| sinkLbs
    if
        | inRange (300, 308) statusCode && not followRedirects -> throwM
            . Redirected
            $ H.getRedirectedRequest req headers cookies statusCode
        | otherwise -> case eitherDecode @a bodyBS of
            Right x  -> pure (resp, x)
            Left err -> case decode @APIException bodyBS of
                Just e  -> throwM e
                Nothing -> throwM . flip JSONParseError bodyBS
                    $ "runAction: Error parsing JSON - " <> T.pack err

runActionWith_
    :: forall m. MonadReddit m => Request -> m (Response (RawBody m))
runActionWith_ req = withResponse @_ @m req $ \resp -> do
    let body       = resp & H.responseBody
        status     = resp & H.responseStatus
        statusCode = status & H.statusCode
    bodyBS <- runConduit $ body .| sinkLbs
    if
        | (statusCode >= 300) -> case decode @APIException bodyBS of
            Just e  -> throwM e
            Nothing -> throwM
                $ JSONParseError "runAction_: Failed to parse error JSON"
                                 bodyBS
        | otherwise -> pure resp

prepareRequest :: MonadReddit m => APIAction a -> m Request
prepareRequest act@APIAction { .. } =
    bool (mkRequest redditURL act)
         (setHeaders =<< mkRequest oauthURL act)
         needsAuth

mkRequest :: MonadIO m => ByteString -> APIAction a -> m Request
mkRequest host APIAction { .. } = case requestData of
    WithJSON d       -> pure $ case method of
        p
            | p `elem` [ POST, PUT, PATCH ] -> request
                { H.requestBody    = RequestBodyLBS $ encode d
                , H.requestHeaders =
                      [ (CI.mk "content-type", "application/json") ]
                }
            | otherwise -> request
    WithForm fd      -> pure $ case method of
        GET -> request
            { H.queryString = (request & H.queryString)
                  <> "&"
                  <> LB.toStrict (urlEncodeFormStable fd)
            }

        p
            | p `elem` [ POST, PUT, PATCH ] -> request
                { H.requestBody    = RequestBodyLBS $ urlEncodeFormStable fd
                , H.requestHeaders = [ ( CI.mk "content-type"
                                       , "application/x-www-form-urlencoded"
                                       )
                                     ]
                }
        _   -> request
    WithMultipart ps -> case method of
        POST -> formDataBody ps request
        _    -> pure request
    NoData           -> pure request
  where
    request      = H.defaultRequest
        { H.host          = host
        , H.secure        = True
        , H.port          = 443
        , H.method        = bshow method
        , H.path          = joinPathSegments pathSegments
          -- add @raw_json@ param to get unescaped HTML in response bodies
        , H.queryString   = bool mempty rawJSONQuery rawJSON
        , H.redirectCount = bool 0 10 followRedirects
        , H.checkResponse = checkResponse
        }

    rawJSONQuery =
        H.renderQuery True $ H.toQuery @[(Text, Text)] [ ("raw_json", "1") ]

setHeaders :: MonadReddit m => Request -> m Request
setHeaders req = do
    userAgent <- asks (^. field @"authConfig" . field @"userAgent")
    token <- readClientState $ field @"accessToken" . field @"token"

    let newHeaders = [ (CI.mk "authorization", auth)
                     , (CI.mk "user-agent", writeUA userAgent)
                     ]
        auth       = "bearer " <> T.encodeUtf8 token
        headers    = req & H.requestHeaders
    pure req { H.requestHeaders = newHeaders <> 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
        -> t b
        -> m (Seq a)
getMany opts ids = mconcat <$> traverse getChunk (chunked ids)
  where
    chunked = chunksOf apiRequestLimit . F.toList

    getChunk chunk = runAction (mkAction @(Listing b a) chunk)
        <&> (^. field @"children")

    mkAction :: forall c. [b] -> APIAction c
    mkAction cs = (defaultAPIAction @c)
        { pathSegments = [ "api", "info" ]
        , requestData  = WithForm
              $ toForm opts
              <> mkTextForm [ ("id", fullname cs)
                            , ("limit", toQueryParam @Int apiRequestLimit)
                            ]
        }

-- NOTE
-- This action needs to be in this module to avoid cyclic module dependencies
-- | Get account information for the currently logged-in user. If you are using
-- an 'ApplicationOnly' client, calling this will throw an 'InvalidRequest'
getMe :: MonadReddit m => m Account
getMe = asks (^. field @"authConfig" . field @"appType") >>= \case
    ApplicationOnly {} ->
        throwM $ InvalidRequest "getMe: This action requires a user context"
    _                  ->
        runAction defaultAPIAction { pathSegments = [ "api", "v1", "me" ] }