{-# LANGUAGE QuasiQuotes #-}

module Network.OAuth.OAuth2.Internal where

import Control.Arrow (second)
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.Types (Parser, explicitParseFieldMaybe)
import Data.Binary (Binary)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Default
import Data.Maybe
import Data.Text (Text, unpack)
import Data.Version (showVersion)
import GHC.Generics
import Lens.Micro
import Lens.Micro.Extras
import Network.HTTP.Conduit as C
import Network.HTTP.Types qualified as H
import Network.HTTP.Types qualified as HT
import Paths_hoauth2 (version)
import URI.ByteString
import URI.ByteString.Aeson ()
import URI.ByteString.QQ

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

-- * OAuth2 Configuration

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

-- | Query Parameter Representation
data OAuth2 = OAuth2
  { OAuth2 -> Text
oauth2ClientId :: Text
  , OAuth2 -> Text
oauth2ClientSecret :: Text
  , OAuth2 -> URIRef Absolute
oauth2AuthorizeEndpoint :: URIRef Absolute
  , OAuth2 -> URIRef Absolute
oauth2TokenEndpoint :: URIRef Absolute
  , OAuth2 -> URIRef Absolute
oauth2RedirectUri :: URIRef Absolute
  }
  deriving (Int -> OAuth2 -> ShowS
[OAuth2] -> ShowS
OAuth2 -> String
(Int -> OAuth2 -> ShowS)
-> (OAuth2 -> String) -> ([OAuth2] -> ShowS) -> Show OAuth2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuth2 -> ShowS
showsPrec :: Int -> OAuth2 -> ShowS
$cshow :: OAuth2 -> String
show :: OAuth2 -> String
$cshowList :: [OAuth2] -> ShowS
showList :: [OAuth2] -> ShowS
Show, OAuth2 -> OAuth2 -> Bool
(OAuth2 -> OAuth2 -> Bool)
-> (OAuth2 -> OAuth2 -> Bool) -> Eq OAuth2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OAuth2 -> OAuth2 -> Bool
== :: OAuth2 -> OAuth2 -> Bool
$c/= :: OAuth2 -> OAuth2 -> Bool
/= :: OAuth2 -> OAuth2 -> Bool
Eq)

instance Default OAuth2 where
  def :: OAuth2
def =
    OAuth2
      { oauth2ClientId :: Text
oauth2ClientId = Text
""
      , oauth2ClientSecret :: Text
oauth2ClientSecret = Text
""
      , oauth2AuthorizeEndpoint :: URIRef Absolute
oauth2AuthorizeEndpoint = [uri|https://www.example.com/|]
      , oauth2TokenEndpoint :: URIRef Absolute
oauth2TokenEndpoint = [uri|https://www.example.com/|]
      , oauth2RedirectUri :: URIRef Absolute
oauth2RedirectUri = [uri|https://www.example.com/|]
      }

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

-- * Tokens

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

newtype AccessToken = AccessToken {AccessToken -> Text
atoken :: Text} deriving (Get AccessToken
[AccessToken] -> Put
AccessToken -> Put
(AccessToken -> Put)
-> Get AccessToken -> ([AccessToken] -> Put) -> Binary AccessToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: AccessToken -> Put
put :: AccessToken -> Put
$cget :: Get AccessToken
get :: Get AccessToken
$cputList :: [AccessToken] -> Put
putList :: [AccessToken] -> Put
Binary, AccessToken -> AccessToken -> Bool
(AccessToken -> AccessToken -> Bool)
-> (AccessToken -> AccessToken -> Bool) -> Eq AccessToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessToken -> AccessToken -> Bool
== :: AccessToken -> AccessToken -> Bool
$c/= :: AccessToken -> AccessToken -> Bool
/= :: AccessToken -> AccessToken -> Bool
Eq, Int -> AccessToken -> ShowS
[AccessToken] -> ShowS
AccessToken -> String
(Int -> AccessToken -> ShowS)
-> (AccessToken -> String)
-> ([AccessToken] -> ShowS)
-> Show AccessToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessToken -> ShowS
showsPrec :: Int -> AccessToken -> ShowS
$cshow :: AccessToken -> String
show :: AccessToken -> String
$cshowList :: [AccessToken] -> ShowS
showList :: [AccessToken] -> ShowS
Show, Maybe AccessToken
Value -> Parser [AccessToken]
Value -> Parser AccessToken
(Value -> Parser AccessToken)
-> (Value -> Parser [AccessToken])
-> Maybe AccessToken
-> FromJSON AccessToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser AccessToken
parseJSON :: Value -> Parser AccessToken
$cparseJSONList :: Value -> Parser [AccessToken]
parseJSONList :: Value -> Parser [AccessToken]
$comittedField :: Maybe AccessToken
omittedField :: Maybe AccessToken
FromJSON, [AccessToken] -> Value
[AccessToken] -> Encoding
AccessToken -> Bool
AccessToken -> Value
AccessToken -> Encoding
(AccessToken -> Value)
-> (AccessToken -> Encoding)
-> ([AccessToken] -> Value)
-> ([AccessToken] -> Encoding)
-> (AccessToken -> Bool)
-> ToJSON AccessToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: AccessToken -> Value
toJSON :: AccessToken -> Value
$ctoEncoding :: AccessToken -> Encoding
toEncoding :: AccessToken -> Encoding
$ctoJSONList :: [AccessToken] -> Value
toJSONList :: [AccessToken] -> Value
$ctoEncodingList :: [AccessToken] -> Encoding
toEncodingList :: [AccessToken] -> Encoding
$comitField :: AccessToken -> Bool
omitField :: AccessToken -> Bool
ToJSON)

newtype RefreshToken = RefreshToken {RefreshToken -> Text
rtoken :: Text} deriving (Get RefreshToken
[RefreshToken] -> Put
RefreshToken -> Put
(RefreshToken -> Put)
-> Get RefreshToken
-> ([RefreshToken] -> Put)
-> Binary RefreshToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: RefreshToken -> Put
put :: RefreshToken -> Put
$cget :: Get RefreshToken
get :: Get RefreshToken
$cputList :: [RefreshToken] -> Put
putList :: [RefreshToken] -> Put
Binary, RefreshToken -> RefreshToken -> Bool
(RefreshToken -> RefreshToken -> Bool)
-> (RefreshToken -> RefreshToken -> Bool) -> Eq RefreshToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefreshToken -> RefreshToken -> Bool
== :: RefreshToken -> RefreshToken -> Bool
$c/= :: RefreshToken -> RefreshToken -> Bool
/= :: RefreshToken -> RefreshToken -> Bool
Eq, Int -> RefreshToken -> ShowS
[RefreshToken] -> ShowS
RefreshToken -> String
(Int -> RefreshToken -> ShowS)
-> (RefreshToken -> String)
-> ([RefreshToken] -> ShowS)
-> Show RefreshToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefreshToken -> ShowS
showsPrec :: Int -> RefreshToken -> ShowS
$cshow :: RefreshToken -> String
show :: RefreshToken -> String
$cshowList :: [RefreshToken] -> ShowS
showList :: [RefreshToken] -> ShowS
Show, Maybe RefreshToken
Value -> Parser [RefreshToken]
Value -> Parser RefreshToken
(Value -> Parser RefreshToken)
-> (Value -> Parser [RefreshToken])
-> Maybe RefreshToken
-> FromJSON RefreshToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser RefreshToken
parseJSON :: Value -> Parser RefreshToken
$cparseJSONList :: Value -> Parser [RefreshToken]
parseJSONList :: Value -> Parser [RefreshToken]
$comittedField :: Maybe RefreshToken
omittedField :: Maybe RefreshToken
FromJSON, [RefreshToken] -> Value
[RefreshToken] -> Encoding
RefreshToken -> Bool
RefreshToken -> Value
RefreshToken -> Encoding
(RefreshToken -> Value)
-> (RefreshToken -> Encoding)
-> ([RefreshToken] -> Value)
-> ([RefreshToken] -> Encoding)
-> (RefreshToken -> Bool)
-> ToJSON RefreshToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: RefreshToken -> Value
toJSON :: RefreshToken -> Value
$ctoEncoding :: RefreshToken -> Encoding
toEncoding :: RefreshToken -> Encoding
$ctoJSONList :: [RefreshToken] -> Value
toJSONList :: [RefreshToken] -> Value
$ctoEncodingList :: [RefreshToken] -> Encoding
toEncodingList :: [RefreshToken] -> Encoding
$comitField :: RefreshToken -> Bool
omitField :: RefreshToken -> Bool
ToJSON)

newtype IdToken = IdToken {IdToken -> Text
idtoken :: Text} deriving (Get IdToken
[IdToken] -> Put
IdToken -> Put
(IdToken -> Put)
-> Get IdToken -> ([IdToken] -> Put) -> Binary IdToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: IdToken -> Put
put :: IdToken -> Put
$cget :: Get IdToken
get :: Get IdToken
$cputList :: [IdToken] -> Put
putList :: [IdToken] -> Put
Binary, IdToken -> IdToken -> Bool
(IdToken -> IdToken -> Bool)
-> (IdToken -> IdToken -> Bool) -> Eq IdToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdToken -> IdToken -> Bool
== :: IdToken -> IdToken -> Bool
$c/= :: IdToken -> IdToken -> Bool
/= :: IdToken -> IdToken -> Bool
Eq, Int -> IdToken -> ShowS
[IdToken] -> ShowS
IdToken -> String
(Int -> IdToken -> ShowS)
-> (IdToken -> String) -> ([IdToken] -> ShowS) -> Show IdToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdToken -> ShowS
showsPrec :: Int -> IdToken -> ShowS
$cshow :: IdToken -> String
show :: IdToken -> String
$cshowList :: [IdToken] -> ShowS
showList :: [IdToken] -> ShowS
Show, Maybe IdToken
Value -> Parser [IdToken]
Value -> Parser IdToken
(Value -> Parser IdToken)
-> (Value -> Parser [IdToken]) -> Maybe IdToken -> FromJSON IdToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser IdToken
parseJSON :: Value -> Parser IdToken
$cparseJSONList :: Value -> Parser [IdToken]
parseJSONList :: Value -> Parser [IdToken]
$comittedField :: Maybe IdToken
omittedField :: Maybe IdToken
FromJSON, [IdToken] -> Value
[IdToken] -> Encoding
IdToken -> Bool
IdToken -> Value
IdToken -> Encoding
(IdToken -> Value)
-> (IdToken -> Encoding)
-> ([IdToken] -> Value)
-> ([IdToken] -> Encoding)
-> (IdToken -> Bool)
-> ToJSON IdToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: IdToken -> Value
toJSON :: IdToken -> Value
$ctoEncoding :: IdToken -> Encoding
toEncoding :: IdToken -> Encoding
$ctoJSONList :: [IdToken] -> Value
toJSONList :: [IdToken] -> Value
$ctoEncodingList :: [IdToken] -> Encoding
toEncodingList :: [IdToken] -> Encoding
$comitField :: IdToken -> Bool
omitField :: IdToken -> Bool
ToJSON)

-- | Authorization Code
newtype ExchangeToken = ExchangeToken {ExchangeToken -> Text
extoken :: Text} deriving (Int -> ExchangeToken -> ShowS
[ExchangeToken] -> ShowS
ExchangeToken -> String
(Int -> ExchangeToken -> ShowS)
-> (ExchangeToken -> String)
-> ([ExchangeToken] -> ShowS)
-> Show ExchangeToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExchangeToken -> ShowS
showsPrec :: Int -> ExchangeToken -> ShowS
$cshow :: ExchangeToken -> String
show :: ExchangeToken -> String
$cshowList :: [ExchangeToken] -> ShowS
showList :: [ExchangeToken] -> ShowS
Show, Maybe ExchangeToken
Value -> Parser [ExchangeToken]
Value -> Parser ExchangeToken
(Value -> Parser ExchangeToken)
-> (Value -> Parser [ExchangeToken])
-> Maybe ExchangeToken
-> FromJSON ExchangeToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ExchangeToken
parseJSON :: Value -> Parser ExchangeToken
$cparseJSONList :: Value -> Parser [ExchangeToken]
parseJSONList :: Value -> Parser [ExchangeToken]
$comittedField :: Maybe ExchangeToken
omittedField :: Maybe ExchangeToken
FromJSON, [ExchangeToken] -> Value
[ExchangeToken] -> Encoding
ExchangeToken -> Bool
ExchangeToken -> Value
ExchangeToken -> Encoding
(ExchangeToken -> Value)
-> (ExchangeToken -> Encoding)
-> ([ExchangeToken] -> Value)
-> ([ExchangeToken] -> Encoding)
-> (ExchangeToken -> Bool)
-> ToJSON ExchangeToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ExchangeToken -> Value
toJSON :: ExchangeToken -> Value
$ctoEncoding :: ExchangeToken -> Encoding
toEncoding :: ExchangeToken -> Encoding
$ctoJSONList :: [ExchangeToken] -> Value
toJSONList :: [ExchangeToken] -> Value
$ctoEncodingList :: [ExchangeToken] -> Encoding
toEncodingList :: [ExchangeToken] -> Encoding
$comitField :: ExchangeToken -> Bool
omitField :: ExchangeToken -> Bool
ToJSON)

-- FIXME: rename to TokenResponse and move to that module

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4
data OAuth2Token = OAuth2Token
  { OAuth2Token -> AccessToken
accessToken :: AccessToken
  , OAuth2Token -> Maybe RefreshToken
refreshToken :: Maybe RefreshToken
  -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token.
  , OAuth2Token -> Maybe Int
expiresIn :: Maybe Int
  , OAuth2Token -> Maybe Text
tokenType :: Maybe Text
  -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.
  , OAuth2Token -> Maybe IdToken
idToken :: Maybe IdToken
  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.
  }
  deriving (OAuth2Token -> OAuth2Token -> Bool
(OAuth2Token -> OAuth2Token -> Bool)
-> (OAuth2Token -> OAuth2Token -> Bool) -> Eq OAuth2Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OAuth2Token -> OAuth2Token -> Bool
== :: OAuth2Token -> OAuth2Token -> Bool
$c/= :: OAuth2Token -> OAuth2Token -> Bool
/= :: OAuth2Token -> OAuth2Token -> Bool
Eq, Int -> OAuth2Token -> ShowS
[OAuth2Token] -> ShowS
OAuth2Token -> String
(Int -> OAuth2Token -> ShowS)
-> (OAuth2Token -> String)
-> ([OAuth2Token] -> ShowS)
-> Show OAuth2Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuth2Token -> ShowS
showsPrec :: Int -> OAuth2Token -> ShowS
$cshow :: OAuth2Token -> String
show :: OAuth2Token -> String
$cshowList :: [OAuth2Token] -> ShowS
showList :: [OAuth2Token] -> ShowS
Show, (forall x. OAuth2Token -> Rep OAuth2Token x)
-> (forall x. Rep OAuth2Token x -> OAuth2Token)
-> Generic OAuth2Token
forall x. Rep OAuth2Token x -> OAuth2Token
forall x. OAuth2Token -> Rep OAuth2Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuth2Token -> Rep OAuth2Token x
from :: forall x. OAuth2Token -> Rep OAuth2Token x
$cto :: forall x. Rep OAuth2Token x -> OAuth2Token
to :: forall x. Rep OAuth2Token x -> OAuth2Token
Generic)

instance Binary OAuth2Token

-- | Parse JSON data into 'OAuth2Token'
instance FromJSON OAuth2Token where
  parseJSON :: Value -> Parser OAuth2Token
parseJSON = String
-> (Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"OAuth2Token" ((Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token)
-> (Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    AccessToken
-> Maybe RefreshToken
-> Maybe Int
-> Maybe Text
-> Maybe IdToken
-> OAuth2Token
OAuth2Token
      (AccessToken
 -> Maybe RefreshToken
 -> Maybe Int
 -> Maybe Text
 -> Maybe IdToken
 -> OAuth2Token)
-> Parser AccessToken
-> Parser
     (Maybe RefreshToken
      -> Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser AccessToken
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"access_token"
      Parser
  (Maybe RefreshToken
   -> Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe RefreshToken)
-> Parser (Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe RefreshToken)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"refresh_token"
      Parser (Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe Int)
-> Parser (Maybe Text -> Maybe IdToken -> OAuth2Token)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser Int) -> Object -> Key -> Parser (Maybe Int)
forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe Value -> Parser Int
parseIntFlexible Object
v Key
"expires_in"
      Parser (Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe Text) -> Parser (Maybe IdToken -> OAuth2Token)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"token_type"
      Parser (Maybe IdToken -> OAuth2Token)
-> Parser (Maybe IdToken) -> Parser OAuth2Token
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe IdToken)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id_token"
    where
      parseIntFlexible :: Value -> Parser Int
      parseIntFlexible :: Value -> Parser Int
parseIntFlexible (String Text
s) = Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parser Int) -> (String -> Int) -> String -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Parser Int) -> String -> Parser Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s
      parseIntFlexible Value
v = Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance ToJSON OAuth2Token where
  toJSON :: OAuth2Token -> Value
toJSON = Options -> OAuth2Token -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {fieldLabelModifier = camelTo2 '_'}
  toEncoding :: OAuth2Token -> Encoding
toEncoding = Options -> OAuth2Token -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions {fieldLabelModifier = camelTo2 '_'}

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

-- * Client Authentication methods

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

-- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3
-- According to spec:
--
-- The client MUST NOT use more than one authentication method in each request.
--
-- Which means use Authorization header or Post body.
--
-- However, I found I have to include authentication in the header all the time in real world.
--
-- In other words, `ClientSecretBasic` is always assured. `ClientSecretPost` is optional.
--
-- Maybe consider an alternative implementation that boolean kind of data type is good enough.
data ClientAuthenticationMethod
  = ClientSecretBasic
  | ClientSecretPost
  | ClientAssertionJwt
  deriving (ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
(ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool)
-> (ClientAuthenticationMethod
    -> ClientAuthenticationMethod -> Bool)
-> Eq ClientAuthenticationMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
Eq)

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

-- * Utilies for Request and URI

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

-- | Type synonym of post body content
type PostBody = [(BS.ByteString, BS.ByteString)]

-- | Type sysnonym of request query params
type QueryParams = [(BS.ByteString, BS.ByteString)]

defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]
defaultRequestHeaders :: [(HeaderName, ByteString)]
defaultRequestHeaders =
  [ (HeaderName
HT.hUserAgent, ByteString
"hoauth2-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Version -> String
showVersion Version
version))
  , (HeaderName
HT.hAccept, ByteString
"application/json")
  ]

appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a
appendQueryParams :: forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
params =
  ASetter
  (URIRef a)
  (URIRef a)
  [(ByteString, ByteString)]
  [(ByteString, ByteString)]
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> URIRef a
-> URIRef a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a)
forall a (f :: * -> *).
Functor f =>
(Query -> f Query) -> URIRef a -> f (URIRef a)
queryL ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a))
-> (([(ByteString, ByteString)]
     -> Identity [(ByteString, ByteString)])
    -> Query -> Identity Query)
