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

module Keycloak.Authorizations where

import           Control.Monad.Reader as R
import           Control.Monad.Except (throwError)
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           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 :: ResourceId -> ScopeName -> JWT -> Keycloak Bool
isAuthorized :: ResourceId -> ScopeName -> JWT -> Keycloak Bool
isAuthorized ResourceId
res ScopeName
scope JWT
tok = do
  Either KCError ()
r <- ReaderT KCConfig (ExceptT KCError IO) ()
-> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ())
forall a (m :: * -> *) b. MonadError a m => m b -> m (Either a b)
U.try (ReaderT KCConfig (ExceptT KCError IO) ()
 -> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ()))
-> ReaderT KCConfig (ExceptT KCError IO) ()
-> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ())
forall a b. (a -> b) -> a -> b
$ ResourceId
-> ScopeName -> JWT -> ReaderT KCConfig (ExceptT KCError IO) ()
checkPermission ResourceId
res ScopeName
scope JWT
tok
  case Either KCError ()
r of
    Right ()
_ -> Bool -> Keycloak 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 -> Keycloak Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Left KCError
e -> KCError -> Keycloak Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError KCError
e --rethrow the error

-- | Return the permissions for the permission requests.
getPermissions :: [PermReq] -> JWT -> Keycloak [Permission]
getPermissions :: [PermReq] -> JWT -> Keycloak [Permission]
getPermissions [PermReq]
reqs JWT
tok = do
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get all permissions"
  Text
client <- (KCConfig -> Text) -> ReaderT KCConfig (ExceptT KCError IO) Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Text
_confClientId
  let dat :: [FormParam]
dat = [ByteString
"grant_type" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client,
             ByteString
"response_mode" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"permissions" :: Text)] 
             [FormParam] -> [FormParam] -> [FormParam]
forall a. Semigroup a => a -> a -> a
<> (Text -> FormParam) -> [Text] -> [FormParam]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
p -> ByteString
"permission" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
p) ([[Text]] -> [Text]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (PermReq -> [Text]) -> [PermReq] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map PermReq -> [Text]
getPermString [PermReq]
reqs)
  ByteString
body <- Text -> [FormParam] -> JWT -> Keycloak ByteString
forall dat.
(Postable dat, Show dat) =>
Text -> dat -> JWT -> Keycloak ByteString
keycloakPost Text
"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 -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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] -> Keycloak [Permission]
forall (m :: * -> *) a. Monad m => a -> m a
return [Permission]
ret
    Left (String
err2 :: String) -> do
      String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> Keycloak [Permission]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak [Permission])
-> KCError -> Keycloak [Permission]
forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError (Text -> KCError) -> Text -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> String
forall a. Show a => a -> String
show String
err2)
  where
    getPermString :: PermReq -> [Text]
    getPermString :: PermReq -> [Text]
getPermString (PermReq (Just (ResourceId Text
rid)) []) = [Text
rid]
    getPermString (PermReq (Just (ResourceId Text
rid)) [ScopeName]
scopes) = (ScopeName -> Text) -> [ScopeName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName Text
s) -> (Text
rid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)) [ScopeName]
scopes
    getPermString (PermReq Maybe ResourceId
Nothing [ScopeName]
scopes) = (ScopeName -> Text) -> [ScopeName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopeName Text
s) -> (Text
"#" Text -> Text -> 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 :: ResourceId -> ScopeName -> JWT -> Keycloak ()
checkPermission :: ResourceId
-> ScopeName -> JWT -> ReaderT KCConfig (ExceptT KCError IO) ()
checkPermission (ResourceId Text
res) (ScopeName Text
scope) JWT
tok = do
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall a b. (a -> b) -> a -> b
$ String
"Checking permissions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
res) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
scope)
  Text
client <- (KCConfig -> Text) -> ReaderT KCConfig (ExceptT KCError IO) Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KCConfig -> Text
_confClientId
  let dat :: [FormParam]
dat = [ByteString
"grant_type" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= (Text
"urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
             ByteString
"audience" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
client,
             ByteString
"permission"  ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scope]
  Keycloak ByteString -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Keycloak ByteString -> ReaderT KCConfig (ExceptT KCError IO) ())
