{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.OAuth.OAuth2.TokenRequest where

import Control.Monad.Trans.Except
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text.Encoding as T
import GHC.Generics
import Network.HTTP.Conduit
import qualified Network.HTTP.Types as HT
import Network.HTTP.Types.URI (parseQuery)
import Network.OAuth.OAuth2.Internal
import URI.ByteString

--------------------------------------------------

-- * Token Request Errors

--------------------------------------------------

instance FromJSON Errors where
  parseJSON :: Value -> Parser Errors
parseJSON = Options -> Value -> Parser Errors
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions {constructorTagModifier :: String -> String
constructorTagModifier = Char -> String -> String
camelTo2 Char
'_', allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True}

instance ToJSON Errors where
  toEncoding :: Errors -> Encoding
toEncoding = Options -> Errors -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions {constructorTagModifier :: String -> String
constructorTagModifier = Char -> String -> String
camelTo2 Char
'_', allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True}

-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2
data Errors
  = InvalidRequest
  | InvalidClient
  | InvalidGrant
  | UnauthorizedClient
  | UnsupportedGrantType
  | InvalidScope
  deriving (Int -> Errors -> String -> String
[Errors] -> String -> String
Errors -> String
(Int -> Errors -> String -> String)
-> (Errors -> String)
-> ([Errors] -> String -> String)
-> Show Errors
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Errors] -> String -> String
$cshowList :: [Errors] -> String -> String
show :: Errors -> String
$cshow :: Errors -> String
showsPrec :: Int -> Errors -> String -> String
$cshowsPrec :: Int -> Errors -> String -> String
Show, Errors -> Errors -> Bool
(Errors -> Errors -> Bool)
-> (Errors -> Errors -> Bool) -> Eq Errors
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Errors -> Errors -> Bool
$c/= :: Errors -> Errors -> Bool
== :: Errors -> Errors -> Bool
$c== :: Errors -> Errors -> Bool
Eq, (forall x. Errors -> Rep Errors x)
-> (forall x. Rep Errors x -> Errors) -> Generic Errors
forall x. Rep Errors x -> Errors
forall x. Errors -> Rep Errors x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Errors x -> Errors
$cfrom :: forall x. Errors -> Rep Errors x
Generic)

--------------------------------------------------

-- * URL

--------------------------------------------------

-- | Prepare the URL and the request body query for fetching an access token.
accessTokenUrl ::
  OAuth2 ->
  -- | access code gained via authorization URL
  ExchangeToken ->
  -- | access token request URL plus the request body.
  (URI, PostBody)
accessTokenUrl :: OAuth2 -> ExchangeToken -> (URI, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code =
  let uri :: URI
uri = OAuth2 -> URI
oauth2TokenEndpoint OAuth2
oa
      body :: PostBody
body =
        [ (ByteString
"code", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ExchangeToken -> Text
extoken ExchangeToken
code),
          (ByteString
"redirect_uri", URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URI -> ByteString) -> URI -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> URI
oauth2RedirectUri OAuth2
oa),
          (ByteString
"grant_type", ByteString
"authorization_code")
        ]
   in (URI
uri, PostBody
body)

-- | Using a Refresh Token.  Obtain a new access token by
-- sending a refresh token to the Authorization server.
refreshAccessTokenUrl ::
  OAuth2 ->
  -- | refresh token gained via authorization URL
  RefreshToken ->
  -- | refresh token request URL plus the request body.
  (URI, PostBody)