-> ASetter
     (URIRef a)
     (URIRef a)
     [(ByteString, ByteString)]
     [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)] -> Identity [(ByteString, ByteString)])
-> Query -> Identity Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) ([(ByteString, ByteString)]
params [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++)

uriToRequest :: MonadThrow m => URI -> m Request
uriToRequest :: forall (m :: * -> *). MonadThrow m => URIRef Absolute -> m Request
uriToRequest URIRef Absolute
auri = do
  Bool
ssl <- case Getting ByteString (URIRef Absolute) ByteString
-> URIRef Absolute -> ByteString
forall a s. Getting a s a -> s -> a
view ((Scheme -> Const ByteString Scheme)
-> URIRef Absolute -> Const ByteString (URIRef Absolute)
Lens' (URIRef Absolute) Scheme
uriSchemeL ((Scheme -> Const ByteString Scheme)
 -> URIRef Absolute -> Const ByteString (URIRef Absolute))
-> ((ByteString -> Const ByteString ByteString)
    -> Scheme -> Const ByteString Scheme)
-> Getting ByteString (URIRef Absolute) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const ByteString ByteString)
-> Scheme -> Const ByteString Scheme
Lens' Scheme ByteString
schemeBSL) URIRef Absolute
auri of
    ByteString
"http" -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ByteString
"https" -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ByteString
s -> HttpException -> m Bool
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HttpException -> m Bool) -> HttpException -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> HttpException
InvalidUrlException (URIRef Absolute -> String
forall a. Show a => a -> String
show URIRef Absolute
auri) (String
"Invalid scheme: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
s)
  let query :: [(ByteString, Maybe ByteString)]
