From ef97e195227a9a5d30eddd61cb8f0bbe2a52c25b Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Thu, 6 Oct 2022 10:25:09 +0200
Subject: [PATCH] chore(ldap): admin interface allows search by personal number

---
 src/Auth/LDAP.hs          |  6 +++---
 src/Handler/Admin/Ldap.hs | 42 ++++++++++++++++++++-------------------
 2 files changed, 25 insertions(+), 23 deletions(-)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 6d408e270..1990b40a3 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -86,7 +86,7 @@ ldapUserFirstName         = Ldap.Attr "givenName"
 ldapUserSurname           = Ldap.Attr "sn"
 ldapAffiliation           = Ldap.Attr "memberOf"   -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
 ldapUserTitle             = Ldap.Attr "title"      -- not used at Fraport
--- new 
+-- new
 ldapUserTelephone             = Ldap.Attr "telephoneNumber"
 ldapUserMobile                = Ldap.Attr "mobile"
 ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
@@ -173,7 +173,7 @@ newtype ADInvalidCredentials = ADInvalidCredentials ADError
 isUnusualADError :: ADError -> Bool
 isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure]
 
-  
+
 campusForm :: ( RenderMessage (HandlerSite m) FormMessage
               , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
               , RenderMessage (HandlerSite m) CampusMessage
@@ -233,7 +233,7 @@ campusLogin pool mode = AuthPlugin{..}
                 loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
           Right (Left bindErr) -> do
             case bindErr of
-              Ldap.ResponseErrorCode _ _ _ errTxt -> 
+              Ldap.ResponseErrorCode _ _ _ errTxt ->
                 $logInfoS apName [st|#{campusIdent}: #{errTxt}|]
               _other -> return ()
             $logDebugS apName "Invalid credentials"
diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs
index 9f305fb37..ba6632a07 100644
--- a/src/Handler/Admin/Ldap.hs
+++ b/src/Handler/Admin/Ldap.hs
@@ -6,7 +6,7 @@ module Handler.Admin.Ldap
   ) where
 
 import Import
--- import qualified Control.Monad.State.Class as State
+import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as Text
@@ -19,49 +19,51 @@ import Handler.Utils
 import qualified Ldap.Client as Ldap
 import Auth.LDAP
 
-newtype LdapQueryPerson = LdapQueryPerson
-      { ldapQueryIdent :: Text
+data LdapQueryPerson = LdapQueryPerson
+      { ldapQueryIdent :: Maybe Text
       -- , ldapQueryName  :: Maybe Text
-      -- , ldapQueryPNum  :: Maybe Text
+      , ldapQueryPNum  :: Maybe Text
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
 makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
   flip (renderAForm FormStandard) html $ LdapQueryPerson
-    <$> areq textField (fslI MsgAdminUserIdent)           (ldapQueryIdent  <$> tmpl)
+    <$> aopt textField (fslI MsgAdminUserIdent)           (ldapQueryIdent  <$> tmpl)
     -- <*> aopt textField (fslI MsgAdminUserSurname)         (ldapQueryName   <$> tmpl)
-    -- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum   <$> tmpl)
+    <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum   <$> tmpl)
 
 validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
-validateLdapQueryPerson = return () -- currently no tests needed
-  --LdapQueryPerson{..} <- State.get
-  --guardValidation MsgAvsQueryEmpty 
-    --is _Just ldapQueryIdent         ||
-    --is _Just ldapQueryName          ||
-    --is _Just ldapQueryPNum
+validateLdapQueryPerson = do
+  LdapQueryPerson{..} <- State.get
+  guardValidation MsgAvsQueryEmpty $
+    is _Just ldapQueryIdent         ||
+    -- is _Just ldapQueryName          ||
+    is _Just ldapQueryPNum
 
 
 
 getAdminLdapR,  postAdminLdapR :: Handler Html
-getAdminLdapR = postAdminLdapR 
+getAdminLdapR = postAdminLdapR
 postAdminLdapR = do
   ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
 
   let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
-      procFormPerson LdapQueryPerson{..} = do     
+      procFormPerson LdapQueryPerson{..} = do
         ldapPool'       <- getsYesod $ view _appLdapPool
 
         if isNothing ldapPool'
           then addMessage Warning $ text2Html "LDAP Configuration missing."
           else addMessage Info    $ text2Html "Input for LDAP test received."
-        fmap join . for ldapPool' $ \ldapPool -> do 
-          ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
-          decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
-          whenIsLeft decodedErr $ addMessageI Error 
+        fmap join . for ldapPool' $ \ldapPool -> do
+          ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser''    ldapPool FailoverUnlimited lqi
+                         | Just lqn <- ldapQueryPNum  -> campusUserMatr' ldapPool FailoverUnlimited lqn
+                         | otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
+          decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData
+          whenIsLeft decodedErr $ addMessageI Error
           return ldapData
 
-          
+
   mbLdapData <- formResultMaybe presult procFormPerson
 
 
@@ -73,7 +75,7 @@ postAdminLdapR = do
                       , formEncoding = penctype
                       }
 
-        presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)      
+        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