{-# 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)

-- * Tokens

-- | return JWKs from Keycloak. Its a set of keys that can be used to check signed tokens (JWTs)
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


-- | Retrieve the user's token. This token can be used for every other Keycloak calls.
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)

-- | return a Client token (linked to a Client, not a User). It is useful to create Resources in that Client in Keycloak.
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)


-- | Verify a JWT. If sucessful, the claims are returned. Otherwise, a JWTError is thrown. 
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

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