query = ((ByteString, ByteString) -> (ByteString, Maybe ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> (ByteString, Maybe ByteString)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) (Getting
  [(ByteString, ByteString)]
  (URIRef Absolute)
  [(ByteString, ByteString)]
-> URIRef Absolute -> [(ByteString, ByteString)]
forall a s. Getting a s a -> s -> a
view ((Query -> Const [(ByteString, ByteString)] Query)
-> URIRef Absolute
-> Const [(ByteString, ByteString)] (URIRef Absolute)
forall a (f :: * -> *).
Functor f =>
(Query -> f Query) -> URIRef a -> f (URIRef a)
queryL ((Query -> Const [(ByteString, ByteString)] Query)
 -> URIRef Absolute
 -> Const [(ByteString, ByteString)] (URIRef Absolute))
-> (([(ByteString, ByteString)]
     -> Const [(ByteString, ByteString)] [(ByteString, ByteString)])
    -> Query -> Const [(ByteString, ByteString)] Query)
-> Getting
     [(ByteString, ByteString)]
     (URIRef Absolute)
     [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)]
 -> Const [(ByteString, ByteString)] [(ByteString, ByteString)])
-> Query -> Const [(ByteString, ByteString)] Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) URIRef Absolute
auri)
      hostL :: (ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL = (Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> URIRef a -> Const (First ByteString) (URIRef a)
forall a (f :: * -> *).
Functor f =>
(Maybe Authority -> f (Maybe Authority))
-> URIRef a -> f (URIRef a)
authorityL ((Maybe Authority -> Const (First ByteString) (Maybe Authority))
 -> URIRef a -> Const (First ByteString) (URIRef a))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> (ByteString -> Const (First ByteString) ByteString)
-> URIRef a
-> Const (First ByteString) (URIRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Authority -> Const (First ByteString) Authority)
-> Maybe Authority -> Const (First ByteString) (Maybe Authority)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just ((Authority -> Const (First ByteString) Authority)
 -> Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Authority -> Const (First ByteString) Authority)
-> (ByteString -> Const (First ByteString) ByteString)
-> Maybe Authority
-> Const (First ByteString) (Maybe Authority)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Host -> Const (First ByteString) Host)
-> Authority -> Const (First ByteString) Authority
Lens' Authority Host
authorityHostL ((Host -> Const (First ByteString) Host)
 -> Authority -> Const (First ByteString) Authority)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Host -> Const (First ByteString) Host)