-> Keycloak ByteString -> ReaderT KCConfig (ExceptT KCError IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> [FormParam] -> JWT -> Keycloak ByteString
forall dat.
(Postable dat, Show dat) =>
Text -> dat -> JWT -> Keycloak ByteString
keycloakPost Text
"protocol/openid-connect/token" [FormParam]
dat JWT
tok


-- * Resource

-- | Create an authorization resource in Keycloak, under the configured client.
createResource :: Resource -> JWT -> Keycloak ResourceId
createResource :: Resource -> JWT -> Keycloak ResourceId
createResource Resource
r JWT
tok = do
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 <- Text -> Value -> JWT -> Keycloak ByteString
forall dat.
(Postable dat, Show dat) =>
Text -> dat -> JWT -> Keycloak ByteString
keycloakPost Text
"authz/protection/resource_set" (Resource -> Value
forall a. ToJSON a => a -> Value
toJSON Resource
r) JWT
tok
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> Keycloak ResourceId
forall (m :: * -> *) a. Monad m => a -> m a
return (ResourceId -> Keycloak ResourceId)
-> ResourceId -> Keycloak 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 -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> Keycloak ResourceId
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak ResourceId) -> KCError -> Keycloak ResourceId
forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError (Text -> KCError) -> Text -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> String
forall a. Show a => a -> String
show String
err2)

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

-- | Delete all resources in Keycloak
deleteAllResources :: JWT -> Keycloak ()
deleteAllResources :: JWT -> ReaderT KCConfig (ExceptT KCError IO) ()
deleteAllResources JWT
tok = do
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Deleting all Keycloak resources..."
  [ResourceId]
ids <- Keycloak [ResourceId]
getAllResourceIds
  [Either KCError ()]
res <- (ResourceId
 -> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ()))
-> [ResourceId]
-> ReaderT KCConfig (ExceptT KCError IO) [Either KCError ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ResourceId
rid -> ReaderT KCConfig (ExceptT KCError IO) ()
-> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ())
forall a (m :: * -> *) b. MonadError a m => m b -> m (Either a b)
try (ReaderT KCConfig (ExceptT KCError IO) ()
 -> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ()))
-> ReaderT KCConfig (ExceptT KCError IO) ()
-> ReaderT KCConfig (ExceptT KCError IO) (Either KCError ())
forall a b. (a -> b) -> a -> b
$ ResourceId -> JWT -> ReaderT KCConfig (ExceptT KCError IO) ()
deleteResource ResourceId
rid JWT
tok) [ResourceId]
ids
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 :: ResourceId -> JWT -> Keycloak Resource
getResource :: ResourceId -> JWT -> Keycloak Resource
getResource (ResourceId Text
rid) JWT
tok = do
  ByteString
body <- Text -> JWT -> Keycloak ByteString
keycloakGet (Text
"authz/protection/resource_set/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 -> Keycloak Resource
forall (m :: * -> *) a. Monad m => a -> m a
return Resource
ret
    Left (String
err2 :: String) -> do
      String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> Keycloak Resource
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak Resource) -> KCError -> Keycloak Resource
forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError (Text -> KCError) -> Text -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | get all resources IDs
getAllResourceIds :: Keycloak [ResourceId]
getAllResourceIds :: Keycloak [ResourceId]
getAllResourceIds = do
  String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Get all resources"
  JWT
tok2 <- Keycloak JWT
getClientJWT 
  ByteString
body <- Text -> JWT -> Keycloak ByteString
keycloakGet (Text
"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] -> Keycloak [ResourceId]
forall (m :: * -> *) a. Monad m => a -> m a
return [ResourceId]
ret
    Left (String
err2 :: String) -> do
      String -> ReaderT KCConfig (ExceptT KCError IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> ReaderT KCConfig (ExceptT KCError IO) ())
-> String -> ReaderT KCConfig (ExceptT KCError IO) ()
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 -> Keycloak [ResourceId]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KCError -> Keycloak [ResourceId])
-> KCError -> Keycloak [ResourceId]
forall a b. (a -> b) -> a -> b
$ Text -> KCError
ParseError (Text -> KCError) -> Text -> KCError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> String
forall a. Show a => a -> String
show String
err2)

-- | Update a resource
updateResource :: Resource -> JWT -> Keycloak ResourceId
updateResource :: Resource -> JWT -> Keycloak ResourceId
updateResource = Resource -> JWT -> Keycloak ResourceId
createResource