{-# LANGUAGE DataKinds #-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.Reddit.Auth
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- OAuth authentication for the Reddit API. At the moment, only 'ScriptApp's are
-- supported
module Network.Reddit.Auth
    ( loadAuthConfig
    , getAccessToken
    , getAccessTokenWith
    , getAuthURL
    , redditURL
    , oauthURL
    , refreshAccessToken
    ) where

import           Conduit
                 ( (.|)
                 , decodeUtf8LenientC
                 , runConduit
                 , sinkLazy
                 , withSourceFile
                 )

import           Control.Monad.Catch         ( MonadThrow(throwM) )
import           Control.Monad.Reader        ( asks )

import           Data.Aeson                  ( decode, eitherDecode )
import           Data.ByteString             ( ByteString )
import qualified Data.ByteString.Lazy        as LB
import qualified Data.CaseInsensitive        as CI
import           Data.Conduit.Binary         ( sinkLbs )
import           Data.Foldable               ( asum )
import           Data.Function               ( on )
import           Data.Generics.Product       ( HasField(field) )
import           Data.Ini.Config             ( IniParser )
import qualified Data.Ini.Config             as Ini
import qualified Data.Text                   as T
import           Data.Text                   ( Text )
import qualified Data.Text.Encoding          as T
import qualified Data.Text.Lazy              as LT

import           Lens.Micro

import           Network.HTTP.Client.Conduit ( Request
                                             , RequestBody(RequestBodyLBS)
                                             )
import qualified Network.HTTP.Client.Conduit as H
import           Network.HTTP.Simple         ( withResponse )
import           Network.Reddit.Types
import           Network.Reddit.Utils

import           UnliftIO                    ( MonadUnliftIO )
import           UnliftIO.Directory

import           Web.FormUrlEncoded          ( toForm, urlEncodeAsFormStable )
import           Web.HttpApiData             ( ToHttpApiData(toQueryParam) )
import           Web.Internal.FormUrlEncoded ( Form )

-- | Load the auth file, looking in the following locations, in order:
--
--      * $PWD\/auth.ini
--      * XDG_CONFIG_HOME\/heddit\/auth.ini
--
-- __Note__: Only 'ScriptApp's and 'ApplicationOnly' apps are supported
loadAuthConfig
    :: (MonadUnliftIO m, MonadThrow m) => ClientSite -> m AuthConfig
loadAuthConfig :: ClientSite -> m AuthConfig
loadAuthConfig ClientSite
cs = do
    FilePath
cwDir <- m FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCurrentDirectory
    FilePath
cfgDir <- XdgDirectory -> FilePath -> m FilePath
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> FilePath -> m FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
"heddit"
    [FilePath] -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
MonadIO m =>
[FilePath] -> FilePath -> m (Maybe FilePath)
findFile [ FilePath
cfgDir, FilePath
cwDir ] FilePath
"auth.ini" m (Maybe FilePath)
-> (Maybe FilePath -> m AuthConfig) -> m AuthConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe FilePath
Nothing -> ClientException -> m AuthConfig
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m AuthConfig)
-> (ClientSite -> ClientException) -> ClientSite -> m AuthConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientSite -> ClientException
OtherError
            (ClientSite -> m AuthConfig) -> ClientSite -> m AuthConfig
forall a b. (a -> b) -> a -> b
$ [ClientSite] -> ClientSite
forall a. Monoid a => [a] -> a
mconcat [ ClientSite
"No auth.ini file found in the current directory"
                      , ClientSite
" or $XDG_CONFIG_HOME/heddit, please create one"
                      ]
        Just FilePath
fp -> ClientSite -> FilePath -> m AuthConfig
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
ClientSite -> FilePath -> m AuthConfig
parseAuthIni ClientSite
cs FilePath
fp

parseAuthIni :: forall m.
             (MonadUnliftIO m, MonadThrow m)
             => ClientSite
             -> FilePath
             -> m AuthConfig
parseAuthIni :: ClientSite -> FilePath -> m AuthConfig
parseAuthIni ClientSite
cs FilePath
fp = FilePath
-> (ConduitM () ByteString m () -> m AuthConfig) -> m AuthConfig
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile @_ @m FilePath
fp ((ConduitM () ByteString m () -> m AuthConfig) -> m AuthConfig)
-> (ConduitM () ByteString m () -> m AuthConfig) -> m AuthConfig
forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString m ()
b ->
    (FilePath -> m AuthConfig)
