{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}

module Network.OAuth.OAuth2.Internal where

import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.Types (Parser, explicitParseFieldMaybe)
import Data.Binary (Binary)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Default
import Data.Maybe
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding
import GHC.Generics
import Lens.Micro
import Lens.Micro.Extras
import Network.HTTP.Conduit as C
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as HT
import URI.ByteString
import URI.ByteString.Aeson ()
import URI.ByteString.QQ

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

-- * Data Types

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

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2] -> ShowS
$cshowList :: [OAuth2] -> ShowS
show :: OAuth2 -> String
$cshow :: OAuth2 -> String
showsPrec :: Int -> OAuth2 -> ShowS
$cshowsPrec :: Int -> OAuth2 -> ShowS
Show, OAuth2 -> OAuth2 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2 -> OAuth2 -> Bool
$c/= :: OAuth2 -> OAuth2 -> Bool
== :: OAuth2 -> OAuth2 -> Bool
$c== :: 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/|]
      }

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

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

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

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

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4
data OAuth2Token = OAuth2Token
  { OAuth2Token -> AccessToken
accessToken :: AccessToken,
    -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token.
    OAuth2Token -> Maybe RefreshToken
refreshToken :: Maybe RefreshToken,
    OAuth2Token -> Maybe Int
expiresIn :: Maybe Int,
    -- | 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 Text
tokenType :: Maybe Text,
    -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID.
    OAuth2Token -> Maybe IdToken
idToken :: Maybe IdToken
  }
  deriving (OAuth2Token -> OAuth2Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2Token -> OAuth2Token -> Bool
$c/= :: OAuth2Token -> OAuth2Token -> Bool
== :: OAuth2Token -> OAuth2Token -> Bool
$c== :: OAuth2Token -> OAuth2Token -> Bool
Eq, Int -> OAuth2Token -> ShowS
[OAuth2Token] -> ShowS
OAuth2Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2Token] -> ShowS
$cshowList :: [OAuth2Token] -> ShowS
show :: OAuth2Token -> String
$cshow :: OAuth2Token -> String
showsPrec :: Int -> OAuth2Token -> ShowS
$cshowsPrec :: Int -> OAuth2Token -> ShowS
Show, 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
$cto :: forall x. Rep OAuth2Token x -> OAuth2Token
$cfrom :: forall x. OAuth2Token -> Rep OAuth2Token x
Generic)

instance Binary OAuth2Token

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

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

data OAuth2Error a = OAuth2Error
  { forall a. OAuth2Error a -> Either Text a
error :: Either Text a,
    forall a. OAuth2Error a -> Maybe Text
errorDescription :: Maybe Text,
    forall a. OAuth2Error a -> Maybe (URIRef Absolute)
errorUri :: Maybe (URIRef Absolute)
  }
  deriving (Int -> OAuth2Error a -> ShowS
forall a. Show a => Int -> OAuth2Error a -> ShowS
forall a. Show a => [OAuth2Error a] -> ShowS
forall a. Show a => OAuth2Error a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2Error a] -> ShowS
$cshowList :: forall a. Show a => [OAuth2Error a] -> ShowS
show :: OAuth2Error a -> String
$cshow :: forall a. Show a => OAuth2Error a -> String
showsPrec :: Int -> OAuth2Error a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OAuth2Error a -> ShowS
Show, OAuth2Error a -> OAuth2Error a -> Bool
forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2Error a -> OAuth2Error a -> Bool
$c/= :: forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
== :: OAuth2Error a -> OAuth2Error a -> Bool
$c== :: forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (OAuth2Error a) x -> OAuth2Error a
forall a x. OAuth2Error a -> Rep (OAuth2Error a) x
$cto :: forall a x. Rep (OAuth2Error a) x -> OAuth2Error a
$cfrom :: forall a x. OAuth2Error a -> Rep (OAuth2Error a) x
Generic)

instance FromJSON err => FromJSON (OAuth2Error err) where
  parseJSON :: Value -> Parser (OAuth2Error err)
parseJSON (Object Object
a) =
    do
      Either Text err
err <- (Object
a forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Value
str -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
str forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
str)
      Maybe Text
desc <- Object
a forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error_description"
      Maybe (URIRef Absolute)
