{-# 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 :: forall (m :: * -> *).
MonadIO m =>
ResourceId -> ScopeName -> JWT -> KeycloakT m Bool
isAuthorized ResourceId
res ScopeName
scope JWT
tok = do
  Either KCError ()
r <- forall (m :: * -> *) b.
Monad m =>
KeycloakT m b -> KeycloakT m (Either KCError b)
U.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
ResourceId -> ScopeName -> JWT -> KeycloakT m ()
checkPermission ResourceId
res ScopeName
scope JWT
tok
  case Either KCError ()
r of
    Right ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Left KCError
e | (Status -> Int
statusCode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KCError -> Maybe Status
U.getErrorStatus KCError
e) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
403 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Left KCError
e -> 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 :: forall (m :: * -> *).
MonadIO m =>
[PermReq] -> JWT -> KeycloakT m [Permission]
getPermissions [PermReq]
reqs JWT
tok = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug [Char]
"Get all permissions"
  Text
client <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig Text
confResource
  let dat :: [FormParam]
dat = [ByteString
"grant_type" forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client,
             ByteString
"response_mode" forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"permissions" :: Text)] 
             forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (\Text
p -> ByteString
"permission" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
p) (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PermReq -> [Text]
getPermString [PermReq]
reqs)
  ByteString
body <- forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Text -> dat -> JWT -> KeycloakT m ByteString
keycloakPost Text
"protocol/openid-connect/token" [FormParam]
dat JWT
tok
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
    Right [Permission]
ret -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak returned perms: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Permission]
ret)
      forall (m :: * -> *) a. Monad m => a -> m a
return [Permission]
ret
    Left ([Char]
err2 :: String) -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Char]
err2) 
      forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (forall a. Show a => a -> [Char]
show [Char]
err2)
  where
    getPermString :: PermReq -> [Text]
    getPermString :: PermReq -> [Text]
getPermString (PermReq (Just (ResourceId Text
rid)) []) = [Text
rid]
    getPermString (PermReq (Just (ResourceId Text
rid)) [ScopeName]
scopes) = forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName Text
s) -> (Text
rid forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
s)) [ScopeName]
scopes
    getPermString (PermReq Maybe ResourceId
Nothing [ScopeName]
scopes) = forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName Text
s) -> (Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
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 :: forall (m :: * -> *).
MonadIO m =>
ResourceId -> ScopeName -> JWT -> KeycloakT m ()
checkPermission (ResourceId Text
res) (ScopeName Text
scope) JWT
tok = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Checking permissions: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Text
res) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Text
scope)
  Text
client <- forall (m :: * -> *) b.
Monad m =>
Getting b KCConfig b -> KeycloakT m b
viewConfig forall a b. (a -> b) -> a -> b
$ Lens' KCConfig AdapterConfig
confAdapterConfigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' AdapterConfig Text
confResource
  let dat :: [FormParam]
dat = [ByteString
"grant_type" forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client,
             ByteString
"permission"  forall v. FormValue v => ByteString -> v -> FormParam
:= Text
res forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
scope]
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Text -> dat -> JWT -> KeycloakT m ByteString
keycloakPost Text
"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 :: forall (m :: * -> *).
MonadIO m =>
Resource -> JWT -> KeycloakT m ResourceId
createResource Resource
r JWT
tok = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
convertString forall a b. (a -> b) -> a -> b
$ ByteString
"Creating resource: " forall a. Semigroup a => a -> a -> a
<> (forall a. ToJSON a => a -> ByteString
JSON.encode Resource
r)
  ByteString
body <- forall dat (m :: * -> *).
(Postable dat, Show dat, MonadIO m) =>
Text -> dat -> JWT -> KeycloakT m ByteString
keycloakPost Text
"authz/protection/resource_set" (forall a. ToJSON a => a -> Value
toJSON Resource
r) JWT
tok
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
convertString forall a b. (a -> b) -> a -> b
$ [Char]
"Created resource: " forall a. [a] -> [a] -> [a]
++ forall a b. ConvertibleStrings a b => a -> b
convertString ByteString
body
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
    Right Resource
ret -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak success: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Resource
ret)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Partial => [Char] -> Maybe a -> a
fromJustNote [Char]
"create" forall a b. (a -> b) -> a -> b
$ Resource -> Maybe ResourceId
resId Resource
ret
    Left [Char]
err2 -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Char]
err2) 
      forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (forall a. Show a => a -> [Char]
show [Char]
err2)

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

-- | Delete all resources in Keycloak
deleteAllResources :: MonadIO m => JWT ->  KeycloakT m ()
deleteAllResources :: forall (m :: * -> *). MonadIO m => JWT -> KeycloakT m ()
deleteAllResources JWT
tok = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug [Char]
"Deleting all Keycloak resources..."
  [ResourceId]
ids <- forall (m :: * -> *). MonadIO m => KeycloakT m [ResourceId]
getAllResourceIds
  [Either KCError ()]
res <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ResourceId
rid -> forall (m :: * -> *) b.
Monad m =>
KeycloakT m b -> KeycloakT m (Either KCError b)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
ResourceId -> JWT -> KeycloakT m ()
deleteResource ResourceId
rid JWT
tok) [ResourceId]
ids
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Deleted " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
L.length forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either KCError ()]
res) forall a. [a] -> [a] -> [a]
++ [Char]
" resources out of " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *).
MonadIO m =>
ResourceId -> JWT -> KeycloakT m Resource
getResource (ResourceId Text
rid) JWT
tok = do
  ByteString
body <- forall (m :: * -> *).
MonadIO m =>
Text -> JWT -> KeycloakT m ByteString
keycloakGet (Text
"authz/protection/resource_set/" forall a. Semigroup a => a -> a -> a
<> Text
rid) JWT
tok
  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
body of
    Right Resource
ret -> do
      forall (m :: * -> *) a. Monad m => a -> m a
return Resource
ret
    Left ([Char]
err2 :: String) -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Keycloak parse error: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [Char]
err2) 
      forall (m :: * -> *) a. Monad m => KCError -> KeycloakT m a
kcError forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (forall a. Show a => a -> [Char]
show [Char]
err2)

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

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