-> (AuthConfig -> m AuthConfig)
-> Either FilePath AuthConfig
-> m AuthConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> m AuthConfig
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (IOError -> m AuthConfig)
-> (FilePath -> IOError) -> FilePath -> m AuthConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
userError) AuthConfig -> m AuthConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either FilePath AuthConfig -> m AuthConfig)
-> (Text -> Either FilePath AuthConfig) -> Text -> m AuthConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientSite -> IniParser AuthConfig -> Either FilePath AuthConfig)
-> IniParser AuthConfig -> ClientSite -> Either FilePath AuthConfig
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientSite -> IniParser AuthConfig -> Either FilePath AuthConfig
forall a. ClientSite -> IniParser a -> Either FilePath a
Ini.parseIniFile (ClientSite -> IniParser AuthConfig
authConfigP ClientSite
cs)
    (ClientSite -> Either FilePath AuthConfig)
-> (Text -> ClientSite) -> Text -> Either FilePath AuthConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ClientSite
LT.toStrict
    (Text -> m AuthConfig) -> m Text -> m AuthConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConduitT () Void m Text -> m Text
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString m ()
b ConduitM () ByteString m ()
-> ConduitM ByteString Void m Text -> ConduitT () Void m 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 ClientSite m ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ClientSite m ()
decodeUtf8LenientC ConduitT ByteString ClientSite m ()
-> ConduitM ClientSite Void m Text
-> ConduitM ByteString Void m Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ClientSite Void m Text
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy)

authConfigP :: Text -> IniParser AuthConfig
authConfigP :: ClientSite -> IniParser AuthConfig
authConfigP ClientSite
sec = [IniParser AuthConfig] -> IniParser AuthConfig
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ IniParser AuthConfig
scriptP, IniParser AuthConfig
appOnlyP ]
  where
    appOnlyP :: IniParser AuthConfig
appOnlyP = ClientSite -> SectionParser AuthConfig -> IniParser AuthConfig
forall a. ClientSite -> SectionParser a -> IniParser a
Ini.section ClientSite
sec
        (SectionParser AuthConfig -> IniParser AuthConfig)