errorUri <- Object
a forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error_uri"
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Either Text a
-> Maybe Text -> Maybe (URIRef Absolute) -> OAuth2Error a
OAuth2Error Either Text err
err Maybe Text
desc Maybe (URIRef Absolute)
errorUri
  parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected an object"

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

parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err
parseOAuth2Error :: forall err. FromJSON err => ByteString -> OAuth2Error err
parseOAuth2Error ByteString
string =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall err. ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error ByteString
string) forall a. a -> a
id (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
string)

mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error :: forall err. ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error ByteString
response String
err =
  forall a.
Either Text a
-> Maybe Text -> Maybe (URIRef Absolute) -> OAuth2Error a
OAuth2Error
    (forall a b. a -> Either a b
Left Text
"Decode error")
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ String
"Error: " forall a. Semigroup a => a -> a -> a
<> String
err forall a. Semigroup a => a -> a -> a
<> String
"\n Original Response:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
response))
    forall a. Maybe a
Nothing

-- | 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, in reality, I always have to include authentication in the header.
--
-- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional.
--
-- Maybe consider an alternative implementation that boolean kind of data type is good enough.
data ClientAuthenticationMethod
  = ClientSecretBasic
  | ClientSecretPost
  deriving (ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
Eq, Eq ClientAuthenticationMethod
ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
$cmin :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
max :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
$cmax :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
>= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c>= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
> :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c> :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
<= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c<= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
< :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c< :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
compare :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
$ccompare :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
Ord)

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

-- * Types Synonym

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

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

type QueryParams = [(BS.ByteString, BS.ByteString)]

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

-- * Utilies

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

defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]
defaultRequestHeaders :: [(HeaderName, ByteString)]
defaultRequestHeaders =
  [ (HeaderName
HT.hUserAgent, ByteString
"hoauth2"),
    (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 =
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall a. Lens' (URIRef a) Query
queryL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Query [(ByteString, ByteString)]
queryPairsL) ([(ByteString, ByteString)]
params 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 forall a s. Getting a s a -> s -> a
view (Lens' (URIRef Absolute) Scheme
uriSchemeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Scheme ByteString
schemeBSL) URIRef Absolute
auri of
    ByteString
"http" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ByteString
"https" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ByteString
s -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> String -> HttpException
InvalidUrlException (forall a. Show a => a -> String
show URIRef Absolute
auri) (String
"Invalid scheme: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
s)
  let query :: [(ByteString, Maybe ByteString)]
query = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just) (forall a s. Getting a s a -> s -> a
view (forall a. Lens' (URIRef a) Query
queryL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Query [(ByteString, ByteString)]
queryPairsL) URIRef Absolute
auri)
      hostL :: (ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL = forall a. Lens' (URIRef a) (Maybe Authority)
authorityL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Authority Host
authorityHostL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Host ByteString
hostBSL
      portL :: (Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL = forall a. Lens' (URIRef a) (Maybe Authority)
authorityL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Authority (Maybe Port)
authorityPortL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$
          Request
defaultRequest
            { secure :: Bool
secure = Bool
ssl,
              path :: ByteString
path = forall a s. Getting a s a -> s -> a
view forall a. Lens' (URIRef a) ByteString
pathL URIRef Absolute
auri
            }
      req2 :: Request
req2 = (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Request ByteString
hostLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (First a) s a -> s -> Maybe a
preview forall {a}.
(ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL) URIRef Absolute
auri Request
req
      req3 :: Request
req3 = (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Request Int
portLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Int
defaultPort) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (First a) s a -> s -> Maybe a
preview forall {a}.
(Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL) URIRef Absolute
auri Request
req2
  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"
        )
    )
    (forall a. a -> Maybe a
Just (Maybe UserInfo -> Host -> Maybe Port -> Authority
Authority forall a. Maybe a
Nothing (ByteString -> Host
Host forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Port
Port forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req)))
    (Request -> ByteString
path Request
req)
    ([(ByteString, ByteString)] -> Query
Query forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
H.parseSimpleQuery forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req)
    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) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ByteString
h' -> Request
req {host :: ByteString
C.host = ByteString
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) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
p' -> Request
req {port :: Int
C.port = Int
p'}
{-# INLINE portLens #-}