{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Keycloak.Client where
import Control.Lens hiding ((.=))
import Control.Monad.Reader as R
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.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.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
isAuthorized :: ResourceId -> ScopeName -> Token -> Keycloak Bool
isAuthorized res scope tok = do
r <- try $ checkPermission res scope tok
case r of
Right _ -> return True
Left e | (statusCode <$> getErrorStatus e) == Just 403 -> return False
Left e -> throwError e
getPermissions :: [PermReq] -> Token -> Keycloak [Permission]
getPermissions reqs tok = do
debug "Get all permissions"
client <- asks _clientId
let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text),
"audience" := client,
"response_mode" := ("permissions" :: Text)]
<> map (\p -> "permission" := p) (join $ map getPermString reqs)
body <- keycloakPost "protocol/openid-connect/token" dat tok
case eitherDecode body of
Right ret -> do
return ret
Left (err2 :: String) -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
getPermString :: PermReq -> [Text]
getPermString (PermReq (Just (ResourceId id)) []) = [id]
getPermString (PermReq (Just (ResourceId id)) scopes) = map (\(ScopeName s) -> (id <> "#" <> s)) scopes
getPermString (PermReq Nothing scopes) = map (\(ScopeName s) -> ("#" <> s)) scopes
checkPermission :: ResourceId -> ScopeName -> Token -> Keycloak ()
checkPermission (ResourceId res) (ScopeName scope) tok = do
debug $ "Checking permissions: " ++ (show res) ++ " " ++ (show scope)
client <- asks _clientId
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 ()
getUserAuthToken :: Username -> Password -> Keycloak Token
getUserAuthToken username password = do
debug "Get user token"
client <- asks _clientId
secret <- asks _clientSecret
let dat = ["client_id" := client,
"client_secret" := secret,
"grant_type" := ("password" :: Text),
"password" := password,
"username" := username]
body <- keycloakPost' "protocol/openid-connect/token" dat
debug $ "Keycloak: " ++ (show body)
case eitherDecode body of
Right ret -> do
debug $ "Keycloak success: " ++ (show ret)
return $ Token $ convertString $ accessToken ret
Left err2 -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
getClientAuthToken :: Keycloak Token
getClientAuthToken = do
debug "Get client token"
client <- asks _clientId
secret <- asks _clientSecret
let dat = ["client_id" := client,
"client_secret" := secret,
"grant_type" := ("client_credentials" :: Text)]
body <- keycloakPost' "protocol/openid-connect/token" dat
case eitherDecode body of
Right ret -> do
debug $ "Keycloak success: " ++ (show ret)
return $ Token $ convertString $ accessToken ret
Left err2 -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
getUsername :: Token -> Username
getUsername (Token tok) = do
case JWT.decode $ convertString tok of
Just t -> case (unClaimsMap $ unregisteredClaims $ claims t) !? "preferred_username" of
Just (String un) -> un
_ -> error "preferred_username not present in token"
Nothing -> error "Error while decoding token"
createResource :: Resource -> Token -> Keycloak ResourceId
createResource r tok = do
debug $ convertString $ "Creating resource: " <> (JSON.encode r)
tok2 <- getClientAuthToken
body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok2
debug $ convertString $ "Created resource: " ++ convertString body
case eitherDecode body of
Right ret -> do
debug $ "Keycloak success: " ++ (show ret)
return $ fromJustNote "create" $ resId ret
Left err2 -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
deleteResource :: ResourceId -> Token -> Keycloak ()
deleteResource (ResourceId rid) tok = do
keycloakDelete ("authz/protection/resource_set/" <> rid) tok
return ()
deleteAllResources :: Token -> Keycloak ()
deleteAllResources tok = do
debug "Deleting all Keycloak resources..."
ids <- getAllResourceIds
res <- mapM (\rid -> try $ deleteResource rid tok) ids
debug $ "Deleted " ++ (show $ L.length $ rights res) ++ " resources out of " ++ (show $ L.length ids)
getResource :: ResourceId -> Keycloak Resource
getResource (ResourceId rid) = do
tok2 <- getClientAuthToken
body <- keycloakGet ("authz/protection/resource_set/" <> rid) tok2
case eitherDecode body of
Right ret -> do
return ret
Left (err2 :: String) -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
getAllResourceIds :: Keycloak [ResourceId]
getAllResourceIds = do
debug "Get all resources"
tok2 <- getClientAuthToken
body <- keycloakGet ("authz/protection/resource_set?max=1000") tok2
case eitherDecode body of
Right ret -> do
return ret
Left (err2 :: String) -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
updateResource :: Resource -> Token -> Keycloak ResourceId
updateResource = createResource
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
++ maybe [] (\f -> [("first", Just $ convertString $ show f)]) first
++ maybe [] (\u -> [("username", Just $ convertString u)]) username
body <- keycloakAdminGet ("users" <> (convertString $ renderQuery True query)) tok
debug $ "Keycloak success"
case eitherDecode body of
Right ret -> do
debug $ "Keycloak success: " ++ (show ret)
return ret
Left (err2 :: String) -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
getUser :: UserId -> Token -> Keycloak User
getUser (UserId id) tok = do
body <- keycloakAdminGet ("users/" <> (convertString id)) tok
debug $ "Keycloak success: " ++ (show body)
case eitherDecode body of
Right ret -> do
debug $ "Keycloak success: " ++ (show ret)
return ret
Left (err2 :: String) -> do
debug $ "Keycloak parse error: " ++ (show err2)
throwError $ ParseError $ pack (show err2)
postUser :: User -> Token -> Keycloak UserId
postUser user tok = do
res <- keycloakAdminPost ("users/") (toJSON user) tok
debug $ "Keycloak success: " ++ (show res)
return $ UserId $ convertString res
putUser :: UserId -> User -> Token -> Keycloak ()
putUser (UserId id) user tok = do
keycloakAdminPut ("users/" <> (convertString id)) (toJSON user) tok
return ()
keycloakPost :: (Postable dat, Show dat) => Path -> dat -> Token -> Keycloak BL.ByteString
keycloakPost path dat tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK POST with url: " ++ (show url)
debug $ " data: " ++ (show dat)
eRes <- C.try $ liftIO $ W.postWith opts url dat
case eRes of
Right res -> do
return $ fromJust $ res ^? responseBody
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakPost' :: (Postable dat, Show dat) => Path -> dat -> Keycloak BL.ByteString
keycloakPost' path dat = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults
let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK POST with url: " ++ (show url)
debug $ " data: " ++ (show dat)
eRes <- C.try $ liftIO $ W.postWith opts url dat
case eRes of
Right res -> do
return $ fromJust $ res ^? responseBody
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakDelete :: Path -> Token -> Keycloak ()
keycloakDelete path tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK DELETE with url: " ++ (show url)
debug $ " headers: " ++ (show $ opts ^. W.headers)
eRes <- C.try $ liftIO $ W.deleteWith opts url
case eRes of
Right res -> return ()
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakGet :: Path -> Token -> Keycloak BL.ByteString
keycloakGet path tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK GET with url: " ++ (show url)
debug $ " headers: " ++ (show $ opts ^. W.headers)
eRes <- C.try $ liftIO $ W.getWith opts url
case eRes of
Right res -> do
return $ fromJust $ res ^? responseBody
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakAdminGet :: Path -> Token -> Keycloak BL.ByteString
keycloakAdminGet path tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK GET with url: " ++ (show url)
debug $ " headers: " ++ (show $ opts ^. W.headers)
eRes <- C.try $ liftIO $ W.getWith opts url
case eRes of
Right res -> do
return $ fromJust $ res ^? responseBody
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakAdminPost :: (Postable dat, Show dat) => Path -> dat -> Token -> Keycloak BL.ByteString
keycloakAdminPost path dat tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK POST with url: " ++ (show url)
debug $ " data: " ++ (show dat)
eRes <- C.try $ liftIO $ W.postWith opts url dat
case eRes of
Right res -> do
debug $ (show eRes)
let headers = fromJust $ res ^? W.responseHeaders
return $ convertString $ L.last $ T.split (== '/') $ convertString $ fromJust $ lookup "Location" headers
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
keycloakAdminPut :: (Putable dat, Show dat) => Path -> dat -> Token -> Keycloak ()
keycloakAdminPut path dat tok = do
(KCConfig baseUrl realm _ _) <- ask
let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)]
let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path)
info $ "Issuing KEYCLOAK PUT with url: " ++ (show url)
debug $ " data: " ++ (show dat)
debug $ " headers: " ++ (show $ opts ^. W.headers)
eRes <- C.try $ liftIO $ W.putWith opts url dat
case eRes of
Right res -> return ()
Left err -> do
warn $ "Keycloak HTTP error: " ++ (show err)
throwError $ HTTPError err
debug, warn, info, err :: (MonadIO m) => String -> m ()
debug s = liftIO $ debugM "Keycloak" s
info s = liftIO $ infoM "Keycloak" s
warn s = liftIO $ warningM "Keycloak" s
err s = liftIO $ errorM "Keycloak" s
getErrorStatus :: KCError -> Maybe Status
getErrorStatus (HTTPError (HttpExceptionRequest _ (StatusCodeException r _))) = Just $ HC.responseStatus r
getErrorStatus _ = Nothing
try :: MonadError a m => m b -> m (Either a b)
try act = catchError (Right <$> act) (return . Left)