-> (ByteString -> Const (First ByteString) ByteString)
-> Authority
-> Const (First ByteString) Authority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (First ByteString) ByteString)
-> Host -> Const (First ByteString) Host
Lens' Host ByteString
hostBSL
      portL :: (Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL = (Maybe Authority -> Const (First Int) (Maybe Authority))
-> URIRef a -> Const (First Int) (URIRef a)
forall a (f :: * -> *).
Functor f =>
(Maybe Authority -> f (Maybe Authority))
-> URIRef a -> f (URIRef a)
authorityL ((Maybe Authority -> Const (First Int) (Maybe Authority))
 -> URIRef a -> Const (First Int) (URIRef a))
-> ((Int -> Const (First Int) Int)
    -> Maybe Authority -> Const (First Int) (Maybe Authority))
-> (Int -> Const (First Int) Int)
-> URIRef a
-> Const (First Int) (URIRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Authority -> Const (First Int) Authority)
-> Maybe Authority -> Const (First Int) (Maybe Authority)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just ((Authority -> Const (First Int) Authority)
 -> Maybe Authority -> Const (First Int) (Maybe Authority))
-> ((Int -> Const (First Int) Int)
    -> Authority -> Const (First Int) Authority)
-> (Int -> Const (First Int) Int)
-> Maybe Authority
-> Const (First Int) (Maybe Authority)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Port -> Const (First Int) (Maybe Port))
-> Authority -> Const (First Int) Authority
Lens' Authority (Maybe Port)
authorityPortL ((Maybe Port -> Const (First Int) (Maybe Port))
 -> Authority -> Const (First Int) Authority)
