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: 0.0.0.4 +version: 0.0.0.5 description: Please see the README on GitHub at homepage: https://github.com/cdupont/keycloak-hs#readme bug-reports: https://github.com/cdupont/keycloak-hs/issues @@ -49,15 +49,3 @@ default-language: Haskell2010 -test-suite keycloak-hs-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_keycloak_hs - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , keycloak-hs - default-language: Haskell2010 diff --git a/src/Keycloak/Client.hs b/src/Keycloak/Client.hs --- a/src/Keycloak/Client.hs +++ b/src/Keycloak/Client.hs @@ -11,11 +11,11 @@ import Control.Monad.Except (throwError, catchError, MonadError) import Data.Aeson as JSON import Data.Aeson.Types hiding ((.=)) -import Data.Text hiding (head, tail, map) +import Data.Text as T hiding (head, tail, map, lookup) import Data.Text.Encoding import Data.Maybe -import Data.Map hiding (map) -import Data.ByteString.Base64 as B64 +import Data.List as L +import Data.Map hiding (map, lookup) import Data.String.Conversions import Data.Monoid hiding (First) import qualified Data.ByteString.Char8 as BS @@ -118,8 +118,8 @@ -- | Extract user name from a token getUsername :: Token -> Maybe Username getUsername (Token tok) = do - case JWT.decode $ (traceShowId (convertString tok)) of - Just t -> case (traceShowId (unClaimsMap $ unregisteredClaims $ claims t)) !? "preferred_username" of + case JWT.decode $ convertString tok of + Just t -> case (unClaimsMap $ unregisteredClaims $ claims t) !? "preferred_username" of Just (String un) -> Just un _ -> Nothing Nothing -> do @@ -133,7 +133,10 @@ 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 + -- The user token might not be suitable because it can use another client (such as "dashboard"). + -- however we need "api-server" as client because it's the resource authorization server. + tok2 <- getClientAuthToken + body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok2 debug $ convertString $ "Created resource: " ++ convertString body case eitherDecode body of Right ret -> do @@ -146,17 +149,19 @@ -- | Delete the resource deleteResource :: ResourceId -> Token -> Keycloak () deleteResource (ResourceId rid) tok = do - keycloakDelete ("authz/protection/resource_set/" <> rid) tok + tok2 <- getClientAuthToken + keycloakDelete ("authz/protection/resource_set/" <> rid) tok2 return () -- * 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 -> Token -> Keycloak [User] -getUsers max first tok = do +getUsers :: Maybe Max -> Maybe First -> Maybe Username -> Token -> Keycloak [User] +getUsers max first username tok = do let query = maybe [] (\l -> [("limit", Just $ convertString $ show l)]) max ++ maybe [] (\m -> [("max", Just $ convertString $ show m)]) first + ++ maybe [] (\u -> [("username", Just $ convertString u)]) username body <- keycloakAdminGet ("users" <> (convertString $ renderQuery True query)) tok debug $ "Keycloak success: " ++ (show body) case eitherDecode body of @@ -180,7 +185,20 @@ debug $ "Keycloak parse error: " ++ (show err2) throwError $ ParseError $ pack (show err2) +-- | Get a single user, based on his Id +postUser :: User -> Token -> Keycloak UserId +postUser 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 +putUser :: UserId -> User -> Token -> Keycloak () +putUser (UserId id) user tok = do + keycloakAdminPut ("users/" <> (convertString id)) (toJSON user) tok + return () + + -- * Keycloak basic requests -- | Perform post to Keycloak. @@ -248,14 +266,47 @@ 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 "API" s -info s = liftIO $ infoM "API" s -warn s = liftIO $ warningM "API" s -err s = liftIO $ errorM "API" s +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 diff --git a/src/Keycloak/Types.hs b/src/Keycloak/Types.hs --- a/src/Keycloak/Types.hs +++ b/src/Keycloak/Types.hs @@ -12,7 +12,9 @@ import Data.Text hiding (head, tail, map, toLower, drop) import Data.Text.Encoding import Data.Monoid +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, _colon, toLower) import Data.Char @@ -61,6 +63,9 @@ -- | 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 @@ -80,32 +85,32 @@ -- | 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"; +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"; +tokAddress = "address"; +tokUpdateAt = "updated_at"; +tokClaimsLocales = "claims_locales"; +tokACR = "acr"; -- | Token reply from Keycloak data TokenRep = TokenRep { @@ -192,7 +197,8 @@ , userUsername :: Username -- ^ Username , userFirstName :: Maybe Text -- ^ First name , userLastName :: Maybe Text -- ^ Last name - , userEmail :: Maybe Text -- ^ Email + , userEmail :: Maybe Text -- ^ Email + , userAttributes :: Maybe (Map Text [Text]) } deriving (Show, Eq, Generic) unCapitalize :: String -> String @@ -203,7 +209,7 @@ parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 4} instance ToJSON User where - toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 4, omitNothingFields = True} + toJSON = genericToJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 4, omitNothingFields = True} @@ -265,7 +271,7 @@ object ["name" .= toJSON name, "uris" .= toJSON uris, "scopes" .= toJSON scopes, - "owner" .= toJSON own, + "owner" .= (toJSON $ ownName own), "ownerManagedAccess" .= toJSON uma, "attributes" .= object (map (\(Attribute name vals) -> name .= toJSON vals) attrs)] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"