{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Authentication with Keycloak is based on [JWTs](https://jwt.io/).
-- This module helps you retrieve tokens from Keycloak, and use them to authenticate your users.
-- In Keycloak, you need to configure a realm, a client and a user.
-- 
-- Users can also have additional attributes.
-- To see them in the Token, you need to add "protocol mappers" in the Client, that will copy the User attribute in the Token.
-- 
-- The example below retrieves a User token using Login/password, verifies it, and extract all the user details from it.
-- 
-- @
-- main :: IO ()
-- main = do
-- 
--   --configure Keycloak with the adapter config file. You can retrieve this file in your Client/Installation tab (JSON format).
--   --This function will also get the signing keys from Keycloak, so make sure that Keycloak is on and configured!
--   kcConfig <- configureKeycloak "keycloak.json"
--
--   void $ flip runKeycloak kcConfig $ do
--   
--     -- Get a JWT from Keycloak. A JWT can then be used to authenticate yourself with an application.
--     jwt <- getJWT "demo" "demo" 
--     liftIO $ putStrLn $ "Got JWT: \n" ++ (show jwt) ++ "\n\n"
--   
--     -- Retrieve the claims contained in the JWT.
--     claims <- verifyJWT jwt
--     liftIO $ putStrLn $ "Claims decoded from Token: \n" ++ (show claims) ++ "\n\n"
--     
--     -- get the user from the claim
--     let user = getClaimsUser claims
--     liftIO $ putStrLn $ "User decoded from claims: \n" ++ (show user) ++ "\n\n"
-- @

module Keycloak.Tokens where

import           Control.Lens hiding ((.=))
import           Control.Monad.IO.Class
import           Control.Monad.Time (MonadTime)
import           Crypto.JWT as JWT
import           Data.Aeson as JSON
import           Data.Aeson.Lens
import           Data.Text as T hiding (head, tail, map)
import           Data.Maybe
import           Data.String.Conversions
import           Keycloak.Types
import           Keycloak.Utils
import           Network.Wreq as W hiding (statusCode)



-- | Retrieve the user's token. This token can be used to authenticate the user.
-- This token can be also used for every other Keycloak calls.
getJWT :: MonadIO m => Username -> Password ->  KeycloakT m JWT
getJWT :: Username -> Username -> KeycloakT m JWT
getJWT Username
username Username
password = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get user token"
  Username
client <- Getting Username KCConfig Username -> KeycloakT m Username
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting Username KCConfig Username -> KeycloakT m Username)
-> Getting Username KCConfig Username -> KeycloakT m Username
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const Username AdapterConfig)
-> KCConfig -> Const Username KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const Username AdapterConfig)
 -> KCConfig -> Const Username KCConfig)
-> ((Username -> Const Username Username)
    -> AdapterConfig -> Const Username AdapterConfig)
-> Getting Username KCConfig Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Username -> Const Username Username)
-> AdapterConfig -> Const Username AdapterConfig
Lens' AdapterConfig Username
confResource
  Username
secret <- Getting Username KCConfig Username -> KeycloakT m Username
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting Username KCConfig Username -> KeycloakT m Username)
-> Getting Username KCConfig Username -> KeycloakT m Username
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const Username AdapterConfig)
-> KCConfig -> Const Username KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const Username AdapterConfig)
 -> KCConfig -> Const Username KCConfig)
-> ((Username -> Const Username Username)
    -> AdapterConfig -> Const Username AdapterConfig)
-> Getting Username KCConfig Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ClientCredentials -> Const Username ClientCredentials)
-> AdapterConfig -> Const Username AdapterConfig
Lens' AdapterConfig ClientCredentials
confCredentials((ClientCredentials -> Const Username ClientCredentials)
 -> AdapterConfig -> Const Username AdapterConfig)
-> ((Username -> Const Username Username)
    -> ClientCredentials -> Const Username ClientCredentials)
-> (Username -> Const Username Username)
-> AdapterConfig
-> Const Username AdapterConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Username -> Const Username Username)
-> ClientCredentials -> Const Username ClientCredentials
Iso' ClientCredentials Username
confSecret
  let dat :: [FormParam]
