fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(admin): generalize admin ldap handler for all source types (TODO: rename)

Browse Source
This commit is contained in:
Sarah Vaupel 2024-03-08 09:56:54 +01:00
parent 969cc4df63
commit c9fa627651
2 changed files with 66 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
src/Handler/Admin/Ldap.hs
View File

@ -2,51 +2,62 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Admin.Ldap module Handler.Admin.Ldap
( getAdminLdapR ( getAdminLdapR
, postAdminLdapR , postAdminLdapR
) where ) where
import Import import Import
-- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,UserConversionException())
import Handler.Utils
import qualified Ldap.Client as Ldap import Foundation.Yesod.Auth (userLookupAndUpsert) -- decodeUserTest
import Auth.OAuth2 (queryOAuth2User)
import Auth.LDAP import Auth.LDAP
import Handler.Utils
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
-- TODO: used for every external source type => rename!
getAdminLdapR, postAdminLdapR :: Handler Html getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR getAdminLdapR = postAdminLdapR
postAdminLdapR = do postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList [])) let
procFormPerson lid = do presentUtf8 v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
ldapPool' <- getsYesod $ view _appLdapPool presentLatin1 v = Text.intercalate ", " ( Text.decodeLatin1 <$> v)
case ldapPool' of
Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
Just ldapPool@(ldapConf, _) -> do procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
addMessage Info $ text2Html "Input for LDAP test received." UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
ldapData <- ldapUser'' ldapPool lid AuthSourceConfAzureAdV2 AzureConf{..} -> do
decodedErr <- decodeUserTest UpsertUserDataLdap{ upsertUserLdapConf = ldapConf, upsertUserLdapData = concat ldapData } -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
whenIsLeft decodedErr $ addMessageI Error queryOAuth2User @[(Text,[ByteString])] needle >>= \case
return ldapData Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
mbLdapData <- formResultMaybe presult procFormPerson Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
AuthSourceConfLdap LdapConf{ ldapConfSourceId = authSourceIdLdapHost } -> do
getsYesod (view _appLdapPool) >>= \case
Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
Just pool -> do
ldapData <- ldapSearch pool needle
-- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
-- whenIsLeft decodedErr $ addMessageI Error
return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
mbData <- formResultMaybe presult procFormPerson
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormUpsert :: Text -> Handler (Maybe (Either UserConversionException (Entity User))) let procFormUpsert :: Text -> Handler (Maybe (Entity User))
procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser)
mbLdapUpsert <- formResultMaybe uresult procFormUpsert
mbUpsert <- formResultMaybe uresult procFormUpsert
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
@ -60,9 +71,6 @@ postAdminLdapR = do
{ formAction = Just $ SomeRoute actionUrl { formAction = Just $ SomeRoute actionUrl
, formEncoding = uenctype , formEncoding = uenctype
} }
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
-- TODO: use i18nWidgetFile instead if this is to become permanent -- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "ldap") $(widgetFile "ldap")

49
templates/ldap.hamlet
View File

@ -1,33 +1,44 @@
$newline never $newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> $# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
$# $#
$# SPDX-License-Identifier: AGPL-3.0-or-later $# SPDX-License-Identifier: AGPL-3.0-or-later
<section> <section>
<p> <p>
LDAP Person Search: Query external user databases:
^{personForm} ^{personForm}
$maybe answers <- mbLdapData $maybe responses <- mbData
<h1> <h1>
Antwort: # Responses: #
<dl .deflist> <dl .deflist>
$forall (lk, lv) <- answers $forall (source,responses) <- responses
$with numv <- length lv <dt .deflist__dt>
<dt> $case source
#{show lk} $of AuthSourceIdAzure tenantId
$if 1 < numv Azure Tenant ID: #
\ (#{show numv}) #{tshow tenantId}
<dd> $of AuthSourceIdLdap ldapHost
UTF8: #{presentUtf8 lv} LDAP host: #
&#8212; #{ldapHost}
Latin: #{presentLatin1 lv} <dd .deflist__dd>
<dl .deflist>
$forall (k,(numv,vUtf8,vLatin1)) <- responses
<dt .deflist__dt>
#{k}
$if 1 < numv
\ (#{show numv})
<dd .deflist__dd>
UTF8: #{vUtf8}
&#8212;
Latin: #{vLatin1}
<section> <section>
<p> <p>
LDAP Upsert user in DB: Upsert user from external database:
^{upsertForm} ^{upsertForm}
$maybe answer <- mbLdapUpsert $maybe response <- mbUpsert
<h1> <h1>
Antwort: # Response: #
<p> <p>
#{tshow answer} #{tshow response}