diff --git a/src/Handler/Admin/ExternalUser.hs b/src/Handler/Admin/ExternalUser.hs index 2a7226765..fc67a6616 100644 --- a/src/Handler/Admin/ExternalUser.hs +++ b/src/Handler/Admin/ExternalUser.hs @@ -15,10 +15,9 @@ 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 +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy getAdminExternalUserR, postAdminExternalUserR :: Handler Html @@ -28,25 +27,27 @@ postAdminExternalUserR = do flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing let - presentUtf8 v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v) - presentLatin1 v = Text.intercalate ", " ( Text.decodeLatin1 <$> v) + -- 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 :: Text -> Handler (Maybe [(AuthSourceIdent,Lazy.Text)]) -- (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 + queryOAuth2User @Value 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 + Right azureResponse -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) . Lazy.decodeUtf8 $ encodePretty azureResponse + -- Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs)) + AuthSourceConfLdap LdapConf{..} -> 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) + return . Just . singleton . (AuthSourceIdLdap ldapConfSourceId,) . Lazy.decodeUtf8 $ encodePretty ldapData + -- return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs) mbData <- formResultMaybe presult procFormPerson diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs index 9f2580333..04db439e6 100644 --- a/src/Ldap/Client/Instances.hs +++ b/src/Ldap/Client/Instances.hs @@ -19,6 +19,8 @@ import Utils.PathPiece (derivePathPiece) import Ldap.Client +import Network.HTTP.Types.Method.Instances () -- for FromJSON instance for ByteString + deriving instance Ord Attr deriving instance Ord Dn @@ -54,4 +56,6 @@ derivePersistField "Password" derivePersistField "Scope" deriveJSON defaultOptions ''Attr +deriveJSON defaultOptions ''Dn deriveJSON defaultOptions ''Scope +deriveJSON defaultOptions ''SearchEntry diff --git a/templates/admin/external-user.hamlet b/templates/admin/external-user.hamlet index 7016383a8..44f4b5af2 100644 --- a/templates/admin/external-user.hamlet +++ b/templates/admin/external-user.hamlet @@ -22,16 +22,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later LDAP host: # #{ldapHost}
+ #{responses}
+$#