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

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")
 

templates/ldap.hamlet

@@ -1,33 +1,44 @@
 $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
 
 <section>
-  <p> 
-    LDAP Person Search:
+  <p>
+    Query external user databases:
     ^{personForm}
-  $maybe answers <- mbLdapData
+  $maybe responses <- mbData
     <h1>
-      Antwort: #
+      Responses: #
     <dl .deflist>
-      $forall (lk, lv) <- answers
-        $with numv <- length lv
-          <dt>
-            #{show lk}
-            $if 1 < numv
-              \ (#{show numv})
-          <dd>
-            UTF8:  #{presentUtf8 lv}
-            &#8212;
-            Latin: #{presentLatin1 lv}
+      $forall (source,responses) <- responses
+        <dt .deflist__dt>
+          $case source
+            $of AuthSourceIdAzure tenantId
+              Azure Tenant ID: #
+              #{tshow tenantId}
+            $of AuthSourceIdLdap ldapHost
+              LDAP host: #
+              #{ldapHost}
+        <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>
   <p>
-    LDAP Upsert user in DB:
+    Upsert user from external database:
     ^{upsertForm}
-  $maybe answer <- mbLdapUpsert
+  $maybe response <- mbUpsert
     <h1>
-      Antwort: #
+      Response: #
     <p>
-      #{tshow answer}
+      #{tshow response}