-> SectionParser AuthConfig -> IniParser AuthConfig
forall a b. (a -> b) -> a -> b
$ ClientSite -> AppType -> UserAgent -> AuthConfig
AuthConfig (ClientSite -> AppType -> UserAgent -> AuthConfig)
-> SectionParser ClientSite
-> SectionParser (AppType -> UserAgent -> AuthConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"id"
        SectionParser (AppType -> UserAgent -> AuthConfig)
-> SectionParser AppType -> SectionParser (UserAgent -> AuthConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClientSite -> AppType
ApplicationOnly (ClientSite -> AppType)
-> SectionParser ClientSite -> SectionParser AppType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"secret")
        SectionParser (UserAgent -> AuthConfig)
-> SectionParser UserAgent -> SectionParser AuthConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientSite
-> (ClientSite -> Either FilePath UserAgent)
-> SectionParser UserAgent
forall a.
ClientSite -> (ClientSite -> Either FilePath a) -> SectionParser a
Ini.fieldOf ClientSite
"agent" ClientSite -> Either FilePath UserAgent
uaP

    scriptP :: IniParser AuthConfig
scriptP  = ClientSite -> SectionParser AuthConfig -> IniParser AuthConfig
forall a. ClientSite -> SectionParser a -> IniParser a
Ini.section ClientSite
sec
        (SectionParser AuthConfig -> IniParser AuthConfig)
-> SectionParser AuthConfig -> IniParser AuthConfig
forall a b. (a -> b) -> a -> b
$ ClientSite -> AppType -> UserAgent -> AuthConfig
AuthConfig (ClientSite -> AppType -> UserAgent -> AuthConfig)
-> SectionParser ClientSite
-> SectionParser (AppType -> UserAgent -> AuthConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"id"
        SectionParser (AppType -> UserAgent -> AuthConfig)
-> SectionParser AppType -> SectionParser (UserAgent -> AuthConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClientSite -> PasswordFlow -> AppType
ScriptApp (ClientSite -> PasswordFlow -> AppType)
-> SectionParser ClientSite
-> SectionParser (PasswordFlow -> AppType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"secret"
             SectionParser (PasswordFlow -> AppType)
-> SectionParser PasswordFlow -> SectionParser AppType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClientSite -> ClientSite -> PasswordFlow
PasswordFlow (ClientSite -> ClientSite -> PasswordFlow)
-> SectionParser ClientSite
-> SectionParser (ClientSite -> PasswordFlow)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"username"
                  SectionParser (ClientSite -> PasswordFlow)
-> SectionParser ClientSite -> SectionParser PasswordFlow
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientSite -> SectionParser ClientSite
Ini.field ClientSite
"password"))
        SectionParser (UserAgent -> AuthConfig)
-> SectionParser UserAgent -> SectionParser AuthConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientSite
-> (ClientSite -> Either FilePath UserAgent)
-> SectionParser UserAgent
forall a.
ClientSite -> (ClientSite -> Either FilePath a) -> SectionParser a
Ini.fieldOf ClientSite
"agent" ClientSite -> Either FilePath UserAgent
uaP

uaP :: Text -> Either [Char] UserAgent
uaP :: ClientSite -> Either FilePath UserAgent
uaP ClientSite
t = case ClientSite -> ClientSite -> [ClientSite]
T.splitOn ClientSite
"," ClientSite
t of
    [ ClientSite
platform, ClientSite
appID, ClientSite
version, ClientSite
author ] -> UserAgent -> Either FilePath UserAgent
forall a b. b -> Either a b
Right UserAgent :: ClientSite -> ClientSite -> ClientSite -> ClientSite -> UserAgent
UserAgent { ClientSite
$sel:author:UserAgent :: ClientSite
$sel:version:UserAgent :: ClientSite
$sel:appID:UserAgent :: ClientSite
$sel:platform:UserAgent :: ClientSite
author :: ClientSite
version :: ClientSite
appID :: ClientSite
platform :: ClientSite
.. }
    [ClientSite]
_ -> FilePath -> Either FilePath UserAgent
forall a b. a -> Either a b
Left
        (FilePath -> Either FilePath UserAgent)
-> FilePath -> Either FilePath UserAgent
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat [ FilePath
"User agent must be of the form"
                  , FilePath
" '<platform>,<appID>,<version>,<author>'"
                  ]

-- | Get the URL required to authorize your application, for 'WebApp's and
-- 'InstalledApp's
getAuthURL
    :: Foldable t
    => URL
    -- ^ A redirect URI, which must exactly match the one
    -- registered with Reddit when creating your application
    -> TokenDuration
    -> t Scope
    -- ^ The OAuth scopes to request authorization for
    -> ClientID
    -> Text
    -- ^ Text that is embedded in the callback URI when the
    -- client completes the request. It must be composed
    -- of printable ASCII characters and should be unique
    -- for the client
    -> URL
getAuthURL :: ClientSite
-> TokenDuration
-> t Scope
-> ClientSite
-> ClientSite
-> ClientSite
getAuthURL ClientSite
redirectURI TokenDuration
duration t Scope
scopes ClientSite
clientID ClientSite
state =
    ByteString -> ClientSite
T.decodeUtf8 (ByteString -> ClientSite) -> ByteString -> ClientSite
forall a b. (a -> b) -> a -> b
$ ByteString
"https://" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
pieces
  where
    pieces :: [ByteString]
pieces  = [ Request -> ByteString
H.host, Request -> ByteString
H.path, Request -> ByteString
H.queryString ] [Request -> ByteString] -> [Request] -> [ByteString]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ Request
request ]

    query :: ByteString
query   = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (Form -> ByteString) -> Form -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form -> ByteString
forall a. ToForm a => a -> ByteString
urlEncodeAsFormStable
        (Form -> ByteString) -> Form -> ByteString
forall a b. (a -> b) -> a -> b
$ [(ClientSite, ClientSite)] -> Form
mkTextForm [ (ClientSite
"client_id", ClientSite
clientID)
                     , (ClientSite
"duration", TokenDuration -> ClientSite
forall a. ToHttpApiData a => a -> ClientSite
toQueryParam TokenDuration
duration)
                     , (ClientSite
"redirect_uri", ClientSite
redirectURI)
                     , (ClientSite
"response_type", ClientSite
"code")
                     , (ClientSite
"state", ClientSite
state)
                     , (ClientSite
"scope", t Scope -> ClientSite
forall (t :: * -> *) a.
(Foldable t, ToHttpApiData a) =>
t a -> ClientSite
joinParams t Scope
scopes)
                     ]

    request :: Request
request = Request
H.defaultRequest
        { host :: ByteString
H.host        = ByteString
redditURL
        , path :: ByteString
H.path        = [ClientSite] -> ByteString
forall (t :: * -> *). Foldable t => t ClientSite -> ByteString
joinPathSegments [ ClientSite
"api", ClientSite
"v1", ClientSite
"authorize" ]
        , queryString :: ByteString
H.queryString = ByteString
"?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
query
        }

-- | Generate an 'AccessToken' from an 'AuthConfig'. This serves to create an
-- initial token for all 'AppType's, and can also be used to refresh tokens for
-- 'ScriptApp's and 'ApplicationOnly' apps
getAccessToken :: (MonadUnliftIO m, MonadThrow m)
               => (AppType -> Form)
               -> AuthConfig
               -> m AccessToken
getAccessToken :: (AppType -> Form) -> AuthConfig -> m AccessToken
getAccessToken AppType -> Form
f ac :: AuthConfig
ac@AuthConfig { ClientSite
AppType
UserAgent
$sel:userAgent:AuthConfig :: AuthConfig -> UserAgent
$sel:appType:AuthConfig :: AuthConfig -> AppType
$sel:clientID:AuthConfig :: AuthConfig -> ClientSite
userAgent :: UserAgent
appType :: AppType
clientID :: ClientSite
.. } =
    Request -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
Request -> m AccessToken
makeTokenRequest (Request -> m AccessToken)
-> (Request -> Request) -> Request -> m AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthConfig -> Request -> Request
setUAHeader AuthConfig
ac (Request -> m AccessToken) -> m Request -> m AccessToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AppType -> m Request
request AppType
appType
  where
    request :: AppType -> m Request
request   = \case
        sa :: AppType
sa@(ScriptApp ClientSite
clientSecret PasswordFlow
_)     ->
            ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
clientID ClientSite
clientSecret (Request -> Request) -> m Request -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppType -> m Request
mkReq AppType
sa
        ro :: AppType
ro@(ApplicationOnly ClientSite
clientSecret) ->
            ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
clientID ClientSite
clientSecret (Request -> Request) -> m Request -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppType -> m Request
mkReq AppType
ro
        wa :: AppType
wa@(WebApp ClientSite
clientSecret CodeFlow
_)        ->
            ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
clientID ClientSite
clientSecret (Request -> Request) -> m Request -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppType -> m Request
mkReq AppType
wa
        ia :: AppType
ia@InstalledApp {}                ->
            ByteString -> ByteString -> Request -> Request
H.applyBasicAuth (ClientSite -> ByteString
T.encodeUtf8 ClientSite
clientID) ByteString
forall a. Monoid a => a
mempty (Request -> Request) -> m Request -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppType -> m Request
mkReq AppType
ia

    applyAuth :: ClientSite -> ClientSite -> Request -> Request
applyAuth = ByteString -> ByteString -> Request -> Request
H.applyBasicAuth (ByteString -> ByteString -> Request -> Request)
-> (ClientSite -> ByteString)
-> ClientSite
-> ClientSite
-> Request
-> Request
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClientSite -> ByteString
T.encodeUtf8

    mkReq :: AppType -> m Request
mkReq     = APIAction Any -> m Request
forall (m :: * -> *) a. MonadThrow m => APIAction a -> m Request
routeToRequest (APIAction Any -> m Request)
-> (AppType -> APIAction Any) -> AppType -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form -> APIAction Any
forall a. Form -> APIAction a
mkAuthRoute (Form -> APIAction Any)
-> (AppType -> Form) -> AppType -> APIAction Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppType -> Form
f

getAccessTokenWith
    :: (MonadUnliftIO m, MonadThrow m) => Token -> AuthConfig -> m AccessToken
getAccessTokenWith :: ClientSite -> AuthConfig -> m AccessToken
getAccessTokenWith ClientSite
rt AuthConfig { ClientSite
AppType
UserAgent
userAgent :: UserAgent
appType :: AppType
clientID :: ClientSite
$sel:userAgent:AuthConfig :: AuthConfig -> UserAgent
$sel:appType:AuthConfig :: AuthConfig -> AppType
$sel:clientID:AuthConfig :: AuthConfig -> ClientSite
.. } = case AppType
appType of
    ScriptApp {}          -> m AccessToken
forall a. m a
cfgError
    ApplicationOnly {}    -> m AccessToken
forall a. m a
cfgError
    WebApp ClientSite
clientSecret CodeFlow
_ ->
        Request -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
Request -> m AccessToken
makeTokenRequest (Request -> m AccessToken)
-> (Request -> Request) -> Request -> m AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
clientID ClientSite
clientSecret (Request -> m AccessToken) -> m Request -> m AccessToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Request
mkReq
    InstalledApp {}       ->
        Request -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
Request -> m AccessToken
makeTokenRequest (Request -> m AccessToken)
-> (Request -> Request) -> Request -> m AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
clientID ClientSite
forall a. Monoid a => a
mempty (Request -> m AccessToken) -> m Request -> m AccessToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Request
mkReq
  where
    mkReq :: m Request
mkReq                = APIAction Any -> m Request
forall (m :: * -> *) a. MonadThrow m => APIAction a -> m Request
routeToRequest (APIAction Any -> m Request)
-> (Form -> APIAction Any) -> Form -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form -> APIAction Any
forall a. Form -> APIAction a
mkAuthRoute
        (Form -> m Request) -> Form -> m Request
forall a b. (a -> b) -> a -> b
$ [(ClientSite, ClientSite)] -> Form
mkTextForm [ (ClientSite
"grant_type", ClientSite
"refresh_token")
                     , (ClientSite
"refresh_token", ClientSite
rt)
                     ]

    applyAuth :: ClientSite -> ClientSite -> Request -> Request
applyAuth ClientSite
cid ClientSite
secret = (ByteString -> ByteString -> Request -> Request
H.applyBasicAuth (ByteString -> ByteString -> Request -> Request)
-> (ClientSite -> ByteString)
-> ClientSite
-> ClientSite
-> Request
-> Request
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClientSite -> ByteString
T.encodeUtf8) ClientSite
cid ClientSite
secret

    cfgError :: m a
cfgError             = ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        (ClientException -> m a) -> ClientException -> m a
forall a b. (a -> b) -> a -> b
$ ClientSite -> ClientException
ConfigurationError ClientSite
"getAccessTokenWith: unsupported application type"

makeTokenRequest
    :: forall m. (MonadUnliftIO m, MonadThrow m) => Request -> m AccessToken
makeTokenRequest :: Request -> m AccessToken
makeTokenRequest Request
req = Request
-> (Response (ConduitM () ByteString m ()) -> m AccessToken)
-> m AccessToken
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse @_ @m Request
req ((Response (ConduitM () ByteString m ()) -> m AccessToken)
 -> m AccessToken)
-> (Response (ConduitM () ByteString m ()) -> m AccessToken)
-> m AccessToken
forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString m ())
resp -> do
    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
