diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,7 @@ Keycloak-hs is an Haskell library for connecting to [Keycloak](https://www.keycloak.org/). Keycloak allows to authenticate users and protect API resources. +This library allows you to retrieve and analyse Keycloak authentication tokens, and to protect resources in your API. Install ======= @@ -15,25 +16,39 @@ Tutorial ======== -In this tutorial we'll learn how to use Keycloak-hs with a [small example](./example/Main.hs). +In this tutorial we'll learn how to use Keycloak-hs with a [small example](./examples/Main.hs). First you should install and run Keycloak: [follow this tutorial](https://www.keycloak.org/docs/latest/getting_started/index.html). + +Authentication +-------------- + +Authentication with Keycloak is based on [JWTs](https://jwt.io/). + In Keycloak admin panel, create the following: - a realm named "demo" -- a user "demo" with password "demo" - a client named "demo". +- a user "demo" with password "demo" +In the user, add an attribute, such as "phone". +In order for this attribute to appear in the token claims, we should also add a client "mapper". +In the client "demo", click on "Mappers"/"add mappers". +Fill the name="demo", Mapper Type=User attribute, Token Claim Name="demo", Claim JSON Type=String, and save. + +At this point, you should be able to retrieve tokens from Keycloak, verify them using this library, and extract a User from the tokens. + +Authorizations +-------------- + In the client "demo": - change "Access Type" to confidential - turn "Authorization Enabled" ON. A new "Authorization" tab should appear. -Authorizations --------------- - Let's set up some authorization policies in order to demonstrate the capacity of Keycloak-hs. We want to authorize our user "demo" to "view" any resource. -Frist go in the new "Authorization" tab that appeared. +First go in the new "Authorization" tab that appeared. +Flip ON "Remote Resource Management". Create a new Scope in the "Authorization Scopes" tab: - Name it "view". @@ -53,7 +68,7 @@ Example code ----------- -The folder example contains an [exemple of usage](./example/Main.hs). +The folder example contains an [exemple of usage](./examples/Main.hs). You should first input your "client secret", that can be found in the demo client "Credentials" tab in Keycloak admin panel. Then run the example: diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -5,51 +5,75 @@ import Keycloak import Control.Monad import Control.Monad.IO.Class +import System.Log.Logger + -- Kecyloak configuration. kcConfig :: KCConfig kcConfig = KCConfig { _confBaseUrl = "http://localhost:8080/auth", _confRealm = "demo", _confClientId = "demo", - _confClientSecret = "4270ce82-4a8f-4d89-9ea9-d9b28c3bab3e"} + _confClientSecret = "3d792576-4e56-4c58-991a-49074e6a92ea"} main :: IO () -main = void $ flip runKeycloak kcConfig $ do - - liftIO $ putStrLn "Getting Client token" - - -- * We first get a client token, used to create resources - clientToken <- getClientAuthToken - - liftIO $ putStrLn "Creating resource" - - -- * We will than create a resource to be protected in Keycloak - let res = Resource { - resId = Nothing, - resName = "MyResource", - resType = Nothing, - resUris = [], - resScopes = [Scope Nothing (ScopeName "view")], - resOwner = Owner Nothing (Just "demo"), - resOwnerManagedAccess = False, - resAttributes = []} - resId <- createResource res clientToken - - liftIO $ putStrLn "Getting User token" - - -- * Let's get a token for a specific user - userToken <- getUserAuthToken "demo" "demo" - - -- * Can I access this resource? - isAuth <- isAuthorized resId (ScopeName "view") userToken - - liftIO $ putStrLn $ "User 'demo' can access resource 'demo': " ++ (show isAuth) - - -- We can also retrieve all the permissions for our user. - perms <- getPermissions [PermReq Nothing [ScopeName "view"]] userToken - - liftIO $ putStrLn $ "All permissions: " ++ (show perms) +main = do + updateGlobalLogger rootLoggerName (setLevel DEBUG) - --resources can be deleted - --deleteResource resId clientToken + void $ flip runKeycloak kcConfig $ do + liftIO $ putStrLn "Starting tests..." + + -- JWKs are public keys delivered by Keycloak to check the integrity of any JWT (user tokens). + -- an application may retrieve these keys at startup and keep them. + jwks <- getJWKs + liftIO $ putStrLn $ "Got JWKs: \n" ++ (show jwks) ++ "\n\n" + + -- Get a JWT from Keycloak. A JWT can then be used to authentify 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 (head jwks) 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" + + + liftIO $ putStrLn "Getting Client token" + + -- * We first get a client token, used to create resources + clientToken <- getClientJWT + + liftIO $ putStrLn "Creating resource" + + -- * We will than create a resource to be protected in Keycloak + let res = Resource { + resId = Nothing, + resName = "MyResource", + resType = Nothing, + resUris = [], + resScopes = [Scope Nothing (ScopeName "view")], + resOwner = Owner Nothing (Just "demo"), + resOwnerManagedAccess = False, + resAttributes = []} + resId <- createResource res clientToken + + liftIO $ putStrLn "Getting User token" + + -- * Let's get a token for a specific user + userToken <- getJWT "demo" "demo" + + -- * Can I access this resource? + isAuth <- isAuthorized resId (ScopeName "view") userToken + + liftIO $ putStrLn $ "User 'demo' can access resource 'demo': " ++ (show isAuth) + + -- We can also retrieve all the permissions for our user. + perms <- getPermissions [PermReq Nothing [ScopeName "view"]] userToken + + liftIO $ putStrLn $ "All permissions: " ++ (show perms) + + --resources can be deleted + --deleteResource resId clientToken diff --git a/keycloak-hs.cabal b/keycloak-hs.cabal --- a/keycloak-hs.cabal +++ b/keycloak-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: keycloak-hs -version: 1.1.1 +version: 2.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Corentin Dupont @@ -21,7 +21,10 @@ library exposed-modules: - Keycloak.Client + Keycloak.Tokens + Keycloak.Authorizations + Keycloak.Users + Keycloak.Utils Keycloak.Types Keycloak hs-source-dirs: src @@ -36,16 +39,19 @@ containers >=0.5.9 && <0.7, bytestring >=0.10 && <0.11, exceptions >=0.10 && <0.11, + hashable -any, http-api-data >=0.4 && <0.5, http-types >=0.12 && <0.13, http-client >=0.5 && <0.7, hslogger >=1.2 && <1.4, - jwt ==0.10.*, + jose, lens >=4.17 && <4.19, + lens-aeson, mtl >=2.2 && <2.3, string-conversions >=0.4 && <0.5, safe >=0.3 && <0.4, text >=1.2 && <1.3, + unordered-containers, wreq >=0.5 && <0.6, word8 >=0.1 && <0.2 @@ -56,4 +62,5 @@ ghc-options: -threaded -Wall build-depends: base >=4.9.1.0 && <5, - keycloak-hs -any + keycloak-hs -any, + hslogger -any diff --git a/src/Keycloak.hs b/src/Keycloak.hs --- a/src/Keycloak.hs +++ b/src/Keycloak.hs @@ -1,21 +1,28 @@ - -module Keycloak (isAuthorized, - getPermissions, - checkPermission, - getUserAuthToken, - getClientAuthToken, - getUsername, - createResource, - deleteResource, - deleteAllResources, - getResource, - getAllResourceIds, - updateResource, - getUsers, - getUser, - createUser, - updateUser, - module Keycloak.Types) where +module Keycloak ( + -- | Tokens + getJWKs, + getJWT, + getClientJWT, + verifyJWT, + getClaimsUser, + isAuthorized, + -- | Authorizations + getPermissions, + checkPermission, + createResource, + deleteResource, + deleteAllResources, + getResource, + getAllResourceIds, + updateResource, + -- | Users + getUsers, + getUser, + createUser, + updateUser, + module Keycloak.Types) where -import Keycloak.Client +import Keycloak.Tokens +import Keycloak.Users +import Keycloak.Authorizations import Keycloak.Types diff --git a/src/Keycloak/Authorizations.hs b/src/Keycloak/Authorizations.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Authorizations.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Keycloak.Authorizations where + +import Control.Monad.Reader as R +import Control.Monad.Except (throwError) +import Data.Aeson as JSON +import Data.Text as T hiding (head, tail, map) +import Data.Either +import Data.List as L +import Data.String.Conversions +import Keycloak.Types +import Keycloak.Tokens +import Keycloak.Utils as U +import Network.HTTP.Types.Status +import Network.Wreq as W hiding (statusCode) +import Safe + +-- * Permissions + +-- | Returns true if the resource is authorized under the given scope. +isAuthorized :: ResourceId -> ScopeName -> JWT -> Keycloak Bool +isAuthorized res scope tok = do + r <- U.try $ checkPermission res scope tok + case r of + Right _ -> return True + Left e | (statusCode <$> U.getErrorStatus e) == Just 403 -> return False + Left e -> throwError e --rethrow the error + +-- | Return the permissions for the permission requests. +getPermissions :: [PermReq] -> JWT -> Keycloak [Permission] +getPermissions reqs tok = do + debug "Get all permissions" + client <- asks _confClientId + let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), + "audience" := client, + "response_mode" := ("permissions" :: Text)] + <> map (\p -> "permission" := p) (join $ map getPermString reqs) + body <- keycloakPost "protocol/openid-connect/token" dat tok + case eitherDecode body of + Right ret -> do + debug $ "Keycloak returned perms: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + where + getPermString :: PermReq -> [Text] + getPermString (PermReq (Just (ResourceId rid)) []) = [rid] + getPermString (PermReq (Just (ResourceId rid)) scopes) = map (\(ScopeName s) -> (rid <> "#" <> s)) scopes + getPermString (PermReq Nothing scopes) = map (\(ScopeName s) -> ("#" <> s)) scopes + +-- | Checks if a scope is permitted on a resource. An HTTP Exception 403 will be thrown if not. +checkPermission :: ResourceId -> ScopeName -> JWT -> Keycloak () +checkPermission (ResourceId res) (ScopeName scope) tok = do + debug $ "Checking permissions: " ++ (show res) ++ " " ++ (show scope) + client <- asks _confClientId + let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), + "audience" := client, + "permission" := res <> "#" <> scope] + void $ keycloakPost "protocol/openid-connect/token" dat tok + + +-- * Resource + +-- | Create an authorization resource in Keycloak, under the configured client. +createResource :: Resource -> JWT -> Keycloak ResourceId +createResource r tok = do + debug $ convertString $ "Creating resource: " <> (JSON.encode r) + body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok + debug $ convertString $ "Created resource: " ++ convertString body + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return $ fromJustNote "create" $ resId ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +-- | Delete the resource +deleteResource :: ResourceId -> JWT -> Keycloak () +deleteResource (ResourceId rid) tok = do + --tok2 <- getClientAuthToken + keycloakDelete ("authz/protection/resource_set/" <> rid) tok + return () + +-- | Delete all resources in Keycloak +deleteAllResources :: JWT -> Keycloak () +deleteAllResources tok = do + debug "Deleting all Keycloak resources..." + ids <- getAllResourceIds + res <- mapM (\rid -> try $ deleteResource rid tok) ids + debug $ "Deleted " ++ (show $ L.length $ rights res) ++ " resources out of " ++ (show $ L.length ids) + +-- | get a single resource +getResource :: ResourceId -> JWT -> Keycloak Resource +getResource (ResourceId rid) tok = do + body <- keycloakGet ("authz/protection/resource_set/" <> rid) tok + case eitherDecode body of + Right ret -> do + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +-- | get all resources IDs +getAllResourceIds :: Keycloak [ResourceId] +getAllResourceIds = do + debug "Get all resources" + tok2 <- getClientJWT + body <- keycloakGet ("authz/protection/resource_set?max=1000") tok2 + case eitherDecode body of + Right ret -> do + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +-- | Update a resource +updateResource :: Resource -> JWT -> Keycloak ResourceId +updateResource = createResource + diff --git a/src/Keycloak/Client.hs b/src/Keycloak/Client.hs deleted file mode 100644 --- a/src/Keycloak/Client.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -module Keycloak.Client where - -import Control.Lens hiding ((.=)) -import Control.Monad.Reader as R -import qualified Control.Monad.Catch as C -import Control.Monad.Except (throwError, catchError, MonadError) -import Data.Aeson as JSON -import Data.Text as T hiding (head, tail, map) -import Data.Maybe -import Data.Either -import Data.List as L -import Data.Map hiding (map, lookup) -import Data.String.Conversions -import qualified Data.ByteString.Lazy as BL -import Keycloak.Types -import Network.HTTP.Client as HC hiding (responseBody, path) -import Network.HTTP.Types.Status -import Network.HTTP.Types (renderQuery) -import Network.Wreq as W hiding (statusCode) -import Network.Wreq.Types -import System.Log.Logger -import Web.JWT as JWT -import Safe - --- * Permissions - --- | Returns true if the resource is authorized under the given scope. -isAuthorized :: ResourceId -> ScopeName -> Token -> Keycloak Bool -isAuthorized res scope tok = do - r <- try $ checkPermission res scope tok - case r of - Right _ -> return True - Left e | (statusCode <$> getErrorStatus e) == Just 403 -> return False - Left e -> throwError e --rethrow the error - --- | Return the permissions for the permission requests. -getPermissions :: [PermReq] -> Token -> Keycloak [Permission] -getPermissions reqs tok = do - debug "Get all permissions" - client <- asks _confClientId - let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), - "audience" := client, - "response_mode" := ("permissions" :: Text)] - <> map (\p -> "permission" := p) (join $ map getPermString reqs) - body <- keycloakPost "protocol/openid-connect/token" dat tok - case eitherDecode body of - Right ret -> do - debug $ "Keycloak returned perms: " ++ (show ret) - return ret - Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - where - getPermString :: PermReq -> [Text] - getPermString (PermReq (Just (ResourceId rid)) []) = [rid] - getPermString (PermReq (Just (ResourceId rid)) scopes) = map (\(ScopeName s) -> (rid <> "#" <> s)) scopes - getPermString (PermReq Nothing scopes) = map (\(ScopeName s) -> ("#" <> s)) scopes - --- | Checks if a scope is permitted on a resource. An HTTP Exception 403 will be thrown if not. -checkPermission :: ResourceId -> ScopeName -> Token -> Keycloak () -checkPermission (ResourceId res) (ScopeName scope) tok = do - debug $ "Checking permissions: " ++ (show res) ++ " " ++ (show scope) - client <- asks _confClientId - let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), - "audience" := client, - "permission" := res <> "#" <> scope] - void $ keycloakPost "protocol/openid-connect/token" dat tok - - --- * Tokens - --- | Retrieve the user's token. This token will be used for every other Keycloak calls. -getUserAuthToken :: Username -> Password -> Keycloak Token -getUserAuthToken username password = do - debug "Get user token" - client <- asks _confClientId - secret <- asks _confClientSecret - let dat = ["client_id" := client, - "client_secret" := secret, - "grant_type" := ("password" :: Text), - "password" := password, - "username" := username] - body <- keycloakPost' "protocol/openid-connect/token" dat - debug $ "Keycloak: " ++ (show body) - case eitherDecode body of - Right ret -> do - debug $ "Keycloak success: " ++ (show ret) - return $ Token $ convertString $ accessToken ret - Left err2 -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | return a Client token. It is useful to create Resources. -getClientAuthToken :: Keycloak Token -getClientAuthToken = do - debug "Get client token" - client <- asks _confClientId - secret <- asks _confClientSecret - let dat = ["client_id" := client, - "client_secret" := secret, - "grant_type" := ("client_credentials" :: Text)] - body <- keycloakPost' "protocol/openid-connect/token" dat - case eitherDecode body of - Right ret -> do - debug $ "Keycloak success: " ++ (show ret) - return $ Token $ convertString $ accessToken ret - Left err2 -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - - --- | Extract user name from a token -getUsername :: Token -> Username -getUsername (Token tok) = do - case JWT.decode $ convertString tok of - Just t -> case (unClaimsMap $ unregisteredClaims $ claims t) !? "preferred_username" of - Just (String u) -> u - _ -> error "preferred_username not present in token" - Nothing -> error "Error while decoding token" - - --- * Resource - --- | Create an authorization resource in Keycloak, under the configured client. -createResource :: Resource -> Token -> Keycloak ResourceId -createResource r tok = do - debug $ convertString $ "Creating resource: " <> (JSON.encode r) - body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok - debug $ convertString $ "Created resource: " ++ convertString body - case eitherDecode body of - Right ret -> do - debug $ "Keycloak success: " ++ (show ret) - return $ fromJustNote "create" $ resId ret - Left err2 -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | Delete the resource -deleteResource :: ResourceId -> Token -> Keycloak () -deleteResource (ResourceId rid) tok = do - --tok2 <- getClientAuthToken - keycloakDelete ("authz/protection/resource_set/" <> rid) tok - return () - --- | Delete all resources in Keycloak -deleteAllResources :: Token -> Keycloak () -deleteAllResources tok = do - debug "Deleting all Keycloak resources..." - ids <- getAllResourceIds - res <- mapM (\rid -> try $ deleteResource rid tok) ids - debug $ "Deleted " ++ (show $ L.length $ rights res) ++ " resources out of " ++ (show $ L.length ids) - --- | get a single resource -getResource :: ResourceId -> Token -> Keycloak Resource -getResource (ResourceId rid) tok = do - body <- keycloakGet ("authz/protection/resource_set/" <> rid) tok - case eitherDecode body of - Right ret -> do - return ret - Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | get all resources IDs -getAllResourceIds :: Keycloak [ResourceId] -getAllResourceIds = do - debug "Get all resources" - tok2 <- getClientAuthToken - body <- keycloakGet ("authz/protection/resource_set?max=1000") tok2 - case eitherDecode body of - Right ret -> do - return ret - Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | Update a resource -updateResource :: Resource -> Token -> Keycloak ResourceId -updateResource = createResource - --- * Users - --- | Get users. Default number of users is 100. Parameters max and first allow to paginate and retrieve more than 100 users. -getUsers :: Maybe Max -> Maybe First -> Maybe Username -> Token -> Keycloak [User] -getUsers mmax first username tok = do - let query = maybe [] (\m -> [("max", Just $ convertString $ show m)]) mmax - ++ maybe [] (\f -> [("first", Just $ convertString $ show f)]) first - ++ maybe [] (\u -> [("username", Just $ convertString u)]) username - body <- keycloakAdminGet ("users" <> (convertString $ renderQuery True query)) tok - debug $ "Keycloak success" - case eitherDecode body of - Right ret -> do - debug $ "Keycloak success: " ++ (show ret) - return ret - Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | Get a single user, based on his Id -getUser :: UserId -> Token -> Keycloak User -getUser (UserId uid) tok = do - body <- keycloakAdminGet ("users/" <> (convertString uid)) tok - debug $ "Keycloak success: " ++ (show body) - case eitherDecode body of - Right ret -> do - debug $ "Keycloak success: " ++ (show ret) - return ret - Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) - --- | Create a user -createUser :: User -> Token -> Keycloak UserId -createUser user tok = do - res <- keycloakAdminPost ("users/") (toJSON user) tok - debug $ "Keycloak success: " ++ (show res) - return $ UserId $ convertString res - --- | Get a single user, based on his Id -updateUser :: UserId -> User -> Token -> Keycloak () -updateUser (UserId uid) user tok = do - keycloakAdminPut ("users/" <> (convertString uid)) (toJSON user) tok - return () - - --- * Keycloak basic requests - --- | Perform post to Keycloak. -keycloakPost :: (Postable dat, Show dat) => Path -> dat -> Token -> Keycloak BL.ByteString -keycloakPost path dat tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK POST with url: " ++ (show url) - debug $ " data: " ++ (show dat) - --debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.postWith opts url dat - case eRes of - Right res -> do - return $ fromJust $ res ^? responseBody - Left er -> do - warn $ "Keycloak HTTP error: " ++ (show er) - throwError $ HTTPError er - --- | Perform post to Keycloak, without token. -keycloakPost' :: (Postable dat, Show dat) => Path -> dat -> Keycloak BL.ByteString -keycloakPost' path dat = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults - let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK POST with url: " ++ (show url) - debug $ " data: " ++ (show dat) - --debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.postWith opts url dat - case eRes of - Right res -> do - return $ fromJust $ res ^? responseBody - Left er -> do - warn $ "Keycloak HTTP error: " ++ (show er) - throwError $ HTTPError er - --- | Perform delete to Keycloak. -keycloakDelete :: Path -> Token -> Keycloak () -keycloakDelete path tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK DELETE with url: " ++ (show url) - debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.deleteWith opts url - case eRes of - Right res -> return () - Left err -> do - warn $ "Keycloak HTTP error: " ++ (show err) - throwError $ HTTPError err - --- | Perform get to Keycloak on admin API -keycloakGet :: Path -> Token -> Keycloak BL.ByteString -keycloakGet path tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK GET with url: " ++ (show url) - debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.getWith opts url - case eRes of - Right res -> do - return $ fromJust $ res ^? responseBody - Left err -> do - warn $ "Keycloak HTTP error: " ++ (show err) - throwError $ HTTPError err - --- | Perform get to Keycloak on admin API -keycloakAdminGet :: Path -> Token -> Keycloak BL.ByteString -keycloakAdminGet path tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK GET with url: " ++ (show url) - debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.getWith opts url - case eRes of - Right res -> do - return $ fromJust $ res ^? responseBody - Left err -> do - warn $ "Keycloak HTTP error: " ++ (show err) - throwError $ HTTPError err - --- | Perform post to Keycloak. -keycloakAdminPost :: (Postable dat, Show dat) => Path -> dat -> Token -> Keycloak BL.ByteString -keycloakAdminPost path dat tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK POST with url: " ++ (show url) - debug $ " data: " ++ (show dat) - --debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.postWith opts url dat - case eRes of - Right res -> do - debug $ (show eRes) - let headers = fromJust $ res ^? W.responseHeaders - return $ convertString $ L.last $ T.split (== '/') $ convertString $ fromJust $ lookup "Location" headers - Left err -> do - warn $ "Keycloak HTTP error: " ++ (show err) - throwError $ HTTPError err - --- | Perform put to Keycloak. -keycloakAdminPut :: (Putable dat, Show dat) => Path -> dat -> Token -> Keycloak () -keycloakAdminPut path dat tok = do - (KCConfig baseUrl realm _ _) <- ask - let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] - let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) - info $ "Issuing KEYCLOAK PUT with url: " ++ (show url) - debug $ " data: " ++ (show dat) - debug $ " headers: " ++ (show $ opts ^. W.headers) - eRes <- C.try $ liftIO $ W.putWith opts url dat - case eRes of - Right res -> return () - Left err -> do - warn $ "Keycloak HTTP error: " ++ (show err) - throwError $ HTTPError err - - --- * Helpers - -debug, warn, info, err :: (MonadIO m) => String -> m () -debug s = liftIO $ debugM "Keycloak" s -info s = liftIO $ infoM "Keycloak" s -warn s = liftIO $ warningM "Keycloak" s -err s = liftIO $ errorM "Keycloak" s - -getErrorStatus :: KCError -> Maybe Status -getErrorStatus (HTTPError (HttpExceptionRequest _ (StatusCodeException r _))) = Just $ HC.responseStatus r -getErrorStatus _ = Nothing - -try :: MonadError a m => m b -> m (Either a b) -try act = catchError (Right <$> act) (return . Left) - diff --git a/src/Keycloak/Tokens.hs b/src/Keycloak/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Tokens.hs @@ -0,0 +1,91 @@ +{-# 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 = do + body <- keycloakGet' ("protocol/openid-connect/certs") + info $ show body + (JWKSet jwks) <- case eitherDecode body of + Right ret -> do + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + return jwks + + +-- | Retrieve the user's token. This token can be used for every other Keycloak calls. +getJWT :: Username -> Password -> Keycloak JWT +getJWT username password = do + debug "Get user token" + client <- asks _confClientId + secret <- asks _confClientSecret + let dat = ["client_id" := client, + "client_secret" := secret, + "grant_type" := ("password" :: Text), + "password" := password, + "username" := username] + body <- keycloakPost' "protocol/openid-connect/token" dat + debug $ "Keycloak: " ++ (show body) + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + decodeCompact $ convertString $ accessToken ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show 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 = do + debug "Get client token" + client <- asks _confClientId + secret <- asks _confClientSecret + let dat = ["client_id" := client, + "client_secret" := secret, + "grant_type" := ("client_credentials" :: Text)] + body <- keycloakPost' "protocol/openid-connect/token" dat + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + decodeCompact $ convertString $ accessToken ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + + +-- | Verify a JWT. If sucessful, the claims are returned. Otherwise, a JWTError is thrown. +verifyJWT :: JWK -> JWT -> Keycloak ClaimsSet +verifyJWT jwk jwt = verifyClaims (defaultJWTValidationSettings (const True)) jwk jwt + +-- | Extract the user identity from a token. Additional attributes can be encoded in the token. +getClaimsUser :: ClaimsSet -> User +getClaimsUser claims = User { userId = Just $ UserId $ view (claimSub . _Just . string) claims + , userUsername = view (unregisteredClaims . at "preferred_username" . _Just . _String) claims + , userFirstName = preview (unregisteredClaims . at "given_name" . _Just . _String) claims + , userLastName = preview (unregisteredClaims . at "family_name" . _Just . _String) claims + , userEmail = preview (unregisteredClaims . at "email" . _Just . _String) claims + , userAttributes = preview unregisteredClaims claims} + + diff --git a/src/Keycloak/Types.hs b/src/Keycloak/Types.hs --- a/src/Keycloak/Types.hs +++ b/src/Keycloak/Types.hs @@ -1,28 +1,28 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} module Keycloak.Types where import Data.Aeson import Data.Aeson.Casing +import Data.Hashable import Data.Text hiding (head, tail, map, toLower, drop) -import Data.Text.Encoding import Data.String.Conversions import Data.Maybe import Data.Map hiding (drop, map) -import qualified Data.ByteString as BS -import qualified Data.Word8 as W8 (isSpace, toLower) +import qualified Data.HashMap.Strict as HM import Data.Char import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Reader as R import Control.Lens hiding ((.=)) import GHC.Generics (Generic) -import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Network.HTTP.Client as HC hiding (responseBody) +import Crypto.JWT as JWT +type JWT = SignedJWT + -- * Keycloak Monad -- | Keycloak Monad stack: a simple Reader monad containing the config, and an ExceptT to handle HTTPErrors and parse errors. @@ -31,9 +31,19 @@ -- | Contains HTTP errors and parse errors. data KCError = HTTPError HttpException -- ^ Keycloak returned an HTTP error. | ParseError Text -- ^ Failed when parsing the response + | JWTError JWTError -- ^ Failed to decode the token | EmptyError -- ^ Empty error to serve as a zero element for Monoid. deriving (Show) +instance AsJWTError KCError where + _JWTError = prism' JWTError up where + up (JWTError e) = Just e + up _ = Nothing + +instance AsError KCError where + _Error = _JWSError + + -- | Configuration of Keycloak. data KCConfig = KCConfig { _confBaseUrl :: Text, @@ -58,58 +68,6 @@ -- * Token --- | Wrapper for tokens. -newtype Token = Token {unToken :: BS.ByteString} deriving (Eq, Show, Generic) - -instance ToJSON Token where - toJSON (Token t) = String $ convertString t - --- | parser for Authorization header -instance FromHttpApiData Token where - parseQueryParam = parseHeader . encodeUtf8 - parseHeader (extractBearerAuth -> Just tok) = Right $ Token tok - parseHeader _ = Left "cannot extract auth Bearer" - -extractBearerAuth :: BS.ByteString -> Maybe BS.ByteString -extractBearerAuth bs = - let (x, y) = BS.break W8.isSpace bs - in if BS.map W8.toLower x == "bearer" - then Just $ BS.dropWhile W8.isSpace y - else Nothing - --- | Create Authorization header -instance ToHttpApiData Token where - toQueryParam (Token token) = "Bearer " <> (decodeUtf8 token) - --- | Keycloak Token additional claims -tokNonce, tokAuthTime, tokSessionState, tokAtHash, tokCHash, tokName, tokGivenName, tokFamilyName, tokMiddleName, tokNickName, tokPreferredUsername, tokProfile, tokPicture, tokWebsite, tokEmail, tokEmailVerified, tokGender, tokBirthdate, tokZoneinfo, tokLocale, tokPhoneNumber, tokPhoneNumberVerified,tokAddress, tokUpdateAt, tokClaimsLocales, tokACR :: Text -tokNonce = "nonce"; -tokAuthTime = "auth_time"; -tokSessionState = "session_state"; -tokAtHash = "at_hash"; -tokCHash = "c_hash"; -tokName = "name"; -tokGivenName = "given_name"; -tokFamilyName = "family_name"; -tokMiddleName = "middle_name"; -tokNickName = "nickname"; -tokPreferredUsername = "preferred_username"; -tokProfile = "profile"; -tokPicture = "picture"; -tokWebsite = "website"; -tokEmail = "email"; -tokEmailVerified = "email_verified"; -tokGender = "gender"; -tokBirthdate = "birthdate"; -tokZoneinfo = "zoneinfo"; -tokLocale = "locale"; -tokPhoneNumber = "phone_number"; -tokPhoneNumberVerified = "phone_number_verified"; -tokAddress = "address"; -tokUpdateAt = "updated_at"; -tokClaimsLocales = "claims_locales"; -tokACR = "acr"; - -- | Token reply from Keycloak data TokenRep = TokenRep { accessToken :: Text, @@ -135,7 +93,7 @@ -- * Permissions -- | Scope name -newtype ScopeName = ScopeName {unScopeName :: Text} deriving (Eq, Generic, Ord) +newtype ScopeName = ScopeName {unScopeName :: Text} deriving (Eq, Generic, Ord, Hashable) --JSON instances instance ToJSON ScopeName where @@ -186,7 +144,7 @@ data PermReq = PermReq { permReqResourceId :: Maybe ResourceId, -- Requested ressource Ids. Nothing means "All resources". permReqScopes :: [ScopeName] -- Scopes requested. [] means "all scopes". - } deriving (Generic, Eq, Ord) + } deriving (Generic, Eq, Ord, Hashable) instance Show PermReq where show (PermReq (Just (ResourceId res1)) scopes) = (show res1) <> " " <> (show scopes) @@ -213,12 +171,12 @@ -- | User data User = User - { userId :: Maybe UserId -- ^ The unique user ID - , userUsername :: Username -- ^ Username - , userFirstName :: Maybe Text -- ^ First name - , userLastName :: Maybe Text -- ^ Last name - , userEmail :: Maybe Text -- ^ Email - , userAttributes :: Maybe (Map Text [Text]) + { userId :: Maybe UserId -- ^ The unique user ID + , userUsername :: Username -- ^ Username + , userFirstName :: Maybe Text -- ^ First name + , userLastName :: Maybe Text -- ^ Last name + , userEmail :: Maybe Text -- ^ Email + , userAttributes :: Maybe (HM.HashMap Text Value) } deriving (Show, Eq, Generic) unCapitalize :: String -> String @@ -254,7 +212,7 @@ type ResourceType = Text -- | A resource Id -newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic, Ord) +newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic, Ord, Hashable) -- JSON instances instance ToJSON ResourceId where diff --git a/src/Keycloak/Users.hs b/src/Keycloak/Users.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Users.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Keycloak.Users where + +import Control.Monad.Except (throwError) +import Data.Aeson as JSON +import Data.Text as T hiding (head, tail, map) +import Data.String.Conversions +import Keycloak.Types +import Keycloak.Utils as U +import Network.HTTP.Types (renderQuery) + +-- * Users + +-- | Get users. Default number of users is 100. Parameters max and first allow to paginate and retrieve more than 100 users. +getUsers :: Maybe Max -> Maybe First -> Maybe Username -> JWT -> Keycloak [User] +getUsers mmax first username tok = do + let query = maybe [] (\m -> [("max", Just $ convertString $ show m)]) mmax + ++ maybe [] (\f -> [("first", Just $ convertString $ show f)]) first + ++ maybe [] (\u -> [("username", Just $ convertString u)]) username + body <- keycloakAdminGet ("users" <> (convertString $ renderQuery True query)) tok + debug $ "Keycloak success" + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +-- | Get a single user, based on his Id +getUser :: UserId -> JWT -> Keycloak User +getUser (UserId uid) tok = do + body <- keycloakAdminGet ("users/" <> (convertString uid)) tok + debug $ "Keycloak success: " ++ (show body) + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +-- | Create a user +createUser :: User -> JWT -> Keycloak UserId +createUser user tok = do + res <- keycloakAdminPost ("users/") (toJSON user) tok + debug $ "Keycloak success: " ++ (show res) + return $ UserId $ convertString res + +-- | Get a single user, based on his Id +updateUser :: UserId -> User -> JWT -> Keycloak () +updateUser (UserId uid) user tok = do + keycloakAdminPut ("users/" <> (convertString uid)) (toJSON user) tok + return () + + diff --git a/src/Keycloak/Utils.hs b/src/Keycloak/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Utils.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Keycloak.Utils where + +import Control.Lens hiding ((.=)) +import Control.Monad.Reader as R +import qualified Control.Monad.Catch as C +import Control.Monad.Except (throwError, catchError, MonadError) +import Data.Aeson as JSON +import Data.Text as T hiding (head, tail, map) +import Data.Maybe +import Data.List as L +import Data.String.Conversions +import qualified Data.ByteString.Lazy as BL +import Keycloak.Types +import Network.HTTP.Client as HC hiding (responseBody, path) +import Network.HTTP.Types.Status +import Network.Wreq as W hiding (statusCode) +import Network.Wreq.Types +import System.Log.Logger +import Crypto.JWT as JWT + +-- | Perform post to Keycloak. +keycloakPost :: (Postable dat, Show dat) => Path -> dat -> JWT -> Keycloak BL.ByteString +keycloakPost path dat jwt = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact jwt)] + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + --debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform post to Keycloak, without token. +keycloakPost' :: (Postable dat, Show dat) => Path -> dat -> Keycloak BL.ByteString +keycloakPost' path dat = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + --debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform delete to Keycloak. +keycloakDelete :: Path -> JWT -> Keycloak () +keycloakDelete path jwt = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact jwt)] + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK DELETE with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.deleteWith opts url + case eRes of + Right _ -> return () + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform get to Keycloak on admin API +keycloakGet :: Path -> JWT -> Keycloak BL.ByteString +keycloakGet path tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact tok)] + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK GET with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.getWith opts url + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform get to Keycloak on admin API, without token +keycloakGet' :: Path -> Keycloak BL.ByteString +keycloakGet' path = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK GET with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.getWith opts url + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + + +-- | Perform get to Keycloak on admin API +keycloakAdminGet :: Path -> JWT -> Keycloak BL.ByteString +keycloakAdminGet path tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact tok)] + let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK GET with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.getWith opts url + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform post to Keycloak. +keycloakAdminPost :: (Postable dat, Show dat) => Path -> dat -> JWT -> Keycloak BL.ByteString +keycloakAdminPost path dat tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact tok)] + let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + --debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat + case eRes of + Right res -> do + debug $ (show eRes) + let hs = fromJust $ res ^? W.responseHeaders + return $ convertString $ L.last $ T.split (== '/') $ convertString $ fromJust $ lookup "Location" hs + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + +-- | Perform put to Keycloak. +keycloakAdminPut :: (Putable dat, Show dat) => Path -> dat -> JWT -> Keycloak () +keycloakAdminPut path dat tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (convertString $ encodeCompact tok)] + let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK PUT with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.putWith opts url dat + case eRes of + Right _ -> return () + Left er -> do + warn $ "Keycloak HTTP error: " ++ (show er) + throwError $ HTTPError er + + +-- * Helpers + +readString :: Value -> Maybe Text +readString (String a) = Just a +readString _ = Nothing + +debug, warn, info, err :: (MonadIO m) => String -> m () +debug s = liftIO $ debugM "Keycloak" s +info s = liftIO $ infoM "Keycloak" s +warn s = liftIO $ warningM "Keycloak" s +err s = liftIO $ errorM "Keycloak" s + +getErrorStatus :: KCError -> Maybe Status +getErrorStatus (HTTPError (HttpExceptionRequest _ (StatusCodeException r _))) = Just $ HC.responseStatus r +getErrorStatus _ = Nothing + +try :: MonadError a m => m b -> m (Either a b) +try act = catchError (Right <$> act) (return . Left) +