-> ((Int -> Const (First Int) Int)
    -> Maybe Port -> Const (First Int) (Maybe Port))
-> (Int -> Const (First Int) Int)
-> Authority
-> Const (First Int) Authority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Port -> Const (First Int) Port)
-> Maybe Port -> Const (First Int) (Maybe Port)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just ((Port -> Const (First Int) Port)
 -> Maybe Port -> Const (First Int) (Maybe Port))
-> ((Int -> Const (First Int) Int)
    -> Port -> Const (First Int) Port)
-> (Int -> Const (First Int) Int)
-> Maybe Port
-> Const (First Int) (Maybe Port)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int) -> Port -> Const (First Int) Port
Lens' Port Int
portNumberL
      defaultPort :: Int
defaultPort = (if Bool
ssl then Int
443 else Int
80) :: Int

      req :: Request
req =
        [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString [(ByteString, Maybe ByteString)]
query (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
          Request
defaultRequest
            { secure = ssl
            , path = view pathL auri
            }
      req2 :: Request
req2 = (ASetter Request Request ByteString ByteString
-> (ByteString -> ByteString) -> Request -> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Request Request ByteString ByteString
Lens' Request ByteString
hostLens ((ByteString -> ByteString) -> Request -> Request)
-> (URIRef Absolute -> ByteString -> ByteString)
-> URIRef Absolute
-> Request
-> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString)
-> (ByteString -> ByteString -> ByteString)
-> Maybe ByteString
-> ByteString
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> ByteString
forall a. a -> a
id ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const (Maybe ByteString -> ByteString -> ByteString)
-> (URIRef Absolute -> Maybe ByteString)
-> URIRef Absolute
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First ByteString) (URIRef Absolute) ByteString
-> URIRef Absolute -> Maybe ByteString
forall a s. Getting (First a) s a -> s -> Maybe a
preview Getting (First ByteString) (URIRef Absolute) ByteString
forall {a}.
(ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL) URIRef Absolute
auri Request
req
      req3 :: Request
req3 = (ASetter Request Request Int Int
-> (Int -> Int) -> Request -> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Request Request Int Int
Lens' Request Int
portLens ((Int -> Int) -> Request -> Request)
-> (URIRef Absolute -> Int -> Int)
-> URIRef Absolute
-> Request
-> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a b. a -> b -> a
const (Int -> Int -> Int)
-> (Maybe Int -> Int) -> Maybe Int -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultPort) (Maybe Int -> Int -> Int)
-> (URIRef Absolute -> Maybe Int) -> URIRef Absolute -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Int) (URIRef Absolute) Int
-> URIRef Absolute -> Maybe Int
forall a s. Getting (First a) s a -> s -> Maybe a
preview Getting (First Int) (URIRef Absolute) Int
forall {a}.
(Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL) URIRef Absolute
auri Request
req2
  Request -> m Request
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req3