$ (Response (ConduitM () ByteString m ())
resp Response (ConduitM () ByteString m ())
-> (Response (ConduitM () ByteString m ())
    -> ConduitM () ByteString m ())
-> ConduitM () ByteString m ()
forall a b. a -> (a -> b) -> b
& Response (ConduitM () ByteString m ())
-> ConduitM () ByteString m ()
forall body. Response body -> body
H.responseBody) ConduitM () ByteString 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
    case ByteString -> Either FilePath AccessToken
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
bodyBS of
        Right AccessToken
token -> AccessToken -> m AccessToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure AccessToken
token
        Left FilePath
err    -> case ByteString -> Maybe APIException
forall a. FromJSON a => ByteString -> Maybe a
decode @APIException ByteString
bodyBS of
            Just APIException
e  -> APIException -> m AccessToken
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e
            Maybe APIException
Nothing -> APIException -> m AccessToken
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (APIException -> m AccessToken)
-> (ClientSite -> APIException) -> ClientSite -> m AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientSite -> ByteString -> APIException)
-> ByteString -> ClientSite -> APIException
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientSite -> ByteString -> APIException
JSONParseError ByteString
bodyBS
                (ClientSite -> m AccessToken) -> ClientSite -> m AccessToken
forall a b. (a -> b) -> a -> b
$ ClientSite
"getAccessToken: Failed to parse JSON - " ClientSite -> ClientSite -> ClientSite
forall a. Semigroup a => a -> a -> a
<> FilePath -> ClientSite
T.pack FilePath
err

