diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index bd18d34e9..41c34afc1 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -2,51 +2,62 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later - - module Handler.Admin.Ldap ( getAdminLdapR , postAdminLdapR ) where 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 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 postAdminLdapR = do ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList [])) - procFormPerson lid = do - ldapPool' <- getsYesod $ view _appLdapPool - case ldapPool' of - Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing - Just ldapPool@(ldapConf, _) -> do - addMessage Info $ text2Html "Input for LDAP test received." - ldapData <- ldapUser'' ldapPool lid - decodedErr <- decodeUserTest UpsertUserDataLdap{ upsertUserLdapConf = ldapConf, upsertUserLdapData = concat ldapData } - whenIsLeft decodedErr $ addMessageI Error - return ldapData - mbLdapData <- formResultMaybe presult procFormPerson + let + presentUtf8 v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v) + presentLatin1 v = Text.intercalate ", " ( Text.decodeLatin1 <$> v) + + procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])]) + procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case + UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of + AuthSourceConfAzureAdV2 AzureConf{..} -> do + -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id + queryOAuth2User @[(Text,[ByteString])] needle >>= \case + Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing + 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 -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormUpsert :: Text -> Handler (Maybe (Either UserConversionException (Entity User))) - procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) - mbLdapUpsert <- formResultMaybe uresult procFormUpsert + let procFormUpsert :: Text -> Handler (Maybe (Entity User)) + procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser) + + mbUpsert <- formResultMaybe uresult procFormUpsert actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute @@ -60,9 +71,6 @@ postAdminLdapR = do { formAction = Just $ SomeRoute actionUrl , 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 $(widgetFile "ldap") diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index a2b2a1533..7016383a8 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -1,33 +1,44 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later
-

- LDAP Person Search: +

+ Query external user databases: ^{personForm} - $maybe answers <- mbLdapData + $maybe responses <- mbData

- Antwort: # + Responses: #
- $forall (lk, lv) <- answers - $with numv <- length lv -
- #{show lk} - $if 1 < numv - \ (#{show numv}) -
- UTF8: #{presentUtf8 lv} - — - Latin: #{presentLatin1 lv} + $forall (source,responses) <- responses +
+ $case source + $of AuthSourceIdAzure tenantId + Azure Tenant ID: # + #{tshow tenantId} + $of AuthSourceIdLdap ldapHost + LDAP host: # + #{ldapHost} +
+
+ $forall (k,(numv,vUtf8,vLatin1)) <- responses +
+ #{k} + $if 1 < numv + \ (#{show numv}) +
+ UTF8: #{vUtf8} + — + Latin: #{vLatin1} +

- LDAP Upsert user in DB: + Upsert user from external database: ^{upsertForm} - $maybe answer <- mbLdapUpsert + $maybe response <- mbUpsert

- Antwort: # + Response: #

- #{tshow answer} + #{tshow response}