{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Req.OAuth2.Internal.AccessToken
    ( AccessTokenRequest(..)
    , AccessTokenResponse(..)
    , fetchAccessToken
    ) where

import           Data.Aeson ((.:), withObject)
import           Data.Aeson.Types (Parser, Value, parseEither)
import           Data.Text (Text)
import           Network.HTTP.Req ((=:), useHttpsURI)
import           Network.HTTP.Req.OAuth2.Internal.AuthCode
import           Network.HTTP.Req.OAuth2.Internal.Types
import           Network.HTTP.Req.OAuth2.Internal.Util

data AccessTokenRequest = AccessTokenRequest AuthCode

data AccessTokenResponse = AccessTokenResponse TokenPair

-- | Gets OAuth2 access token
--
-- Implements standard OAuth2 access token workflow for web server apps
-- as described <https://aaronparecki.com/oauth-2-simplified/#web-server-apps here>.
--
-- We don't pass @client_secret@ because that would be silly. We also don't bother
-- with @redirect_uri@ since this do not seem to be required.
fetchAccessToken :: App -> AccessTokenRequest -> IO (Either String AccessTokenResponse)
fetchAccessToken :: App -> AccessTokenRequest -> IO (Either String AccessTokenResponse)
fetchAccessToken App
app (AccessTokenRequest (AuthCode Text
ac)) = do
    let clientPair :: ClientPair
clientPair = App -> ClientPair
appClientPair App
app
        ClientPair (ClientId Text
cid) ClientSecret
_ = ClientPair
clientPair
        Just (Url 'Https
url, Option Any
_) = URI -> Maybe (Url 'Https, Option Any)
forall (scheme :: Scheme). URI -> Maybe (Url 'Https, Option scheme)
useHttpsURI (URI -> Maybe (Url 'Https, Option Any))
-> URI -> Maybe (Url 'Https, Option Any)
forall a b. (a -> b) -> a -> b
$ App -> URI
appTokenUri App
app
    (Value -> Parser AccessTokenResponse)
-> Value -> Either String AccessTokenResponse
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser AccessTokenResponse
pResponse (Value -> Either String AccessTokenResponse)
-> IO Value -> IO (Either String AccessTokenResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Url 'Https -> Option 'Https -> FormUrlEncodedParam -> IO Value
oAuth2PostRaw
            Url 'Https
url
            (ClientPair -> Option 'Https
forall (scheme :: Scheme). ClientPair -> Option scheme
oAuth2AuthHeader ClientPair
clientPair)
            (Text
"code" Text -> Text -> FormUrlEncodedParam
forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: Text
ac FormUrlEncodedParam -> FormUrlEncodedParam -> FormUrlEncodedParam
forall a. Semigroup a => a -> a -> a
<> Text
"grant_type" Text -> Text -> FormUrlEncodedParam
forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: (Text
"authorization_code" :: Text) FormUrlEncodedParam -> FormUrlEncodedParam -> FormUrlEncodedParam
forall a. Semigroup a => a -> a -> a
<> Text
"client_id" Text -> Text -> FormUrlEncodedParam
forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: Text
cid FormUrlEncodedParam -> FormUrlEncodedParam -> FormUrlEncodedParam
forall a. Semigroup a => a -> a -> a
<> Text
"expires_in" Text -> Text -> FormUrlEncodedParam
forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: (Text
"3600" :: Text))

pResponse :: Value -> Parser AccessTokenResponse
pResponse :: Value -> Parser AccessTokenResponse
pResponse =
    String
-> (Object -> Parser AccessTokenResponse)
-> Value
-> Parser AccessTokenResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"AccessTokenResponse" ((Object -> Parser AccessTokenResponse)
 -> Value -> Parser AccessTokenResponse)
-> (Object -> Parser AccessTokenResponse)
-> Value
-> Parser AccessTokenResponse
forall a b. (a -> b) -> a -> b
$ \Object
v -> (TokenPair -> AccessTokenResponse
AccessTokenResponse (TokenPair -> AccessTokenResponse)
-> (RefreshToken -> TokenPair)
-> RefreshToken
-> AccessTokenResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((RefreshToken -> TokenPair)
 -> RefreshToken -> AccessTokenResponse)
-> (AccessToken -> RefreshToken -> TokenPair)
-> AccessToken
-> RefreshToken
-> AccessTokenResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessToken -> RefreshToken -> TokenPair
TokenPair
        (AccessToken -> RefreshToken -> AccessTokenResponse)
-> Parser AccessToken
-> Parser (RefreshToken -> AccessTokenResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> AccessToken
AccessToken (Text -> AccessToken) -> Parser Text -> Parser AccessToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"access_token")
        Parser (RefreshToken -> AccessTokenResponse)
-> Parser RefreshToken -> Parser AccessTokenResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> RefreshToken
RefreshToken (Text -> RefreshToken) -> Parser Text -> Parser RefreshToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"refresh_token")