dat = [ByteString
"client_id" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
client, 
             ByteString
"client_secret" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
secret,
             ByteString
"grant_type" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Username
"password" :: Text),
             ByteString
"password" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
password,
             ByteString
"username" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
username]
  ByteString
body <- Username -> [FormParam] -> KeycloakT m ByteString
forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Username -> dat -> KeycloakT m ByteString
keycloakPost' Username
"protocol/openid-connect/token" [FormParam]
dat
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ByteString -> String
forall a. Show a => a -> String
show ByteString
body) 
  case ByteString -> Either String TokenRep
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right TokenRep
ret -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak success: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TokenRep -> String
forall a. Show a => a -> String
show TokenRep
ret) 
      ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT
forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT (ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT)
-> ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT
forall a b. (a -> b) -> a -> b
$ ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT
forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact (ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT)
-> ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT
forall a b. (a -> b) -> a -> b
$ Username -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString (Username -> ByteString) -> Username -> ByteString
forall a b. (a -> b) -> a -> b
$ TokenRep -> Username
accessToken TokenRep
ret
    Left String
err2 -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m JWT
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m JWT) -> KCError -> KeycloakT m JWT
forall a b. (a -> b) -> a -> b
$ Username -> KCError
ParseError (Username -> KCError) -> Username -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Username
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | return a Client token (linked to a Client, not a User). It is useful to create Resources in that Client in Keycloak.
getClientJWT :: MonadIO m => KeycloakT m JWT
getClientJWT :: KeycloakT m JWT
getClientJWT = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get client token"
  Username
client <- Getting Username KCConfig Username -> KeycloakT m Username
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting Username KCConfig Username -> KeycloakT m Username)
-> Getting Username KCConfig Username -> KeycloakT m Username
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const Username AdapterConfig)
-> KCConfig -> Const Username KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const Username AdapterConfig)
 -> KCConfig -> Const Username KCConfig)
-> ((Username -> Const Username Username)
    -> AdapterConfig -> Const Username AdapterConfig)
-> Getting Username KCConfig Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Username -> Const Username Username)
-> AdapterConfig -> Const Username AdapterConfig
Lens' AdapterConfig Username
confResource
  Username
secret <- Getting Username KCConfig Username -> KeycloakT m Username
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting Username KCConfig Username -> KeycloakT m Username)
-> Getting Username KCConfig Username -> KeycloakT m Username
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const Username AdapterConfig)
-> KCConfig -> Const Username KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const Username AdapterConfig)
 -> KCConfig -> Const Username KCConfig)
-> ((Username -> Const Username Username)
    -> AdapterConfig -> Const Username AdapterConfig)
-> Getting Username KCConfig Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ClientCredentials -> Const Username ClientCredentials)
-> AdapterConfig -> Const Username AdapterConfig
Lens' AdapterConfig ClientCredentials
confCredentials((ClientCredentials -> Const Username ClientCredentials)
 -> AdapterConfig -> Const Username AdapterConfig)
-> ((Username -> Const Username Username)
    -> ClientCredentials -> Const Username ClientCredentials)
-> (Username -> Const Username Username)
-> AdapterConfig
-> Const Username AdapterConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Username -> Const Username Username)
-> ClientCredentials -> Const Username ClientCredentials
Iso' ClientCredentials Username
confSecret
  let dat :: [FormParam]
dat = [ByteString
"client_id" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
client, 
             ByteString
"client_secret" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Username
secret,
             ByteString
"grant_type" ByteString -> Username -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Username
"client_credentials" :: Text)]
  ByteString
body <- Username -> [FormParam] -> KeycloakT m ByteString
forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Username -> dat -> KeycloakT m ByteString
keycloakPost' Username
"protocol/openid-connect/token" [FormParam]
dat
  case ByteString -> Either String TokenRep
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right TokenRep
ret -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak success: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TokenRep -> String
forall a. Show a => a -> String
show TokenRep
ret) 
      ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT
forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT (ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT)
-> ReaderT KCConfig (ExceptT KCError m) JWT -> KeycloakT m JWT
forall a b. (a -> b) -> a -> b
$ ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT
forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact (ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT)
-> ByteString -> ReaderT KCConfig (ExceptT KCError m) JWT
forall a b. (a -> b) -> a -> b
$ Username -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString (Username -> ByteString) -> Username -> ByteString
forall a b. (a -> b) -> a -> b
$ TokenRep -> Username
accessToken TokenRep
ret
    Left String
err2 -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m JWT
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m JWT) -> KCError -> KeycloakT m JWT
forall a b. (a -> b) -> a -> b
$ Username -> KCError
ParseError (Username -> KCError) -> Username -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Username
pack (String -> String
forall a. Show a => a -> String
show String
err2)


-- | Verify a JWT. If sucessful, the claims are returned. Otherwise, a JWTError is thrown. 
verifyJWT :: (MonadTime m, MonadIO m) => JWT -> KeycloakT m ClaimsSet
verifyJWT :: JWT -> KeycloakT m ClaimsSet
verifyJWT JWT
jwt = do
  [JWK]
jwks <- Getting [JWK] KCConfig [JWK] -> KeycloakT m [JWK]
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig Getting [JWK] KCConfig [JWK]
Lens' KCConfig [JWK]
confJWKs
  ReaderT KCConfig (ExceptT KCError m) ClaimsSet
-> KeycloakT m ClaimsSet
forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT (ReaderT KCConfig (ExceptT KCError m) ClaimsSet
 -> KeycloakT m ClaimsSet)
-> ReaderT KCConfig (ExceptT KCError m) ClaimsSet
-> KeycloakT m ClaimsSet
forall a b. (a -> b) -> a -> b
$ JWTValidationSettings
-> JWK -> JWT -> ReaderT KCConfig (ExceptT KCError m) ClaimsSet
forall (m :: * -> *) a e k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) ClaimsSet k) =>
a -> k -> JWT -> m ClaimsSet
verifyClaims ((StringOrURI -> Bool) -> JWTValidationSettings
defaultJWTValidationSettings (Bool -> StringOrURI -> Bool
forall a b. a -> b -> a
const Bool
True)) ([JWK] -> JWK
forall a. [a] -> a
head [JWK]
jwks) JWT
jwt

-- | Extract the user identity from a token. Additional attributes can be encoded in the token.
getClaimsUser :: ClaimsSet -> User
getClaimsUser :: ClaimsSet -> User
getClaimsUser ClaimsSet
claims = User :: Maybe UserId
-> Username
-> Maybe Username
-> Maybe Username
-> Maybe Username
-> Maybe (HashMap Username Value)
-> User
User { userId :: Maybe UserId
userId          = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId) -> UserId -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ Username -> UserId
UserId (Username -> UserId) -> Username -> UserId
forall a b. (a -> b) -> a -> b
$ Getting Username ClaimsSet Username -> ClaimsSet -> Username
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Maybe StringOrURI -> Const Username (Maybe StringOrURI))
-> ClaimsSet -> Const Username ClaimsSet
Lens' ClaimsSet (Maybe StringOrURI)
claimSub ((Maybe StringOrURI -> Const Username (Maybe StringOrURI))
 -> ClaimsSet -> Const Username ClaimsSet)
-> ((Username -> Const Username Username)
    -> Maybe StringOrURI -> Const Username (Maybe StringOrURI))
-> Getting Username ClaimsSet Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringOrURI -> Const Username StringOrURI)
-> Maybe StringOrURI -> Const Username (Maybe StringOrURI)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((StringOrURI -> Const Username StringOrURI)
 -> Maybe StringOrURI -> Const Username (Maybe StringOrURI))
-> ((Username -> Const Username Username)
    -> StringOrURI -> Const Username StringOrURI)
-> (Username -> Const Username Username)
-> Maybe StringOrURI
-> Const Username (Maybe StringOrURI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> Const Username Username)
-> StringOrURI -> Const Username StringOrURI
Prism' StringOrURI Username
string) ClaimsSet
claims
                            , userUsername :: Username