-- | Generate the correct API 'APIAction' for an 'AppType'
mkAuthRoute :: Form -> APIAction a
mkAuthRoute :: Form -> APIAction a
mkAuthRoute Form
form = APIAction Any
forall a. APIAction a
defaultAPIAction
    { $sel:method:APIAction :: Method
method       = Method
POST
    , $sel:pathSegments:APIAction :: [ClientSite]
pathSegments = [ ClientSite
"api", ClientSite
"v1", ClientSite
"access_token" ]
    , $sel:requestData:APIAction :: WithData
requestData  = Form -> WithData
WithForm Form
form
    }

-- | Convert an API 'APIAction' to a 'Request'
routeToRequest :: MonadThrow m => APIAction a -> m Request
routeToRequest :: APIAction a -> m Request
routeToRequest APIAction { Bool
[ClientSite]
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
checkResponse :: Request -> Response BodyReader -> IO ()
rawJSON :: Bool
followRedirects :: Bool
needsAuth :: Bool
requestData :: WithData
pathSegments :: [ClientSite]
method :: Method
$sel:requestData:APIAction :: forall a. APIAction a -> WithData
$sel:pathSegments:APIAction :: forall a. APIAction a -> [ClientSite]
$sel:method:APIAction :: forall a. APIAction a -> Method
.. } = case WithData
requestData of
    WithForm Form
