{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- This module helps you manage resources authorization with Keycloak.
-- 
-- In Keycloak, in the client, activate "Authorization Enabled" and set "Valid Redirect URIs" as "*".
-- You then need to create your scopes, policies and permissions in the authorization tab.
-- If you are unsure, set the "Policy Enforcement Mode" as permissive, so that a positive permission will be given with resources without policy.
-- 
-- The example below shows how to retrieve a token from Keycloak, and then retrieve the permissions of a user on a specific resource.
-- 
-- @
-- -- Let's get a token for a specific user login/password
-- 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)
-- @

module Keycloak.Authorizations where

import           Control.Monad.Reader as R
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           Control.Lens
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 :: MonadIO m => ResourceId -> ScopeName -> JWT -> KeycloakT m Bool
isAuthorized :: ResourceId -> ScopeName -> JWT -> KeycloakT m Bool
isAuthorized ResourceId
res ScopeName
scope JWT
tok = do
  Either KCError ()
r <- KeycloakT m () -> KeycloakT m (Either KCError ())
forall (m :: * -> *) b.
Monad m =>
KeycloakT m b -> KeycloakT m (Either KCError b)
U.try (KeycloakT m () -> KeycloakT m (Either KCError ()))
-> KeycloakT m () -> KeycloakT m (Either KCError ())
forall a b. (a -> b) -> a -> b
$ ResourceId -> ScopeName -> JWT -> KeycloakT m ()
forall (m :: * -> *).
MonadIO m =>
ResourceId -> ScopeName -> JWT -> KeycloakT m ()
checkPermission ResourceId
res ScopeName
scope JWT
tok
  case Either KCError ()
r of
    Right ()
_ -> Bool -> KeycloakT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Left KCError
e | (Status -> Int
statusCode (Status -> Int) -> Maybe Status -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KCError -> Maybe Status
U.getErrorStatus KCError
e) Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
403 -> Bool -> KeycloakT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Left KCError
e -> KCError -> KeycloakT m Bool
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError KCError
e --rethrow the error

-- | Return the permissions for the permission requests.
getPermissions :: MonadIO m => [PermReq] -> JWT -> KeycloakT m [Permission]
getPermissions :: [PermReq] -> JWT -> KeycloakT m [Permission]
getPermissions [PermReq]
reqs JWT
tok = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get all permissions"
  ClientId
client <- Getting ClientId KCConfig ClientId -> KeycloakT m ClientId
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting ClientId KCConfig ClientId -> KeycloakT m ClientId)
-> Getting ClientId KCConfig ClientId -> KeycloakT m ClientId
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const ClientId AdapterConfig)
-> KCConfig -> Const ClientId KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const ClientId AdapterConfig)
 -> KCConfig -> Const ClientId KCConfig)
-> ((ClientId -> Const ClientId ClientId)
    -> AdapterConfig -> Const ClientId AdapterConfig)
-> Getting ClientId KCConfig ClientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ClientId -> Const ClientId ClientId)
-> AdapterConfig -> Const ClientId AdapterConfig
Lens' AdapterConfig ClientId
confResource
  let dat :: [FormParam]
dat = [ByteString
"grant_type" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (ClientId
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= ClientId
client,
             ByteString
"response_mode" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (ClientId
"permissions" :: Text)] 
             [FormParam] -> [FormParam] -> [FormParam]
forall a. Semigroup a => a -> a -> a
<> (ClientId -> FormParam) -> [ClientId] -> [FormParam]
forall a b. (a -> b) -> [a] -> [b]
map (\ClientId
p -> ByteString
"permission" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= ClientId
p) ([[ClientId]] -> [ClientId]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[ClientId]] -> [ClientId]) -> [[ClientId]] -> [ClientId]
forall a b. (a -> b) -> a -> b
$ (PermReq -> [ClientId]) -> [PermReq] -> [[ClientId]]
forall a b. (a -> b) -> [a] -> [b]
map PermReq -> [ClientId]
getPermString [PermReq]
reqs)
  ByteString
body <- ClientId -> [FormParam] -> JWT -> KeycloakT m ByteString
forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
ClientId -> dat -> JWT -> KeycloakT m ByteString
keycloakPost ClientId
"protocol/openid-connect/token" [FormParam]
dat JWT
tok
  case ByteString -> Either String [Permission]
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right [Permission]
ret -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak returned perms: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Permission] -> String
forall a. Show a => a -> String
show [Permission]
ret)
      [Permission] -> KeycloakT m [Permission]
forall (m :: * -> *) a. Monad m => a -> m a
return [Permission]
ret
    Left (String
err2 :: String) -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m [Permission]
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m [Permission])
-> KCError -> KeycloakT m [Permission]
forall a b. (a -> b) -> a -> b
$ ClientId -> KCError
ParseError (ClientId -> KCError) -> ClientId -> KCError
forall a b. (a -> b) -> a -> b
$ String -> ClientId
pack (String -> String
forall a. Show a => a -> String
show String
err2)
  where
    getPermString :: PermReq -> [Text]
    getPermString :: PermReq -> [ClientId]
