diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ Keycloak-hs =========== +[![Build status](https://github.com/cdupont/keycloak-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/cdupont/keycloak-hs/actions/workflows/ci.yml) Keycloak-hs is an Haskell library for connecting to [Keycloak](https://www.keycloak.org/). Keycloak allows to authenticate and manage users and to protect API resources. 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: 2.1.0 +version: 3.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Corentin Dupont @@ -48,6 +48,7 @@ jose >=0.8 && <0.9, lens >=4.17 && <4.20, lens-aeson >=1.1 && <1.2, + monad-time >= 0.3 && <0.4, mtl >=2.2 && <2.3, string-conversions >=0.4 && <0.5, safe >=0.3 && <0.4, diff --git a/src/Keycloak/Authorizations.hs b/src/Keycloak/Authorizations.hs --- a/src/Keycloak/Authorizations.hs +++ b/src/Keycloak/Authorizations.hs @@ -28,7 +28,6 @@ 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 @@ -45,19 +44,19 @@ -- * Permissions -- | Returns true if the resource is authorized under the given scope. -isAuthorized :: ResourceId -> ScopeName -> JWT -> Keycloak Bool +isAuthorized :: MonadIO m => ResourceId -> ScopeName -> JWT -> KeycloakT m 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 + Left e -> kcError e --rethrow the error -- | Return the permissions for the permission requests. -getPermissions :: [PermReq] -> JWT -> Keycloak [Permission] +getPermissions :: MonadIO m => [PermReq] -> JWT -> KeycloakT m [Permission] getPermissions reqs tok = do debug "Get all permissions" - client <- view $ confAdapterConfig.confResource + client <- viewConfig $ confAdapterConfig.confResource let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), "audience" := client, "response_mode" := ("permissions" :: Text)] @@ -69,7 +68,7 @@ return ret Left (err2 :: String) -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) where getPermString :: PermReq -> [Text] getPermString (PermReq (Just (ResourceId rid)) []) = [rid] @@ -77,10 +76,10 @@ 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 :: MonadIO m => ResourceId -> ScopeName -> JWT -> KeycloakT m () checkPermission (ResourceId res) (ScopeName scope) tok = do debug $ "Checking permissions: " ++ (show res) ++ " " ++ (show scope) - client <- view $ confAdapterConfig.confResource + client <- viewConfig $ confAdapterConfig.confResource let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), "audience" := client, "permission" := res <> "#" <> scope] @@ -90,7 +89,7 @@ -- * Resource -- | Create an authorization resource in Keycloak, under the configured client. -createResource :: Resource -> JWT -> Keycloak ResourceId +createResource :: MonadIO m => Resource -> JWT -> KeycloakT m ResourceId createResource r tok = do debug $ convertString $ "Creating resource: " <> (JSON.encode r) body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok @@ -101,17 +100,17 @@ return $ fromJustNote "create" $ resId ret Left err2 -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | Delete the resource -deleteResource :: ResourceId -> JWT -> Keycloak () +deleteResource :: MonadIO m => ResourceId -> JWT -> KeycloakT m () deleteResource (ResourceId rid) tok = do --tok2 <- getClientAuthToken keycloakDelete ("authz/protection/resource_set/" <> rid) tok return () -- | Delete all resources in Keycloak -deleteAllResources :: JWT -> Keycloak () +deleteAllResources :: MonadIO m => JWT -> KeycloakT m () deleteAllResources tok = do debug "Deleting all Keycloak resources..." ids <- getAllResourceIds @@ -119,7 +118,7 @@ debug $ "Deleted " ++ (show $ L.length $ rights res) ++ " resources out of " ++ (show $ L.length ids) -- | get a single resource -getResource :: ResourceId -> JWT -> Keycloak Resource +getResource :: MonadIO m => ResourceId -> JWT -> KeycloakT m Resource getResource (ResourceId rid) tok = do body <- keycloakGet ("authz/protection/resource_set/" <> rid) tok case eitherDecode body of @@ -127,10 +126,10 @@ return ret Left (err2 :: String) -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | get all resources IDs -getAllResourceIds :: Keycloak [ResourceId] +getAllResourceIds :: MonadIO m => KeycloakT m [ResourceId] getAllResourceIds = do debug "Get all resources" tok2 <- getClientJWT @@ -140,9 +139,8 @@ return ret Left (err2 :: String) -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | Update a resource -updateResource :: Resource -> JWT -> Keycloak ResourceId +updateResource :: MonadIO m => Resource -> JWT -> KeycloakT m ResourceId updateResource = createResource - diff --git a/src/Keycloak/Tokens.hs b/src/Keycloak/Tokens.hs --- a/src/Keycloak/Tokens.hs +++ b/src/Keycloak/Tokens.hs @@ -39,7 +39,8 @@ module Keycloak.Tokens where import Control.Lens hiding ((.=)) -import Control.Monad.Except (throwError) +import Control.Monad.IO.Class +import Control.Monad.Time (MonadTime) import Crypto.JWT as JWT import Data.Aeson as JSON import Data.Aeson.Lens @@ -54,11 +55,11 @@ -- | 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 :: Username -> Password -> Keycloak JWT -getJWT username password = do +getJWT :: MonadIO m => Username -> Password -> KeycloakT m JWT +getJWT username password = do debug "Get user token" - client <- view $ confAdapterConfig.confResource - secret <- view $ confAdapterConfig.confCredentials.confSecret + client <- viewConfig $ confAdapterConfig.confResource + secret <- viewConfig $ confAdapterConfig.confCredentials.confSecret let dat = ["client_id" := client, "client_secret" := secret, "grant_type" := ("password" :: Text), @@ -67,19 +68,19 @@ body <- keycloakPost' "protocol/openid-connect/token" dat debug $ "Keycloak: " ++ (show body) case eitherDecode body of - Right ret -> do + Right ret -> do debug $ "Keycloak success: " ++ (show ret) - decodeCompact $ convertString $ accessToken ret + KeycloakT $ decodeCompact $ convertString $ accessToken ret Left err2 -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ 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 :: MonadIO m => KeycloakT m JWT getClientJWT = do debug "Get client token" - client <- view $ confAdapterConfig.confResource - secret <- view $ confAdapterConfig.confCredentials.confSecret + client <- viewConfig $ confAdapterConfig.confResource + secret <- viewConfig $ confAdapterConfig.confCredentials.confSecret let dat = ["client_id" := client, "client_secret" := secret, "grant_type" := ("client_credentials" :: Text)] @@ -87,17 +88,17 @@ case eitherDecode body of Right ret -> do debug $ "Keycloak success: " ++ (show ret) - decodeCompact $ convertString $ accessToken ret + KeycloakT $ decodeCompact $ convertString $ accessToken ret Left err2 -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | Verify a JWT. If sucessful, the claims are returned. Otherwise, a JWTError is thrown. -verifyJWT :: JWT -> Keycloak ClaimsSet +verifyJWT :: (MonadTime m, MonadIO m) => JWT -> KeycloakT m ClaimsSet verifyJWT jwt = do - jwks <- view confJWKs - verifyClaims (defaultJWTValidationSettings (const True)) (head jwks) jwt + jwks <- viewConfig confJWKs + KeycloakT $ verifyClaims (defaultJWTValidationSettings (const True)) (head jwks) jwt -- | Extract the user identity from a token. Additional attributes can be encoded in the token. getClaimsUser :: ClaimsSet -> User @@ -114,14 +115,14 @@ getJWKs :: Realm -> ServerURL -> IO [JWK] getJWKs realm baseUrl = do let opts = W.defaults - let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/protocol/openid-connect/certs") - info $ "Issuing KEYCLOAK GET with url: " ++ (show url) - debug $ " headers: " ++ (show $ opts ^. W.headers) + let url = unpack (baseUrl <> "/realms/" <> realm <> "/protocol/openid-connect/certs") + info $ "Issuing KEYCLOAK GET with url: " ++ show url + debug $ " headers: " ++ show (opts ^. W.headers) res <- W.getWith opts url let body = fromJust $ res ^? responseBody info $ show body case eitherDecode body of Right (JWKSet jwks) -> return jwks Left (err2 :: String) -> do - debug $ "Keycloak parse error: " ++ (show err2) - error $ (show err2) + debug $ "Keycloak parse error: " ++ show err2 + error $ show err2 diff --git a/src/Keycloak/Types.hs b/src/Keycloak/Types.hs --- a/src/Keycloak/Types.hs +++ b/src/Keycloak/Types.hs @@ -2,6 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Keycloak.Types where @@ -16,6 +20,7 @@ import Data.Char import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Reader as R +import Control.Monad.Time (MonadTime) import Control.Lens hiding ((.=)) import GHC.Generics (Generic) import Network.HTTP.Client as HC hiding (responseBody) @@ -29,14 +34,20 @@ -- | Keycloak Monad stack: a simple Reader monad containing the config, and an ExceptT to handle HTTPErrors and parse errors. -- You can extract the value using 'runKeycloak'. -- Example: @keys <- runKeycloak getJWKs defaultKCConfig@ -type Keycloak a = ReaderT KCConfig (ExceptT KCError IO) a +type Keycloak a = KeycloakT IO a +newtype KeycloakT m a = KeycloakT { unKeycloakT :: ReaderT KCConfig (ExceptT KCError m) a } + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadTime) + +instance MonadTrans KeycloakT where + lift = KeycloakT . lift . lift + -- | 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) + deriving stock (Show) instance AsJWTError KCError where _JWTError = prism' JWTError up where @@ -62,7 +73,7 @@ _confAuthServerUrl :: ServerURL, -- ^ Base url where Keycloak resides _confResource :: ClientId, -- ^ client id _confCredentials :: ClientCredentials} -- ^ client secret, found in Client/Credentials tab - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) instance ToJSON AdapterConfig where toJSON = genericToJSON $ trainDrop 5 @@ -72,7 +83,7 @@ data ClientCredentials = ClientCredentials { _confSecret :: Text} - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) instance ToJSON ClientCredentials where toJSON = genericToJSON $ trainDrop 5 @@ -92,8 +103,8 @@ _confCredentials = ClientCredentials "4e9dcb80-efcd-484c-b3d7-1e95a0096ac0"} -- | Run a Keycloak monad within IO. -runKeycloak :: Keycloak a -> KCConfig -> IO (Either KCError a) -runKeycloak kc conf = runExceptT $ runReaderT kc conf +runKeycloak :: Monad m => KeycloakT m a -> KCConfig -> m (Either KCError a) +runKeycloak kc conf = runExceptT $ runReaderT (unKeycloakT kc) conf type Path = Text @@ -109,7 +120,7 @@ tokenType :: Text, notBeforePolicy :: Int, sessionState :: Text, - tokenScope :: Text} deriving (Show, Eq) + tokenScope :: Text} deriving stock (Show, Eq) instance FromJSON TokenRep where parseJSON (Object v) = TokenRep <$> v .: "access_token" @@ -126,7 +137,9 @@ -- | Scope name, such as "houses:view" -- You need to create the scopes in Client/Authorization panel/Authorization scopes tab -newtype ScopeName = ScopeName {unScopeName :: Text} deriving (Eq, Generic, Ord, Hashable) +newtype ScopeName = ScopeName {unScopeName :: Text} + deriving stock (Eq, Generic, Ord) + deriving newtype (Hashable) --JSON instances instance ToJSON ScopeName where @@ -250,7 +263,9 @@ type ResourceType = Text -- | A resource Id -newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic, Ord, Hashable) +newtype ResourceId = ResourceId {unResId :: Text} + deriving stock (Show, Eq, Generic, Ord) + deriving newtype (Hashable) -- JSON instances instance ToJSON ResourceId where diff --git a/src/Keycloak/Users.hs b/src/Keycloak/Users.hs --- a/src/Keycloak/Users.hs +++ b/src/Keycloak/Users.hs @@ -22,7 +22,7 @@ module Keycloak.Users where -import Control.Monad.Except (throwError) +import Control.Monad.IO.Class import Data.Aeson as JSON import Data.Text as T hiding (head, tail, map) import Data.String.Conversions @@ -33,7 +33,7 @@ -- * 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 :: MonadIO m => Maybe Max -> Maybe First -> Maybe Username -> JWT -> KeycloakT m [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 @@ -46,10 +46,10 @@ return ret Left (err2 :: String) -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | Get a single user, based on his Id -getUser :: UserId -> JWT -> Keycloak User +getUser :: MonadIO m => UserId -> JWT -> KeycloakT m User getUser (UserId uid) tok = do body <- keycloakAdminGet ("users/" <> (convertString uid)) tok debug $ "Keycloak success: " ++ (show body) @@ -59,17 +59,17 @@ return ret Left (err2 :: String) -> do debug $ "Keycloak parse error: " ++ (show err2) - throwError $ ParseError $ pack (show err2) + kcError $ ParseError $ pack (show err2) -- | Create a user -createUser :: User -> JWT -> Keycloak UserId +createUser :: MonadIO m => User -> JWT -> KeycloakT m 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 :: MonadIO m => UserId -> User -> JWT -> KeycloakT m () 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 --- a/src/Keycloak/Utils.hs +++ b/src/Keycloak/Utils.hs @@ -24,120 +24,113 @@ -- | Perform post to Keycloak. -keycloakPost :: (Postable dat, Show dat) => Path -> dat -> JWT -> Keycloak BL.ByteString +keycloakPost :: (Postable dat, Show dat, MonadIO m) => Path -> dat -> JWT -> KeycloakT m BL.ByteString keycloakPost path dat jwt = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ 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 + kcError $ HTTPError er -- | Perform post to Keycloak, without token. -keycloakPost' :: (Postable dat, Show dat) => Path -> dat -> Keycloak BL.ByteString +keycloakPost' :: (Postable dat, Show dat, MonadIO m) => Path -> dat -> KeycloakT m BL.ByteString keycloakPost' path dat = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ 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 + kcError $ HTTPError er -- | Perform delete to Keycloak. -keycloakDelete :: Path -> JWT -> Keycloak () +keycloakDelete :: MonadIO m => Path -> JWT -> KeycloakT m () keycloakDelete path jwt = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ W.deleteWith opts url case eRes of Right _ -> return () Left er -> do warn $ "Keycloak HTTP error: " ++ (show er) - throwError $ HTTPError er + kcError $ HTTPError er -- | Perform get to Keycloak on admin API -keycloakGet :: Path -> JWT -> Keycloak BL.ByteString -keycloakGet path tok = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) +keycloakGet :: MonadIO m => Path -> JWT -> KeycloakT m BL.ByteString +keycloakGet path tok = do + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ 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 + kcError $ HTTPError er -- | Perform get to Keycloak on admin API, without token -keycloakGet' :: Path -> Keycloak BL.ByteString -keycloakGet' path = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) +keycloakGet' :: MonadIO m => Path -> KeycloakT m BL.ByteString +keycloakGet' path = do + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ 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 + kcError $ HTTPError er -- | Perform get to Keycloak on admin API -keycloakAdminGet :: Path -> JWT -> Keycloak BL.ByteString +keycloakAdminGet :: MonadIO m => Path -> JWT -> KeycloakT m BL.ByteString keycloakAdminGet path tok = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ 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 + kcError $ HTTPError er -- | Perform post to Keycloak. -keycloakAdminPost :: (Postable dat, Show dat) => Path -> dat -> JWT -> Keycloak BL.ByteString +keycloakAdminPost :: (Postable dat, Show dat, MonadIO m) => Path -> dat -> JWT -> KeycloakT m BL.ByteString keycloakAdminPost path dat tok = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ W.postWith opts url dat case eRes of Right res -> do debug $ (show eRes) @@ -145,29 +138,39 @@ return $ convertString $ L.last $ T.split (== '/') $ convertString $ fromJust $ lookup "Location" hs Left er -> do warn $ "Keycloak HTTP error: " ++ (show er) - throwError $ HTTPError er + kcError $ HTTPError er -- | Perform put to Keycloak. -keycloakAdminPut :: (Putable dat, Show dat) => Path -> dat -> JWT -> Keycloak () +keycloakAdminPut :: (Putable dat, Show dat, MonadIO m) => Path -> dat -> JWT -> KeycloakT m () keycloakAdminPut path dat tok = do - realm <- view (confAdapterConfig.confRealm) - baseUrl <- view (confAdapterConfig.confAuthServerUrl) + (realm,baseUrl) <- viewRealmAndUrl 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 + eRes <- liftIO $ C.try $ W.putWith opts url dat case eRes of Right _ -> return () Left er -> do warn $ "Keycloak HTTP error: " ++ (show er) - throwError $ HTTPError er + kcError $ HTTPError er +kcError :: Monad m => KCError -> KeycloakT m a +kcError = KeycloakT . throwError +viewRealmAndUrl :: Monad m => KeycloakT m (Realm,ServerURL) +viewRealmAndUrl = do + realm <- viewConfig (confAdapterConfig.confRealm) + baseUrl <- viewConfig (confAdapterConfig.confAuthServerUrl) + pure (realm,baseUrl) + +viewConfig :: Monad m => Getting b KCConfig b -> KeycloakT m b +viewConfig = KeycloakT . view + -- * Helpers -debug, warn, info, err :: (MonadIO m) => String -> m () +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 @@ -177,8 +180,5 @@ 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) - - - +try :: Monad m => KeycloakT m b -> KeycloakT m (Either KCError b) +try (KeycloakT act) = KeycloakT $ catchError (Right <$> act) (return . Left)