fd -> 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 ] -> 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
$ Request
mkRequest
                { requestBody :: RequestBody
H.requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Form -> ByteString
forall a. ToForm a => a -> ByteString
urlEncodeAsFormStable Form
fd }
        Method
_ -> m Request
forall a. m a
invalidRequest
    WithData
NoData      -> Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
mkRequest
    WithData
_           -> m Request
forall a. m a
invalidRequest
  where
    mkRequest :: Request
mkRequest      = Request
H.defaultRequest
        { host :: ByteString
H.host   = ByteString
"www.reddit.com"
        , 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   = [ClientSite] -> ByteString
forall (t :: * -> *). Foldable t => t ClientSite -> ByteString
joinPathSegments [ClientSite]
pathSegments
        }

    invalidRequest :: m a
invalidRequest = ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m a) -> ClientException -> m a
forall a b. (a -> b) -> a -> b
$ ClientSite -> ClientException
InvalidRequest ClientSite
"Invalid request body"

setUAHeader :: AuthConfig -> Request -> Request
setUAHeader :: AuthConfig -> Request -> Request
setUAHeader AuthConfig { ClientSite
AppType
UserAgent
userAgent :: UserAgent
appType :: AppType
clientID :: ClientSite
$sel:userAgent:AuthConfig :: AuthConfig -> UserAgent
$sel:appType:AuthConfig :: AuthConfig -> AppType
$sel:clientID:AuthConfig :: AuthConfig -> ClientSite
.. } Request
req =
    Request
req { requestHeaders :: RequestHeaders
H.requestHeaders = (CI ByteString, ByteString)
newHeader (CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
headers }
  where
    newHeader :: (CI ByteString, ByteString)
newHeader = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"user-agent", ByteString
ua)

    ua :: ByteString
ua        = UserAgent -> ByteString
writeUA UserAgent
userAgent

    headers :: RequestHeaders