getPermString (PermReq (Just (ResourceId ClientId
rid)) []) = [ClientId
rid]
    getPermString (PermReq (Just (ResourceId ClientId
rid)) [ScopeName]
scopes) = (ScopeName -> ClientId) -> [ScopeName] -> [ClientId]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName ClientId
s) -> (ClientId
rid ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
"#" ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
s)) [ScopeName]
scopes
    getPermString (PermReq Maybe ResourceId
Nothing [ScopeName]
scopes) = (ScopeName -> ClientId) -> [ScopeName] -> [ClientId]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName ClientId
s) -> (ClientId
"#" ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
s)) [ScopeName]
scopes

-- | Checks if a scope is permitted on a resource. An HTTP Exception 403 will be thrown if not.
checkPermission :: MonadIO m => ResourceId -> ScopeName -> JWT -> KeycloakT m ()
checkPermission :: ResourceId -> ScopeName -> JWT -> KeycloakT m ()
checkPermission (ResourceId ClientId
res) (ScopeName ClientId
scope) JWT
tok = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Checking permissions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ClientId -> String
forall a. Show a => a -> String
show ClientId
res) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ClientId -> String
forall a. Show a => a -> String
show ClientId
scope)
  ClientId
client <- Getting ClientId KCConfig ClientId -> KeycloakT m ClientId
forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig (Getting ClientId KCConfig ClientId -> KeycloakT m ClientId)
-> Getting ClientId KCConfig ClientId -> KeycloakT m ClientId
forall a b. (a -> b) -> a -> b
$ (AdapterConfig -> Const ClientId AdapterConfig)
-> KCConfig -> Const ClientId KCConfig
Lens' KCConfig AdapterConfig
confAdapterConfig((AdapterConfig -> Const ClientId AdapterConfig)
 -> KCConfig -> Const ClientId KCConfig)
-> ((ClientId -> Const ClientId ClientId)
    -> AdapterConfig -> Const ClientId AdapterConfig)
-> Getting ClientId KCConfig ClientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ClientId -> Const ClientId ClientId)
-> AdapterConfig -> Const ClientId AdapterConfig
Lens' AdapterConfig ClientId
confResource
  let dat :: [FormParam]
dat = [ByteString
"grant_type" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (ClientId
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= ClientId
client,
             ByteString
"permission"  ByteString -> ClientId -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= ClientId
res ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
"#" ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
scope]
  KeycloakT m ByteString -> KeycloakT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeycloakT m ByteString -> KeycloakT m ())
-> KeycloakT m ByteString -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ ClientId -> [FormParam] -> JWT -> KeycloakT m ByteString
forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
ClientId -> dat -> JWT -> KeycloakT m ByteString
keycloakPost ClientId
"protocol/openid-connect/token" [FormParam]
dat JWT
tok


-- * Resource

-- | Create an authorization resource in Keycloak, under the configured client.
createResource :: MonadIO m => Resource -> JWT -> KeycloakT m ResourceId
createResource :: Resource -> JWT -> KeycloakT m ResourceId
createResource Resource
r JWT
tok = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
convertString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
"Creating resource: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Resource -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode Resource
r)
  ByteString
body <- ClientId -> Value -> JWT -> KeycloakT m ByteString
forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
ClientId -> dat -> JWT -> KeycloakT m ByteString
keycloakPost ClientId
"authz/protection/resource_set" (Resource -> Value
forall a. ToJSON a => a -> Value
toJSON Resource
r) JWT
tok
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall a b. ConvertibleStrings a b => a -> b
convertString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Created resource: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
convertString ByteString
body
  case ByteString -> Either String Resource
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right Resource
ret -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak success: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Resource -> String
forall a. Show a => a -> String
show Resource
ret)
      ResourceId -> KeycloakT m ResourceId
forall (m :: * -> *) a. Monad m => a -> m a
return (ResourceId -> KeycloakT m ResourceId)
-> ResourceId -> KeycloakT m ResourceId
forall a b. (a -> b) -> a -> b
$ String -> Maybe ResourceId -> ResourceId
forall a. Partial => String -> Maybe a -> a
fromJustNote String
"create" (Maybe ResourceId -> ResourceId) -> Maybe ResourceId -> ResourceId
forall a b. (a -> b) -> a -> b
$ Resource -> Maybe ResourceId
resId Resource
ret
    Left String
err2 -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m ResourceId
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m ResourceId)
-> KCError -> KeycloakT m ResourceId
forall a b. (a -> b) -> a -> b
$ ClientId -> KCError
ParseError (ClientId -> KCError) -> ClientId -> KCError
forall a b. (a -> b) -> a -> b
$ String -> ClientId
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | Delete the resource
deleteResource :: MonadIO m => ResourceId -> JWT -> KeycloakT m ()
deleteResource :: ResourceId -> JWT -> KeycloakT m ()
deleteResource (ResourceId ClientId
rid) JWT
tok = do
  --tok2 <- getClientAuthToken 
  ClientId -> JWT -> KeycloakT m ()
forall (m :: * -> *).
MonadIO m =>
ClientId -> JWT -> KeycloakT m ()
keycloakDelete (ClientId
"authz/protection/resource_set/" ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
rid) JWT
tok
  () -> KeycloakT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Delete all resources in Keycloak
deleteAllResources :: MonadIO m => JWT ->  KeycloakT m ()
deleteAllResources :: JWT -> KeycloakT m ()
deleteAllResources JWT
tok = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Deleting all Keycloak resources..."
  [ResourceId]
ids <- KeycloakT m [ResourceId]
forall (m :: * -> *). MonadIO m => KeycloakT m [ResourceId]
getAllResourceIds
  [Either KCError ()]
res <- (ResourceId -> KeycloakT m (Either KCError ()))
-> [ResourceId] -> KeycloakT m [Either KCError ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ResourceId
rid -> KeycloakT m () -> KeycloakT m (Either KCError ())
forall (m :: * -> *) b.
Monad m =>
KeycloakT m b -> KeycloakT m (Either KCError b)
try (KeycloakT m () -> KeycloakT m (Either KCError ()))
-> KeycloakT m () -> KeycloakT m (Either KCError ())
forall a b. (a -> b) -> a -> b
$ ResourceId -> JWT -> KeycloakT m ()
forall (m :: * -> *).
MonadIO m =>
ResourceId -> JWT -> KeycloakT m ()
deleteResource ResourceId
rid JWT
tok) [ResourceId]
ids
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Deleted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([()] -> Int) -> [()] -> Int
forall a b. (a -> b) -> a -> b
$ [Either KCError ()] -> [()]
forall a b. [Either a b] -> [b]
rights [Either KCError ()]
res) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" resources out of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [ResourceId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [ResourceId]
ids)

-- | get a single resource
getResource :: MonadIO m => ResourceId -> JWT -> KeycloakT m Resource
getResource :: ResourceId -> JWT -> KeycloakT m Resource
getResource (ResourceId ClientId
rid) JWT
tok = do
  ByteString
body <- ClientId -> JWT -> KeycloakT m ByteString
forall (m :: * -> *).
MonadIO m =>
ClientId -> JWT -> KeycloakT m ByteString
keycloakGet (ClientId
"authz/protection/resource_set/" ClientId -> ClientId -> ClientId
forall a. Semigroup a => a -> a -> a
<> ClientId
rid) JWT
tok
  case ByteString -> Either String Resource
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right Resource
ret -> do
      Resource -> KeycloakT m Resource
forall (m :: * -> *) a. Monad m => a -> m a
return Resource
ret
    Left (String
err2 :: String) -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m Resource
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m Resource)
-> KCError -> KeycloakT m Resource
forall a b. (a -> b) -> a -> b
$ ClientId -> KCError
ParseError (ClientId -> KCError) -> ClientId -> KCError
forall a b. (a -> b) -> a -> b
$ String -> ClientId
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | get all resources IDs
getAllResourceIds :: MonadIO m => KeycloakT m [ResourceId]
getAllResourceIds :: KeycloakT m [ResourceId]
getAllResourceIds = do
  String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get all resources"
  JWT
tok2 <- KeycloakT m JWT
forall (m :: * -> *). MonadIO m => KeycloakT m JWT
getClientJWT 
  ByteString
body <- ClientId -> JWT -> KeycloakT m ByteString
forall (m :: * -> *).
MonadIO m =>
ClientId -> JWT -> KeycloakT m ByteString
keycloakGet (ClientId
"authz/protection/resource_set?max=1000") JWT
tok2
  case ByteString -> Either String [ResourceId]
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
    Right [ResourceId]
ret -> do
      [ResourceId] -> KeycloakT m [ResourceId]
forall (m :: * -> *) a. Monad m => a -> m a
return [ResourceId]
ret
    Left (String
err2 :: String) -> do
      String -> KeycloakT m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> KeycloakT m ()) -> String -> KeycloakT m ()
forall a b. (a -> b) -> a -> b
$ String
"Keycloak parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
err2) 
      KCError -> KeycloakT m [ResourceId]
forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError (KCError -> KeycloakT m [ResourceId])
-> KCError -> KeycloakT m [ResourceId]
forall a b. (a -> b) -> a -> b
$ ClientId -> KCError
ParseError (ClientId -> KCError) -> ClientId -> KCError
forall a b. (a -> b) -> a -> b
$ String -> ClientId
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | Update a resource
updateResource :: MonadIO m => Resource -> JWT ->  KeycloakT m ResourceId
updateResource :: Resource -> JWT -> KeycloakT m ResourceId
updateResource = Resource -> JWT -> KeycloakT m ResourceId
forall (m :: * -> *).
MonadIO m =>
Resource -> JWT -> KeycloakT m ResourceId
createResource