{-# LANGUAGE OverloadedStrings #-}
{-|
    Module: Web.OIDC.Client.Internal
    Maintainer: krdlab@gmail.com
    Stability: experimental
-}
module Web.OIDC.Client.Internal where

import           Control.Applicative   ((<|>))
import           Control.Monad         (mzero)
import           Control.Monad.Catch   (MonadCatch, MonadThrow, throwM)
import           Data.Aeson            (FromJSON, Value (..), parseJSON, (.:),
                                        (.:?))
import           Data.Aeson.Types      (Parser)
import           Data.Text             (Text, unpack)
import           Data.Text.Read        (decimal)
import           Jose.Jwt              (Jwt)
import           Network.HTTP.Client   (HttpException, Request, parseRequest)
import           Prelude               hiding (exp)
import           Web.OIDC.Client.Types (OpenIdException (InternalHttpException))

data TokensResponse = TokensResponse
    { TokensResponse -> Text
accessToken  :: !Text
    , TokensResponse -> Text
tokenType    :: !Text
    , TokensResponse -> Jwt
idToken      :: !Jwt
    , TokensResponse -> Maybe Integer
expiresIn    :: !(Maybe Integer)
    , TokensResponse -> Maybe Text
refreshToken :: !(Maybe Text)
    }
  deriving (Int -> TokensResponse -> ShowS
[TokensResponse] -> ShowS
TokensResponse -> String
(Int -> TokensResponse -> ShowS)
-> (TokensResponse -> String)
-> ([TokensResponse] -> ShowS)
-> Show TokensResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokensResponse] -> ShowS
$cshowList :: [TokensResponse] -> ShowS
show :: TokensResponse -> String
$cshow :: TokensResponse -> String
showsPrec :: Int -> TokensResponse -> ShowS
$cshowsPrec :: Int -> TokensResponse -> ShowS
Show, TokensResponse -> TokensResponse -> Bool
(TokensResponse -> TokensResponse -> Bool)
-> (TokensResponse -> TokensResponse -> Bool) -> Eq TokensResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokensResponse -> TokensResponse -> Bool
$c/= :: TokensResponse -> TokensResponse -> Bool
== :: TokensResponse -> TokensResponse -> Bool
$c== :: TokensResponse -> TokensResponse -> Bool
Eq)

instance FromJSON TokensResponse where
    parseJSON :: Value -> Parser TokensResponse
parseJSON (Object Object
o) = Text
-> Text -> Jwt -> Maybe Integer -> Maybe Text -> TokensResponse
TokensResponse
        (Text
 -> Text -> Jwt -> Maybe Integer -> Maybe Text -> TokensResponse)
-> Parser Text
-> Parser
     (Text -> Jwt -> Maybe Integer -> Maybe Text -> TokensResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.:  Text
"access_token"
        Parser
  (Text -> Jwt -> Maybe Integer -> Maybe Text -> TokensResponse)
-> Parser Text
-> Parser (Jwt -> Maybe Integer -> Maybe Text -> TokensResponse)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.:  Text
"token_type"
        Parser (Jwt -> Maybe Integer -> Maybe Text -> TokensResponse)
-> Parser Jwt
-> Parser (Maybe Integer -> Maybe Text -> TokensResponse)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  Object
o Object -> Text -> Parser Jwt
forall a. FromJSON a => Object -> Text -> Parser a
.:  Text
"id_token"
        Parser (Maybe Integer -> Maybe Text -> TokensResponse)
-> Parser (Maybe Integer) -> Parser (Maybe Text -> TokensResponse)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Object
o Object -> Text -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"expires_in") Parser (Maybe Integer)
-> Parser (Maybe Integer) -> Parser (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe Text -> Parser (Maybe Integer)
textToInt (Maybe Text -> Parser (Maybe Integer))
-> Parser (Maybe Text) -> Parser (Maybe Integer)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"expires_in")))
        Parser (Maybe Text -> TokensResponse)
-> Parser (Maybe Text) -> Parser TokensResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"refresh_token"
    parseJSON Value
_          = Parser TokensResponse
forall (m :: * -> *) a. MonadPlus m => m a
mzero

textToInt :: Maybe Text -> Parser (Maybe Integer)
textToInt :: Maybe Text -> Parser (Maybe Integer)
textToInt (Just Text
t) =
    case Reader Integer
forall a. Integral a => Reader a
decimal Text
t of
        Right (Integer
i, Text
_) -> Maybe Integer -> Parser (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Parser (Maybe Integer))
-> Maybe Integer -> Parser (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
        Left  String
_      -> String -> Parser (Maybe Integer)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expires_in: expected a decimal text, encountered a non decimal text"
textToInt Maybe Text
_        = Maybe Integer -> Parser (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing

rethrow :: (MonadCatch m) => HttpException -> m a
rethrow :: HttpException -> m a
rethrow = OpenIdException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (OpenIdException -> m a)
-> (HttpException -> OpenIdException) -> HttpException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> OpenIdException
InternalHttpException

parseUrl :: MonadThrow m => Text -> m Request
parseUrl :: Text -> m Request
parseUrl = String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
Network.HTTP.Client.parseRequest (String -> m Request) -> (Text -> String) -> Text -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack