{-# LANGUAGE QuasiQuotes #-}

module Network.OAuth2.Internal where

import Control.Monad.Catch
import Data.Aeson
import Data.Binary.Instances.Aeson ()
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Default
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Version (showVersion)
import Lens.Micro (over)
import Network.HTTP.Conduit as C
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 (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 (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 (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)

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

-- * Client Authentication methods

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

-- | How would the Client (RP) authenticate itself?
--
-- The client MUST NOT use more than one authentication method in each request.
-- Means use Authorization header or Post body.
--
-- See more details
--
-- https://www.rfc-editor.org/rfc/rfc6749#section-2.3
-- https://oauth.net/private-key-jwt/
-- https://www.rfc-editor.org/rfc/rfc7523.html
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, Int -> ClientAuthenticationMethod -> ShowS
[ClientAuthenticationMethod] -> ShowS
ClientAuthenticationMethod -> String
(Int -> ClientAuthenticationMethod -> ShowS)
-> (ClientAuthenticationMethod -> String)
-> ([ClientAuthenticationMethod] -> ShowS)
-> Show ClientAuthenticationMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientAuthenticationMethod -> ShowS
showsPrec :: Int -> ClientAuthenticationMethod -> ShowS
$cshow :: ClientAuthenticationMethod -> String
show :: ClientAuthenticationMethod -> String
$cshowList :: [ClientAuthenticationMethod] -> ShowS
showList :: [ClientAuthenticationMethod] -> ShowS
Show)

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

-- * 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
<> (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion Version
version))
  , (HeaderName
HT.hAccept, ByteString
"application/json")
  ]

-- | 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 = headers}

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 = String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> m Request)
-> (URIRef Absolute -> String) -> URIRef Absolute -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack (ByteString -> String)
-> (URIRef Absolute -> ByteString) -> URIRef Absolute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIRef Absolute -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef'