diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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 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.0 +version: 1.1.1 license: BSD3 license-file: LICENSE copyright: 2019 Corentin Dupont diff --git a/src/Keycloak.hs b/src/Keycloak.hs --- a/src/Keycloak.hs +++ b/src/Keycloak.hs @@ -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 diff --git a/src/Keycloak/Client.hs b/src/Keycloak/Client.hs --- a/src/Keycloak/Client.hs +++ b/src/Keycloak/Client.hs @@ -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 () diff --git a/src/Keycloak/Types.hs b/src/Keycloak/Types.hs --- a/src/Keycloak/Types.hs +++ b/src/Keycloak/Types.hs @@ -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 {