headers   = Request
req Request -> (Request -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
& Request -> RequestHeaders
H.requestHeaders

-- | Refresh the access token
refreshAccessToken :: MonadReddit m => m AccessToken
refreshAccessToken :: m AccessToken
refreshAccessToken = do
    ac :: AuthConfig
ac@AuthConfig { ClientSite
AppType
UserAgent
userAgent :: UserAgent
appType :: AppType
clientID :: ClientSite
$sel:userAgent:AuthConfig :: AuthConfig -> UserAgent
$sel:appType:AuthConfig :: AuthConfig -> AppType
$sel:clientID:AuthConfig :: AuthConfig -> ClientSite
.. } <- (Client -> AuthConfig) -> m AuthConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Client -> Getting AuthConfig Client AuthConfig -> AuthConfig
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")
    case AppType
appType of
        ScriptApp {}       -> (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
        ApplicationOnly {} -> (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
        WebApp {}          -> AuthConfig -> m AccessToken
forall s.
(MonadReader s m,
 HasField
   "tokenManager" s s (Maybe TokenManager) (Maybe TokenManager)) =>
AuthConfig -> m AccessToken
tryRefresh AuthConfig
ac
        InstalledApp {}    -> AuthConfig -> m AccessToken
forall s.
(MonadReader s m,
 HasField
   "tokenManager" s s (Maybe TokenManager) (Maybe TokenManager)) =>
AuthConfig -> m AccessToken
tryRefresh AuthConfig
ac
  where
    tryRefresh :: AuthConfig -> m AccessToken
tryRefresh AuthConfig
ac = (s -> Maybe TokenManager) -> m (Maybe TokenManager)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (s
-> Getting (Maybe TokenManager) s (Maybe TokenManager)
-> Maybe TokenManager
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "tokenManager" 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 @"tokenManager") m (Maybe TokenManager)
-> (Maybe TokenManager -> m AccessToken) -> m AccessToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TokenManager { forall (m :: * -> *). (MonadIO m, MonadThrow m) => m ClientSite
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe ClientSite -> m ()
$sel:putToken:TokenManager :: TokenManager
-> forall (m :: * -> *).
   (MonadIO m, MonadThrow m) =>
   Maybe ClientSite -> m ()
$sel:loadToken:TokenManager :: TokenManager
-> forall (m :: * -> *). (MonadIO m, MonadThrow m) => m ClientSite
putToken :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe ClientSite -> m ()
loadToken :: forall (m :: * -> *). (MonadIO m, MonadThrow m) => m ClientSite
.. } -> do
            AccessToken
token <- (ClientSite -> AuthConfig -> m AccessToken)
-> AuthConfig -> ClientSite -> m AccessToken
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientSite -> AuthConfig -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
ClientSite -> AuthConfig -> m AccessToken
getAccessTokenWith AuthConfig
ac (ClientSite -> m AccessToken) -> m ClientSite -> m AccessToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ClientSite
forall (m :: * -> *). (MonadIO m, MonadThrow m) => m ClientSite
loadToken
            Maybe ClientSite -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Maybe ClientSite -> m ()
putToken (Maybe ClientSite -> m ()) -> Maybe ClientSite -> m ()
forall a b. (a -> b) -> a -> b
$ AccessToken
token AccessToken
-> Getting (Maybe ClientSite) AccessToken (Maybe ClientSite)
-> Maybe ClientSite
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 -> m AccessToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure AccessToken
token
        Maybe TokenManager
Nothing                  -> m (Maybe ClientSite)
lookupRefreshToken m (Maybe ClientSite)
-> (Maybe ClientSite -> m AccessToken) -> m AccessToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ClientSite
Nothing ->
                ClientSite -> m AccessToken
forall a. ClientSite -> m a
cfgError ClientSite
"refreshAccessToken: No refresh token available"
            Just ClientSite
rt -> ClientSite -> AuthConfig -> m AccessToken
forall (m :: * -> *).
(MonadUnliftIO m, MonadThrow m) =>
ClientSite -> AuthConfig -> m AccessToken
getAccessTokenWith ClientSite
rt AuthConfig
ac

    lookupRefreshToken :: m (Maybe ClientSite)
lookupRefreshToken =
        Lens' ClientState (Maybe ClientSite) -> m (Maybe ClientSite)
forall (m :: * -> *) a. MonadReddit m => Lens' ClientState a -> m a
readClientState (Lens' ClientState (Maybe ClientSite) -> m (Maybe ClientSite))
-> Lens' ClientState (Maybe ClientSite) -> m (Maybe ClientSite)
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)
-> ((Maybe ClientSite -> f (Maybe ClientSite))
    -> AccessToken -> f AccessToken)
-> (Maybe ClientSite -> f (Maybe ClientSite))
-> ClientState
-> f ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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"

    cfgError :: ClientSite -> m a
cfgError           = ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m a)
-> (ClientSite -> ClientException) -> ClientSite -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientSite -> ClientException
ConfigurationError

-- | The endpoint for non-OAuth actions
redditURL :: ByteString
redditURL :: ByteString
redditURL = ByteString
"www.reddit.com"

-- | The endpoint for OAuth actions
oauthURL :: ByteString
oauthURL :: ByteString
oauthURL = ByteString
"oauth.reddit.com"