keycloak-hs 1.1.0 → 1.1.1

raw patch · 5 files changed

+61/−55 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/Main.hs +4/−4
• keycloak-hs.cabal +1/−1
• src/Keycloak.hs +17/−3
• src/Keycloak/Client.hs +24/−31
• src/Keycloak/Types.hs +15/−16

@@ -9,10 +9,10 @@ -- Kecyloak configuration. kcConfig :: KCConfig kcConfig = KCConfig {-  _baseUrl       = "http://localhost:8080/auth",-  _realm         = "demo",-  _clientId      = "demo",-  _clientSecret  = "4270ce82-4a8f-4d89-9ea9-d9b28c3bab3e"}+  _confBaseUrl       = "http://localhost:8080/auth",+  _confRealm         = "demo",+  _confClientId      = "demo",+  _confClientSecret  = "4270ce82-4a8f-4d89-9ea9-d9b28c3bab3e"}  main :: IO () main = void $ flip runKeycloak kcConfig $ do

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: keycloak-hs-version: 1.1.0+version: 1.1.1 license: BSD3 license-file: LICENSE copyright: 2019 Corentin Dupont

@@ -1,7 +1,21 @@ -module Keycloak (-  module Keycloak.Client,-  module Keycloak.Types) where+module Keycloak (isAuthorized,+                 getPermissions,+                 checkPermission,+                 getUserAuthToken,+                 getClientAuthToken,+                 getUsername,+                 createResource,+                 deleteResource,+                 deleteAllResources,+                 getResource,+                 getAllResourceIds,+                 updateResource,+                 getUsers,+                 getUser,+                 createUser,+                 updateUser, +                 module Keycloak.Types) where  import Keycloak.Client import Keycloak.Types

