{-# 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 :: forall (m :: * -> *). MonadIO m => Text -> Text -> KeycloakT m JWT
getJWT Text
username Text
password = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug [Char]
"Get user token"
  Text
client <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig Text
confResource
  Text
secret <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig ClientCredentials
confCredentialsforall b c a. (b -> c) -> (a -> b) -> a -> c
.Iso' ClientCredentials Text
confSecret
  let dat :: [FormParam]
dat = [ByteString
"client_id" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client, 
             ByteString
"client_secret" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
secret,
             ByteString
"grant_type" forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"password" :: Text),
             ByteString
"password" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
password,
             ByteString
"username" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
username]
  ByteString
body <- forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Text -> dat -> KeycloakT m ByteString
keycloakPost' Text
"protocol/openid-connect/token" [FormParam]
dat
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show ByteString
body) 
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
    Right TokenRep
ret -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak success: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show TokenRep
ret) 
      forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT forall a b. (a -> b) -> a -> b
$ forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
convertString forall a b. (a -> b) -> a -> b
$ TokenRep -> Text
accessToken TokenRep
ret
    Left [Char]
err2 -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Char]
err2) 
      forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (forall a. Show a => a -> [Char]
show [Char]
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 :: forall (m :: * -> *). MonadIO m => KeycloakT m JWT
getClientJWT = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug [Char]
"Get client token"
  Text
client <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig Text
confResource
  Text
secret <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig ClientCredentials
confCredentialsforall b c a. (b -> c) -> (a -> b) -> a -> c
.Iso' ClientCredentials Text
confSecret
  let dat :: [FormParam]
dat = [ByteString
"client_id" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client, 
             ByteString
"client_secret" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
secret,
             ByteString
"grant_type" forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"client_credentials" :: Text)]
  ByteString
body <- forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Text -> dat -> KeycloakT m ByteString
keycloakPost' Text
"protocol/openid-connect/token" [FormParam]
dat
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
    Right TokenRep
ret -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak success: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show TokenRep
ret) 
      forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT forall a b. (a -> b) -> a -> b
$ forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
convertString forall a b. (a -> b) -> a -> b
$ TokenRep -> Text
accessToken TokenRep
ret
    Left [Char]
err2 -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Char]
err2) 
      forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (forall a. Show a => a -> [Char]
show [Char]
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 :: forall (m :: * -> *).
(MonadTime m, MonadIO m) =>
JWT -> KeycloakT m ClaimsSet
verifyJWT JWT
jwt = do
  [JWK]
jwks <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig Lens' KCConfig [JWK]
confJWKs
  forall (m :: * -> *) a.
ReaderT KCConfig (ExceptT KCError m) a -> KeycloakT m a
KeycloakT forall a b. (a -> b) -> a -> b
$ 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 (forall a b. a -> b -> a
const Bool
True)) (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 { userId :: Maybe UserId
userId          = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> UserId
UserId forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasClaimsSet a => Lens' a (Maybe StringOrURI)
claimSub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' StringOrURI Text
string) ClaimsSet
claims
                            , userUsername :: Text
userUsername    = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClaimsSet (Map Text Value)
unregisteredClaims forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
"preferred_username" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String) ClaimsSet
claims
                            , userFirstName :: Maybe Text
userFirstName   = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' ClaimsSet (Map Text Value)
unregisteredClaims forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
"given_name" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String) ClaimsSet
claims
                            , userLastName :: Maybe Text
userLastName    = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' ClaimsSet (Map Text Value)
unregisteredClaims forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
"family_name" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String) ClaimsSet
claims
                            , userEmail :: Maybe Text
userEmail       = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' ClaimsSet (Map Text Value)
unregisteredClaims forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
"email" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String) ClaimsSet
claims
                            , userAttributes :: Maybe (Map Text Value)
userAttributes  = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Lens' ClaimsSet (Map Text 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 :: Text -> Text -> IO [JWK]
getJWKs Text
realm Text
baseUrl = do
  let opts :: Options
opts = Options
W.defaults
  let url :: [Char]
url = Text -> [Char]
unpack (Text
baseUrl forall a. Semigroup a => a -> a -> a
<> Text
"/realms/" forall a. Semigroup a => a -> a -> a
<> Text
realm forall a. Semigroup a => a -> a -> a
<> Text
"/protocol/openid-connect/certs")
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
info forall a b. (a -> b) -> a -> b
$ [Char]
"Issuing KEYCLOAK GET with url: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
url
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"  headers: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Options
opts forall s a. s -> Getting a s a -> a
^. Lens' Options [Header]
W.headers)
  Response ByteString
res <- Options -> [Char] -> IO (Response ByteString)
W.getWith Options
opts [Char]
url
  let body :: ByteString
body = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Response ByteString
res forall s a. s -> Getting (First a) s a -> Maybe a
^? forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
info forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ByteString
body
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
     Right (JWKSet [JWK]
jwks) -> forall (m :: * -> *) a. Monad m => a -> m a
return [JWK]
jwks
     Left ([Char]
err2 :: String) -> do
       forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
err2
       forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show [Char]
err2