userUsername    = Getting Username ClaimsSet Username -> ClaimsSet -> Username
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Username Value -> Const Username (HashMap Username Value))
-> ClaimsSet -> Const Username ClaimsSet
Lens' ClaimsSet (HashMap Username Value)
unregisteredClaims ((HashMap Username Value
  -> Const Username (HashMap Username Value))
 -> ClaimsSet -> Const Username ClaimsSet)
-> ((Username -> Const Username Username)
    -> HashMap Username Value
    -> Const Username (HashMap Username Value))
-> Getting Username ClaimsSet Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Username Value)
-> Lens'
     (HashMap Username Value) (Maybe (IxValue (HashMap Username Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Username Value)
"preferred_username" ((Maybe Value -> Const Username (Maybe Value))
 -> HashMap Username Value
 -> Const Username (HashMap Username Value))
-> ((Username -> Const Username Username)
    -> Maybe Value -> Const Username (Maybe Value))
-> (Username -> Const Username Username)
-> HashMap Username Value
-> Const Username (HashMap Username Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const Username Value)
-> Maybe Value -> Const Username (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const Username Value)
 -> Maybe Value -> Const Username (Maybe Value))
-> ((Username -> Const Username Username)
    -> Value -> Const Username Value)
-> (Username -> Const Username Username)
-> Maybe Value
-> Const Username (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> Const Username Username)
-> Value -> Const Username Value
forall t. AsPrimitive t => Prism' t Username
_String) ClaimsSet
claims
                            , userFirstName :: Maybe Username
userFirstName   = Getting (First Username) ClaimsSet Username
-> ClaimsSet -> Maybe Username
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ClaimsSet -> Const (First Username) ClaimsSet
Lens' ClaimsSet (HashMap Username Value)
unregisteredClaims ((HashMap Username Value
  -> Const (First Username) (HashMap Username Value))
 -> ClaimsSet -> Const (First Username) ClaimsSet)
-> ((Username -> Const (First Username) Username)
    -> HashMap Username Value
    -> Const (First Username) (HashMap Username Value))
-> Getting (First Username) ClaimsSet Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Username Value)
-> Lens'
     (HashMap Username Value) (Maybe (IxValue (HashMap Username Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Username Value)
"given_name" ((Maybe Value -> Const (First Username) (Maybe Value))
 -> HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ((Username -> Const (First Username) Username)
    -> Maybe Value -> Const (First Username) (Maybe Value))
-> (Username -> Const (First Username) Username)
-> HashMap Username Value
-> Const (First Username) (HashMap Username Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Username) Value)
-> Maybe Value -> Const (First Username) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Username) Value)
 -> Maybe Value -> Const (First Username) (Maybe Value))
-> ((Username -> Const (First Username) Username)
    -> Value -> Const (First Username) Value)
-> (Username -> Const (First Username) Username)
-> Maybe Value
-> Const (First Username) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> Const (First Username) Username)
-> Value -> Const (First Username) Value
forall t. AsPrimitive t => Prism' t Username
_String) ClaimsSet
claims
                            , userLastName :: Maybe Username
userLastName    = Getting (First Username) ClaimsSet Username
-> ClaimsSet -> Maybe Username
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ClaimsSet -> Const (First Username) ClaimsSet
Lens' ClaimsSet (HashMap Username Value)
unregisteredClaims ((HashMap Username Value
  -> Const (First Username) (HashMap Username Value))
 -> ClaimsSet -> Const (First Username) ClaimsSet)
-> ((Username -> Const (First Username) Username)
    -> HashMap Username Value
    -> Const (First Username) (HashMap Username Value))
-> Getting (First Username) ClaimsSet Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Username Value)
-> Lens'
     (HashMap Username Value) (Maybe (IxValue (HashMap Username Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Username Value)
"family_name" ((Maybe Value -> Const (First Username) (Maybe Value))
 -> HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ((Username -> Const (First Username) Username)
    -> Maybe Value -> Const (First Username) (Maybe Value))
-> (Username -> Const (First Username) Username)
-> HashMap Username Value
-> Const (First Username) (HashMap Username Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Username) Value)
-> Maybe Value -> Const (First Username) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Username) Value)
 -> Maybe Value -> Const (First Username) (Maybe Value))