@@ -10,26 +10,20 @@ import qualified Control.Monad.Catch as C import           Control.Monad.Except (throwError, catchError, MonadError) import           Data.Aeson as JSON-import           Data.Aeson.Types hiding ((.=))-import           Data.Text as T hiding (head, tail, map, lookup)-import           Data.Text.Encoding+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           Data.Monoid hiding (First)-import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL import           Keycloak.Types-import           Network.HTTP.Client as HC hiding (responseBody)+import           Network.HTTP.Client as HC hiding (responseBody, path) import           Network.HTTP.Types.Status-import           Network.HTTP.Types.Method  import           Network.HTTP.Types (renderQuery) import           Network.Wreq as W hiding (statusCode) import           Network.Wreq.Types import           System.Log.Logger-import           System.IO.Unsafe import           Web.JWT as JWT import           Safe @@ -48,7 +42,7 @@ getPermissions :: [PermReq] -> Token -> Keycloak [Permission] getPermissions reqs tok = do   debug "Get all permissions"-  client <- asks _clientId+  client <- asks _confClientId   let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),              "audience" := client,              "response_mode" := ("permissions" :: Text)] @@ -63,20 +57,19 @@       throwError $ ParseError $ pack (show err2)   where     getPermString :: PermReq -> [Text]-    getPermString (PermReq (Just (ResourceId id)) []) = [id]-    getPermString (PermReq (Just (ResourceId id)) scopes) = map (\(ScopeName s) -> (id <> "#" <> s)) scopes+    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 _clientId+  client <- asks _confClientId   let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),              "audience" := client,              "permission"  := res <> "#" <> scope]-  keycloakPost "protocol/openid-connect/token" dat tok-  return ()+  void $ keycloakPost "protocol/openid-connect/token" dat tok   -- * Tokens@@ -85,8 +78,8 @@ getUserAuthToken :: Username -> Password -> Keycloak Token getUserAuthToken username password = do    debug "Get user token"-  client <- asks _clientId-  secret <- asks _clientSecret+  client <- asks _confClientId+  secret <- asks _confClientSecret   let dat = ["client_id" := client,               "client_secret" := secret,              "grant_type" := ("password" :: Text),@@ -106,8 +99,8 @@ getClientAuthToken :: Keycloak Token getClientAuthToken = do   debug "Get client token"-  client <- asks _clientId-  secret <- asks _clientSecret+  client <- asks _confClientId+  secret <- asks _confClientSecret   let dat = ["client_id" := client,               "client_secret" := secret,              "grant_type" := ("client_credentials" :: Text)]@@ -126,7 +119,7 @@ getUsername (Token tok) = do    case JWT.decode $ convertString tok of     Just t -> case (unClaimsMap $ unregisteredClaims $ claims t) !? "preferred_username" of-      Just (String un) -> un+      Just (String u) -> u       _ -> error "preferred_username not present in token"      Nothing -> error "Error while decoding token" @@ -194,8 +187,8 @@  -- | 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 max first username tok = do-  let query = maybe [] (\m -> [("max", Just $ convertString $ show m)]) max+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 @@ -210,8 +203,8 @@  -- | Get a single user, based on his Id getUser :: UserId -> Token -> Keycloak User-getUser (UserId id) tok = do-  body <- keycloakAdminGet ("users/" <> (convertString id)) tok +getUser (UserId uid) tok = do+  body <- keycloakAdminGet ("users/" <> (convertString uid)) tok    debug $ "Keycloak success: " ++ (show body)    case eitherDecode body of     Right ret -> do@@ -230,8 +223,8 @@  -- | Get a single user, based on his Id updateUser :: UserId -> User -> Token -> Keycloak ()-updateUser (UserId id) user tok = do-  keycloakAdminPut ("users/" <> (convertString id)) (toJSON user) tok +updateUser (UserId uid) user tok = do+  keycloakAdminPut ("users/" <> (convertString uid)) (toJSON user) tok    return ()  @@ -250,9 +243,9 @@   case eRes of      Right res -> do       return $ fromJust $ res ^? responseBody-    Left err -> do-      warn $ "Keycloak HTTP error: " ++ (show err)-      throwError $ HTTPError err+    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@@ -267,9 +260,9 @@   case eRes of      Right res -> do       return $ fromJust $ res ^? responseBody-    Left err -> do-      warn $ "Keycloak HTTP error: " ++ (show err)-      throwError $ HTTPError err+    Left er -> do+      warn $ "Keycloak HTTP error: " ++ (show er)+      throwError $ HTTPError er  -- | Perform delete to Keycloak. keycloakDelete :: Path -> Token -> Keycloak ()

@@ -7,16 +7,14 @@ module Keycloak.Types where  import           Data.Aeson-import           Data.Aeson.Types import           Data.Aeson.Casing 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 qualified Data.Word8 as W8 (isSpace, toLower) import           Data.Char import           Control.Monad.Except (ExceptT, runExceptT) import           Control.Monad.Reader as R@@ -24,7 +22,6 @@ import           GHC.Generics (Generic) import           Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import           Network.HTTP.Client as HC hiding (responseBody)-import           Web.JWT as JWT  -- * Keycloak Monad @@ -39,18 +36,18 @@  -- | Configuration of Keycloak. data KCConfig = KCConfig {-  _baseUrl       :: Text,-  _realm         :: Text,-  _clientId      :: Text,-  _clientSecret  :: Text} deriving (Eq, Show)+  _confBaseUrl       :: Text,+  _confRealm         :: Text,+  _confClientId      :: Text,+  _confClientSecret  :: Text} deriving (Eq, Show)  -- | Default configuration defaultKCConfig :: KCConfig defaultKCConfig = KCConfig {-  _baseUrl       = "http://localhost:8080/auth",-  _realm         = "waziup",-  _clientId      = "api-server",-  _clientSecret  = "4e9dcb80-efcd-484c-b3d7-1e95a0096ac0"}+  _confBaseUrl       = "http://localhost:8080/auth",+  _confRealm         = "waziup",+  _confClientId      = "api-server",+  _confClientSecret  = "4e9dcb80-efcd-484c-b3d7-1e95a0096ac0"}  -- | Run a Keycloak monad within IO. runKeycloak :: Keycloak a -> KCConfig -> IO (Either KCError a)@@ -133,6 +130,7 @@                                   <*> v .: "not-before-policy"                                   <*> v .: "session_state"                                   <*> v .: "scope"+  parseJSON _ = error "Not an object"  -- * Permissions @@ -224,7 +222,7 @@   } deriving (Show, Eq, Generic)  unCapitalize :: String -> String-unCapitalize (c:cs) = toLower c : cs+unCapitalize (a:as) = toLower a : as unCapitalize [] = []  instance FromJSON User where@@ -289,17 +287,18 @@     rAtt    <- v .:? "attributes"     let atts = if isJust rAtt then toList $ fromJust rAtt else []     return $ Resource rId rName rType rUris rScopes rOwn rOMA (map (\(a, b) -> Attribute a b) atts)+  parseJSON _ = error "not an object"  instance ToJSON Resource where-  toJSON (Resource id name typ uris scopes own uma attrs) =-    object ["_id"                .= toJSON id,+  toJSON (Resource rid name typ uris scopes own uma attrs) =+    object ["_id"                .= toJSON rid,             "name"               .= toJSON name,             "type"               .= toJSON typ,             "uris"               .= toJSON uris,             "scopes"             .= toJSON scopes,             "owner"              .= (toJSON $ ownName own),             "ownerManagedAccess" .= toJSON uma,-            "attributes"         .= object (map (\(Attribute name vals) -> name .= toJSON vals) attrs)]+            "attributes"         .= object (map (\(Attribute aname vals) -> aname .= toJSON vals) attrs)]  -- | A resource attribute data Attribute = Attribute {