{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Keycloak.Tokens where
import Control.Lens hiding ((.=))
import Control.Monad.Reader as R
import Control.Monad.Except (throwError)
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 qualified Data.HashMap.Strict as HM
import Data.String.Conversions
import Keycloak.Types
import Keycloak.Utils
import Network.Wreq as W hiding (statusCode)
getJWKs :: Keycloak [JWK]
getJWKs :: Keycloak [JWK]
getJWKs = do
ByteString
body <- Path -> Keycloak ByteString
keycloakGet' (Path
"protocol/openid-connect/certs")
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
info (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
body
(JWKSet [JWK]
jwks) <- case ByteString -> Either String JWKSet
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
Right JWKSet
ret -> do
JWKSet -> ReaderT KCConfig (ExceptT KCError IO) JWKSet
forall (m :: * -> *) a. Monad m => a -> m a
return JWKSet
ret
Left (String
err2 :: String) -> do
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError 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)
KCError -> ReaderT KCConfig (ExceptT KCError IO) JWKSet
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> ReaderT KCConfig (ExceptT KCError IO) JWKSet)
-> KCError -> ReaderT KCConfig (ExceptT KCError IO) JWKSet
forall a b. (a -> b) -> a -> b
$ Path -> KCError
ParseError (Path -> KCError) -> Path -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Path
pack (String -> String
forall a. Show a => a -> String
show String
err2)
[JWK] -> Keycloak [JWK]
forall (m :: * -> *) a. Monad m => a -> m a
return [JWK]
jwks
getJWT :: Username -> Password -> Keycloak JWT
getJWT :: Path -> Path -> Keycloak JWT
getJWT Path
username Path
password = do
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get user token"
Path
client <- (KCConfig -> Path) -> ReaderT KCConfig (ExceptT KCError IO) Path
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Path
_confClientId
Path
secret <- (KCConfig -> Path) -> ReaderT KCConfig (ExceptT KCError IO) Path
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Path
_confClientSecret
let dat :: [FormParam]
dat = [ByteString
"client_id" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
client,
ByteString
"client_secret" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
secret,
ByteString
"grant_type" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Path
"password" :: Text),
ByteString
"password" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
password,
ByteString
"username" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
username]
ByteString
body <- Path -> [FormParam] -> Keycloak ByteString
forall dat.
(Postable dat, Show dat) =>
Path -> dat -> Keycloak ByteString
keycloakPost' Path
"protocol/openid-connect/token" [FormParam]
dat
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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)
ByteString -> Keycloak JWT
forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact (ByteString -> Keycloak JWT) -> ByteString -> Keycloak JWT
forall a b. (a -> b) -> a -> b
$ Path -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString (Path -> ByteString) -> Path -> ByteString
forall a b. (a -> b) -> a -> b
$ TokenRep -> Path
accessToken TokenRep
ret
Left String
err2 -> do
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError 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)
KCError -> Keycloak JWT
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak JWT) -> KCError -> Keycloak JWT
forall a b. (a -> b) -> a -> b
$ Path -> KCError
ParseError (Path -> KCError) -> Path -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Path
pack (String -> String
forall a. Show a => a -> String
show String
err2)
getClientJWT :: Keycloak JWT
getClientJWT :: Keycloak JWT
getClientJWT = do
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get client token"
Path
client <- (KCConfig -> Path) -> ReaderT KCConfig (ExceptT KCError IO) Path
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Path
_confClientId
Path
secret <- (KCConfig -> Path) -> ReaderT KCConfig (ExceptT KCError IO) Path
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Path
_confClientSecret
let dat :: [FormParam]
dat = [ByteString
"client_id" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
client,
ByteString
"client_secret" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Path
secret,
ByteString
"grant_type" ByteString -> Path -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Path
"client_credentials" :: Text)]
ByteString
body <- Path -> [FormParam] -> Keycloak ByteString
forall dat.
(Postable dat, Show dat) =>
Path -> dat -> Keycloak ByteString
keycloakPost' Path
"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 -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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)
ByteString -> Keycloak JWT
forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact (ByteString -> Keycloak JWT) -> ByteString -> Keycloak JWT
forall a b. (a -> b) -> a -> b
$ Path -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString (Path -> ByteString) -> Path -> ByteString
forall a b. (a -> b) -> a -> b
$ TokenRep -> Path
accessToken TokenRep
ret
Left String
err2 -> do
String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError 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)
KCError -> Keycloak JWT
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak JWT) -> KCError -> Keycloak JWT
forall a b. (a -> b) -> a -> b
$ Path -> KCError
ParseError (Path -> KCError) -> Path -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Path
pack (String -> String
forall a. Show a => a -> String
show String
err2)
verifyJWT :: JWK -> JWT -> Keycloak ClaimsSet
verifyJWT :: JWK -> JWT -> Keycloak ClaimsSet
verifyJWT JWK
jwk JWT
jwt = JWTValidationSettings -> JWK -> JWT -> Keycloak 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 JWT
jwt
getClaimsUser :: ClaimsSet -> User
getClaimsUser :: ClaimsSet -> User
getClaimsUser ClaimsSet
claims = User :: Maybe UserId
-> Path
-> Maybe Path
-> Maybe Path
-> Maybe Path
-> Maybe (HashMap Path 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
$ Path -> UserId
UserId (Path -> UserId) -> Path -> UserId
forall a b. (a -> b) -> a -> b
$ Getting Path ClaimsSet Path -> ClaimsSet -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Maybe StringOrURI -> Const Path (Maybe StringOrURI))
-> ClaimsSet -> Const Path ClaimsSet
Lens' ClaimsSet (Maybe StringOrURI)
claimSub ((Maybe StringOrURI -> Const Path (Maybe StringOrURI))
-> ClaimsSet -> Const Path ClaimsSet)
-> ((Path -> Const Path Path)
-> Maybe StringOrURI -> Const Path (Maybe StringOrURI))
-> Getting Path ClaimsSet Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringOrURI -> Const Path StringOrURI)
-> Maybe StringOrURI -> Const Path (Maybe StringOrURI)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((StringOrURI -> Const Path StringOrURI)
-> Maybe StringOrURI -> Const Path (Maybe StringOrURI))
-> ((Path -> Const Path Path)
-> StringOrURI -> Const Path StringOrURI)
-> (Path -> Const Path Path)
-> Maybe StringOrURI
-> Const Path (Maybe StringOrURI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path) -> StringOrURI -> Const Path StringOrURI
Prism' StringOrURI Path
string) ClaimsSet
claims
, userUsername :: Path
userUsername = Getting Path ClaimsSet Path -> ClaimsSet -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Path Value -> Const Path (HashMap Path Value))
-> ClaimsSet -> Const Path ClaimsSet
Lens' ClaimsSet (HashMap Path Value)
unregisteredClaims ((HashMap Path Value -> Const Path (HashMap Path Value))
-> ClaimsSet -> Const Path ClaimsSet)
-> ((Path -> Const Path Path)
-> HashMap Path Value -> Const Path (HashMap Path Value))
-> Getting Path ClaimsSet Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Path Value)
-> Lens'
(HashMap Path Value) (Maybe (IxValue (HashMap Path Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Path Value)
"preferred_username" ((Maybe Value -> Const Path (Maybe Value))
-> HashMap Path Value -> Const Path (HashMap Path Value))
-> ((Path -> Const Path Path)
-> Maybe Value -> Const Path (Maybe Value))
-> (Path -> Const Path Path)
-> HashMap Path Value
-> Const Path (HashMap Path Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const Path Value)
-> Maybe Value -> Const Path (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const Path Value)
-> Maybe Value -> Const Path (Maybe Value))
-> ((Path -> Const Path Path) -> Value -> Const Path Value)
-> (Path -> Const Path Path)
-> Maybe Value
-> Const Path (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path) -> Value -> Const Path Value
forall t. AsPrimitive t => Prism' t Path
_String) ClaimsSet
claims
, userFirstName :: Maybe Path
userFirstName = Getting (First Path) ClaimsSet Path -> ClaimsSet -> Maybe Path
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet
Lens' ClaimsSet (HashMap Path Value)
unregisteredClaims ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet)
-> ((Path -> Const (First Path) Path)
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> Getting (First Path) ClaimsSet Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Path Value)
-> Lens'
(HashMap Path Value) (Maybe (IxValue (HashMap Path Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Path Value)
"given_name" ((Maybe Value -> Const (First Path) (Maybe Value))
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ((Path -> Const (First Path) Path)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> (Path -> Const (First Path) Path)
-> HashMap Path Value
-> Const (First Path) (HashMap Path Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> ((Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value)
-> (Path -> Const (First Path) Path)
-> Maybe Value
-> Const (First Path) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value
forall t. AsPrimitive t => Prism' t Path
_String) ClaimsSet
claims
, userLastName :: Maybe Path
userLastName = Getting (First Path) ClaimsSet Path -> ClaimsSet -> Maybe Path
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet
Lens' ClaimsSet (HashMap Path Value)
unregisteredClaims ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet)
-> ((Path -> Const (First Path) Path)
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> Getting (First Path) ClaimsSet Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Path Value)
-> Lens'
(HashMap Path Value) (Maybe (IxValue (HashMap Path Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Path Value)
"family_name" ((Maybe Value -> Const (First Path) (Maybe Value))
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ((Path -> Const (First Path) Path)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> (Path -> Const (First Path) Path)
-> HashMap Path Value
-> Const (First Path) (HashMap Path Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> ((Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value)
-> (Path -> Const (First Path) Path)
-> Maybe Value
-> Const (First Path) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value
forall t. AsPrimitive t => Prism' t Path
_String) ClaimsSet
claims
, userEmail :: Maybe Path
userEmail = Getting (First Path) ClaimsSet Path -> ClaimsSet -> Maybe Path
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet
Lens' ClaimsSet (HashMap Path Value)
unregisteredClaims ((HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ClaimsSet -> Const (First Path) ClaimsSet)
-> ((Path -> Const (First Path) Path)
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> Getting (First Path) ClaimsSet Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Path Value)
-> Lens'
(HashMap Path Value) (Maybe (IxValue (HashMap Path Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Path Value)
"email" ((Maybe Value -> Const (First Path) (Maybe Value))
-> HashMap Path Value -> Const (First Path) (HashMap Path Value))
-> ((Path -> Const (First Path) Path)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> (Path -> Const (First Path) Path)
-> HashMap Path Value
-> Const (First Path) (HashMap Path Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First Path) Value)
-> Maybe Value -> Const (First Path) (Maybe Value))
-> ((Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value)
-> (Path -> Const (First Path) Path)
-> Maybe Value
-> Const (First Path) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const (First Path) Path)
-> Value -> Const (First Path) Value
forall t. AsPrimitive t => Prism' t Path
_String) ClaimsSet
claims
, userAttributes :: Maybe (HashMap Path Value)
userAttributes = Getting (First (HashMap Path Value)) ClaimsSet (HashMap Path Value)
-> ClaimsSet -> Maybe (HashMap Path Value)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First (HashMap Path Value)) ClaimsSet (HashMap Path Value)
Lens' ClaimsSet (HashMap Path Value)
unregisteredClaims ClaimsSet
claims}