feat: automatically sync system functions from ldap

models/users.model

@@ -45,6 +45,8 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
 UserSystemFunction
     user     UserId
     function SystemFunction
+    manual   Bool
+    isOptOut Bool
     UniqueUserSystemFunction user function
 UserExamOffice
     user     UserId

src/Auth/LDAP.hs

@@ -10,6 +10,7 @@ module Auth.LDAP
   , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
   , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
   , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
+  , ldapAffiliation
   ) where
 
 import Import.NoFoundation
@@ -68,7 +69,7 @@ userSearchSettings LdapConf{..} = mconcat
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
-ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
+ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation :: Ldap.Attr
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
 ldapUserDisplayName       = Ldap.Attr "displayName"
 ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
@@ -80,6 +81,7 @@ ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach"
 ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
 ldapSex                   = Ldap.Attr "schacGender"
 ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
+ldapAffiliation           = Ldap.Attr "eduPersonAffiliation"
 
 ldapUserEmail :: NonEmpty Ldap.Attr
 ldapUserEmail = Ldap.Attr "mail" :|

src/Foundation/Yesod/Auth.hs

@@ -14,6 +14,7 @@ import Foundation.I18n
 import Handler.Utils.Profile
 import Handler.Utils.StudyFeatures
 import Handler.Utils.SchoolLdap
+import Handler.Utils.LdapSystemFunctions
 
 import Yesod.Auth.Message
 import Auth.LDAP
@@ -22,6 +23,7 @@ import qualified Data.CaseInsensitive as CI
 import qualified Control.Monad.Catch as C (Handler(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Ldap.Client as Ldap
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.ByteString as ByteString
 import qualified Data.Set as Set
@@ -425,6 +427,19 @@ upsertCampusUser plugin ldapData = do
 
   forM_ ss $ void . insertUnique . SchoolLdap Nothing
 
+  let
+    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
+    userSystemFunctions' = do
+      (k, v) <- ldapData
+      guard $ k == ldapAffiliation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      assertM' (not . Text.null) $ Text.strip str
+
+  iforM_ userSystemFunctions $ \func preset -> if
+    | preset -> void $ upsert (UserSystemFunction userId func False False) []
+    | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
+
   return user
   where
     insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())

src/Handler/Users.hs

@@ -101,6 +101,9 @@ postUsersR = do
                 $forall (E.Value sh) <- schools
                   <li>#{sh}
               |]
+      , sortable Nothing (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
+          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+           in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
           { formCellAttrs    = []
           , formCellLens     = id
@@ -289,7 +292,7 @@ postAdminUserR uuid = do
                    E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
         return (school, userFunction E.?. UserFunctionFunction, isAdmin)
 
-      systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid] []
+      systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
       let systemFunctions = (`Set.member` systemFunctionsF) 
 
       return ( user
@@ -380,9 +383,9 @@ postAdminUserR uuid = do
             | not $ Set.null symmDiff -> runDBJobs $ do
                 forM_ symmDiff $ \func -> if
                   | newFuncs func
-                    -> void . insertUnique $ UserSystemFunction uid func
+                    -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
                   | otherwise
-                    -> deleteBy $ UniqueUserSystemFunction uid func
+                    -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
                 queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
                 addMessageI Success MsgUserSystemFunctionsSaved
             | otherwise

src/Handler/Utils/LdapSystemFunctions.hs

@@ -0,0 +1,13 @@
+module Handler.Utils.LdapSystemFunctions
+  ( determineSystemFunctions
+  ) where
+
+import Import.NoFoundation
+
+import qualified Data.Set as Set
+
+
+determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
+determineSystemFunctions ldapFuncs = \case
+  SystemExamOffice -> False
+  SystemFaculty -> "faculty" `Set.member` ldapFuncs