-> ((Username -> Const (First Username) Username)
    -> Value -> Const (First Username) Value)
-> (Username -> Const (First Username) Username)
-> Maybe Value
-> Const (First Username) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> Const (First Username) Username)
-> Value -> Const (First Username) Value
forall t. AsPrimitive t => Prism' t Username
_String) ClaimsSet
claims
                            , userEmail :: Maybe Username
userEmail       = Getting (First Username) ClaimsSet Username
-> ClaimsSet -> Maybe Username
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ClaimsSet -> Const (First Username) ClaimsSet
Lens' ClaimsSet (HashMap Username Value)
unregisteredClaims ((HashMap Username Value
  -> Const (First Username) (HashMap Username Value))
 -> ClaimsSet -> Const (First Username) ClaimsSet)
-> ((Username -> Const (First Username) Username)
    -> HashMap Username Value
    -> Const (First Username) (HashMap Username Value))
-> Getting (First Username) ClaimsSet Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Username Value)
-> Lens'
     (HashMap Username Value) (Maybe (IxValue (HashMap Username Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Username Value)
"email" ((Maybe Value -> Const (First Username) (Maybe Value))
 -> HashMap Username Value
 -> Const (First Username) (HashMap Username Value))
-> ((Username -> Const (First Username) Username)
    -> Maybe Value -> Const (First Username) (Maybe Value))
-> (Username -> Const (First Username) Username)
-> HashMap Username Value
-> Const (First Username) (HashMap Username Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Username) Value)
-> Maybe Value -> Const (First Username) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Username) Value)
 -> Maybe Value -> Const (First Username) (Maybe Value))
-> ((Username -> Const (First Username) Username)
    -> Value -> Const (First Username) Value)
-> (Username -> Const (First Username) Username)
-> Maybe Value
-> Const (First Username) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Username -> Const (First Username) Username)
-> Value -> Const (First Username) Value
forall t. AsPrimitive t => Prism' t Username
_String) ClaimsSet
claims
                            , userAttributes :: Maybe (HashMap Username Value)
userAttributes  = Getting
  (First (HashMap Username Value)) ClaimsSet (HashMap Username Value)
-> ClaimsSet -> Maybe (HashMap Username Value)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting
  (First (HashMap Username Value)) ClaimsSet (HashMap Username Value)
Lens' ClaimsSet (HashMap Username Value)
unregisteredClaims ClaimsSet
claims}


-- | return JWKs from Keycloak. Its a set of keys that can be used to check signed tokens (JWTs)
-- This is done for you in the 'configureKeycloak' function. JWKs are stored in the Keycloak State Monad.
getJWKs :: Realm -> ServerURL -> IO [JWK]
getJWKs :: Username -> Username -> IO [JWK]
getJWKs Username
realm Username
baseUrl = do
  let opts :: Options
opts = Options
W.defaults
  let url :: String
url = Username -> String
unpack (Username
baseUrl Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Username
"/realms/" Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Username
realm Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Username
"/protocol/openid-connect/certs")
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Issuing KEYCLOAK GET with url: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
url
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  headers: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Header] -> String
forall a. Show a => a -> String
show (Options
opts Options -> Getting [Header] Options [Header] -> [Header]
forall s a. s -> Getting a s a -> a
^. Getting [Header] Options [Header]
Lens' Options [Header]
W.headers)
  Response ByteString
res <- Options -> String -> IO (Response ByteString)
W.getWith Options
opts String
url
  let body :: ByteString
body = Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString
res Response ByteString
-> Getting (First ByteString) (Response ByteString) ByteString
-> Maybe ByteString
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First ByteString) (Response ByteString) ByteString
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
body
  case ByteString -> Either String JWKSet
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
     Right (JWKSet [JWK]
jwks) -> [JWK] -> IO [JWK]
forall (m :: * -> *) a. Monad m => a -> m a
return [JWK]
jwks
     Left (String
err2 :: String) -> do
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err2
       String -> IO [JWK]
forall a. HasCallStack => String -> a
error (String -> IO [JWK]) -> String -> IO [JWK]
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
err2