requestToUri :: Request -> URI
requestToUri :: Request -> URIRef Absolute
requestToUri Request
req =
  Scheme
-> Maybe Authority
-> ByteString
-> Query
-> Maybe ByteString
-> URIRef Absolute
URI
    ( ByteString -> Scheme
Scheme
        ( if Request -> Bool
secure Request
req
            then ByteString
"https"
            else ByteString
"http"
        )
    )
    (Authority -> Maybe Authority
forall a. a -> Maybe a
Just (Maybe UserInfo -> Host -> Maybe Port -> Authority
Authority Maybe UserInfo
forall a. Maybe a
Nothing (ByteString -> Host
Host (ByteString -> Host) -> ByteString -> Host
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req) (Port -> Maybe Port
forall a. a -> Maybe a
Just (Port -> Maybe Port) -> Port -> Maybe Port
forall a b. (a -> b) -> a -> b
$ Int -> Port
Port (Int -> Port) -> Int -> Port
forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req)))
    (Request -> ByteString
path Request
req)
    ([(ByteString, ByteString)] -> Query
Query ([(ByteString, ByteString)] -> Query)
-> [(ByteString, ByteString)] -> Query
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
H.parseSimpleQuery (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req)
    Maybe ByteString
forall a. Maybe a
Nothing

hostLens :: Lens' Request BS.ByteString
hostLens :: Lens' Request ByteString
hostLens ByteString -> f ByteString
f Request
req = ByteString -> f ByteString
f (Request -> ByteString
C.host Request
req) f ByteString -> (ByteString -> Request) -> f Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ByteString
h' -> Request
req {C.host = h'}
{-# INLINE hostLens #-}

portLens :: Lens' Request Int
portLens :: Lens' Request Int
portLens Int -> f Int
f Request
req = Int -> f Int
f (Request -> Int
C.port Request
req) f Int -> (Int -> Request) -> f Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
p' -> Request
req {C.port = p'}
{-# INLINE portLens #-}