refreshAccessTokenUrl :: OAuth2 -> RefreshToken -> (URI, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token = (URI
uri, PostBody
body)
  where
    uri :: URI
uri = OAuth2 -> URI
oauth2TokenEndpoint OAuth2
oa
    body :: PostBody
body =
      [ (ByteString
"grant_type", ByteString
"refresh_token"),
        (ByteString
"refresh_token", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RefreshToken -> Text
rtoken RefreshToken
token)
      ]

clientSecretPost :: OAuth2 -> PostBody
clientSecretPost :: OAuth2 -> PostBody
clientSecretPost OAuth2
oa =
  [ (ByteString
"client_id", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientId OAuth2
oa),
    (ByteString
"client_secret", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientSecret OAuth2
oa)
  ]

--------------------------------------------------

-- * Token management

--------------------------------------------------

-- | Fetch OAuth2 Token with authenticate in request header.
--
-- OAuth2 spec allows `client_id` and `client_secret` to
-- either be sent in the header (as basic authentication)
-- OR as form/url params.
-- The OAuth server can choose to implement only one, or both.
-- Unfortunately, there is no way for the OAuth client (i.e. this library) to
-- know which method to use.
-- Please take a look at the documentation of the
-- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`
fetchAccessToken ::
  -- | HTTP connection manager
  Manager ->
  -- | OAuth Data
  OAuth2 ->
  -- | OAuth2 Code
  ExchangeToken ->
  -- | Access Token
  ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken :: Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessTokenInternal ClientAuthenticationMethod
ClientSecretBasic

fetchAccessToken2 ::
  -- | HTTP connection manager
  Manager ->
  -- | OAuth Data
  OAuth2 ->
  -- | OAuth 2 Tokens
  ExchangeToken ->
  -- | Access Token
  ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken2 :: Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken2 = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessTokenInternal ClientAuthenticationMethod
ClientSecretPost
{-# DEPRECATED fetchAccessToken2 "renamed to fetchAccessTokenInternal" #-}

fetchAccessTokenInternal ::
  ClientAuthenticationMethod ->
  -- | HTTP connection manager
  Manager ->
  -- | OAuth Data
  OAuth2 ->
  -- | OAuth 2 Tokens
  ExchangeToken ->
  -- | Access Token
  ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessTokenInternal :: ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessTokenInternal ClientAuthenticationMethod
authMethod Manager
manager OAuth2
oa ExchangeToken
code = do
  let (URI
uri, PostBody
body) = OAuth2 -> ExchangeToken -> (URI, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code
  let extraBody :: PostBody
extraBody = if ClientAuthenticationMethod
authMethod ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretPost then OAuth2 -> PostBody
clientSecretPost OAuth2
oa else []
  Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO a
doJSONPostRequest Manager
manager OAuth2
oa URI
uri (PostBody
body PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
extraBody)

-- doJSONPostRequest append client secret to header which is needed for both
-- client_secret_post and client_secret_basic

-- | Fetch a new AccessToken with the Refresh Token with authentication in request header.
--
-- OAuth2 spec allows `client_id` and `client_secret` to
-- either be sent in the header (as basic authentication)
-- OR as form/url params.
-- The OAuth server can choose to implement only one, or both.
-- Unfortunately, there is no way for the OAuth client (i.e. this library) to
-- know which method to use. Please take a look at the documentation of the
-- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`
refreshAccessToken ::
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth context
  OAuth2 ->
  -- | refresh token gained after authorization
  RefreshToken ->
  ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken :: Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessTokenInternal ClientAuthenticationMethod
ClientSecretBasic

refreshAccessToken2 ::
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth context
  OAuth2 ->
  -- | refresh token gained after authorization
  RefreshToken ->
  ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken2 :: Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken2 = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessTokenInternal ClientAuthenticationMethod
ClientSecretPost
{-# DEPRECATED refreshAccessToken2 "renamed to fetchAccessTokenInternal" #-}

refreshAccessTokenInternal ::
  ClientAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth context
  OAuth2 ->
  -- | refresh token gained after authorization
  RefreshToken ->
  ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessTokenInternal :: ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessTokenInternal ClientAuthenticationMethod
authMethod Manager
manager OAuth2
oa RefreshToken
token = do
  let (URI
uri, PostBody
body) = OAuth2 -> RefreshToken -> (URI, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token
  let extraBody :: PostBody
extraBody = if ClientAuthenticationMethod
authMethod ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretPost then OAuth2 -> PostBody
clientSecretPost OAuth2
oa else []
  Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO a
doJSONPostRequest Manager
manager OAuth2
oa URI
uri (PostBody
body PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
extraBody)

--------------------------------------------------

-- * Utilies

--------------------------------------------------

-- | Conduct post request and return response as JSON.
doJSONPostRequest ::
  (FromJSON err, FromJSON a) =>
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth options
  OAuth2 ->
  -- | The URL
  URI ->
  -- | request body
  PostBody ->
  -- | Response as JSON
  ExceptT (OAuth2Error err) IO a
doJSONPostRequest :: Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO a
doJSONPostRequest Manager
manager OAuth2
oa URI
uri PostBody
body = do
  ByteString
resp <- Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
forall err.
FromJSON err =>
Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
doSimplePostRequest Manager
manager OAuth2
oa URI
uri PostBody
body
  case ByteString -> Either (OAuth2Error err) a
forall err a.
(FromJSON err, FromJSON a) =>
ByteString -> Either (OAuth2Error err) a
parseResponseFlexible ByteString
resp of
    Right a
obj -> a -> ExceptT (OAuth2Error err) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
obj
    Left OAuth2Error err
e -> OAuth2Error err -> ExceptT (OAuth2Error err) IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Error err
e

-- | Conduct post request.
doSimplePostRequest ::
  FromJSON err =>
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth options
  OAuth2 ->
  -- | URL
  URI ->
  -- | Request body.
  PostBody ->
  -- | Response as ByteString
  ExceptT (OAuth2Error err) IO BSL.ByteString
doSimplePostRequest :: Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
doSimplePostRequest Manager
manager OAuth2
oa URI
url PostBody
body =
  IO (Either (OAuth2Error err) ByteString)
-> ExceptT (OAuth2Error err) IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (OAuth2Error err) ByteString)
 -> ExceptT (OAuth2Error err) IO ByteString)
-> IO (Either (OAuth2Error err) ByteString)
-> ExceptT (OAuth2Error err) IO ByteString
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Either (OAuth2Error err) ByteString)
-> IO (Response ByteString)
-> IO (Either (OAuth2Error err) ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> Either (OAuth2Error err) ByteString
forall err.
FromJSON err =>
Response ByteString -> Either (OAuth2Error err) ByteString
handleOAuth2TokenResponse IO (Response ByteString)
go
  where
    addBasicAuth :: Request -> Request
addBasicAuth = ByteString -> ByteString -> Request -> Request
applyBasicAuth (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientId OAuth2
oa) (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientSecret OAuth2
oa)
    go :: IO (Response ByteString)
go = do
      Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
      let req' :: Request
req' = (Request -> Request
addBasicAuth (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
addDefaultRequestHeaders) Request
req
      Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs (PostBody -> Request -> Request
urlEncodedBody PostBody
body Request
req') Manager
manager

-- | Parses a @Response@ to to @OAuth2Result@
handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString
handleOAuth2TokenResponse :: Response ByteString -> Either (OAuth2Error err) ByteString
handleOAuth2TokenResponse Response ByteString
rsp =
  if Status -> Bool
HT.statusIsSuccessful (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
rsp)
    then ByteString -> Either (OAuth2Error err) ByteString
forall a b. b -> Either a b
Right (ByteString -> Either (OAuth2Error err) ByteString)
-> ByteString -> Either (OAuth2Error err) ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp
    else OAuth2Error err -> Either (OAuth2Error err) ByteString
forall a b. a -> Either a b
Left (OAuth2Error err -> Either (OAuth2Error err) ByteString)
-> OAuth2Error err -> Either (OAuth2Error err) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> OAuth2Error err
forall err. FromJSON err => ByteString -> OAuth2Error err
parseOAuth2Error (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp)

-- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.
parseResponseFlexible ::
  (FromJSON err, FromJSON a) =>
  BSL.ByteString ->
  Either (OAuth2Error err) a
parseResponseFlexible :: ByteString -> Either (OAuth2Error err) a
parseResponseFlexible ByteString
r = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
r of
  Left String
_ -> ByteString -> Either (OAuth2Error err) a
forall err a.
(FromJSON err, FromJSON a) =>
ByteString -> Either (OAuth2Error err) a
parseResponseString ByteString
r
  Right a
x -> a -> Either (OAuth2Error err) a
forall a b. b -> Either a b
Right a
x

-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String
parseResponseString ::
  (FromJSON err, FromJSON a) =>
  BSL.ByteString ->
  Either (OAuth2Error err) a
parseResponseString :: ByteString -> Either (OAuth2Error err) a
parseResponseString ByteString
b = case ByteString -> Query
parseQuery (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
b of
  [] -> OAuth2Error err -> Either (OAuth2Error err) a
forall a b. a -> Either a b
Left OAuth2Error err
errorMessage
  Query
a -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result a) -> Value -> Result a
forall a b. (a -> b) -> a -> b
$ Query -> Value
queryToValue Query
a of
    Error String
_ -> OAuth2Error err -> Either (OAuth2Error err) a
forall a b. a -> Either a b
Left OAuth2Error err
errorMessage
    Success a
x -> a -> Either (OAuth2Error err) a
forall a b. b -> Either a b
Right a
x
  where
    queryToValue :: Query -> Value
queryToValue = Object -> Value
Object (Object -> Value) -> (Query -> Object) -> Query -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object)
-> (Query -> [(Key, Value)]) -> Query -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> (Key, Value))
-> Query -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> (Key, Value)
paramToPair
    paramToPair :: (ByteString, Maybe ByteString) -> (Key, Value)
paramToPair (ByteString
k, Maybe ByteString
mv) = (Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
k, Value -> (ByteString -> Value) -> Maybe ByteString -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) Maybe ByteString
mv)
    errorMessage :: OAuth2Error err
errorMessage = ByteString -> OAuth2Error err
forall err. FromJSON err => ByteString -> OAuth2Error err
parseOAuth2Error ByteString
b

-- | Set several header values:
--   + userAgennt    : `hoauth2`
--   + accept        : `application/json`
addDefaultRequestHeaders :: Request -> Request
addDefaultRequestHeaders :: Request -> Request
addDefaultRequestHeaders Request
req =
  let headers :: [(HeaderName, ByteString)]
headers = [(HeaderName, ByteString)]
defaultRequestHeaders [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
   in Request
req {requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
headers}