Merge branch 'schools' into 'master'

School/User-Overhaul

Closes #320

See merge request !263

config/settings.yml

@@ -41,6 +41,9 @@ health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
 health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
 health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
 
+synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:604800"
+synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"
+
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"
   all:           "_env:LOG_ALL:false"

frontend/src/services/html-helpers/html-helpers.js

@@ -24,7 +24,7 @@ export class HtmlHelpers {
   }
 
   _prefixIds(element, idPrefix) {
-    const idAttrs = ['id', 'for', 'data-conditional-input', 'data-modal-trigger'];
+    const idAttrs = ['id', 'for', 'list', 'data-conditional-input', 'data-modal-trigger'];
 
     idAttrs.forEach((attr) => {
       Array.from(element.querySelectorAll('[' + attr + ']')).forEach((input) => {

frontend/src/utils/mass-input/mass-input.js

@@ -1,5 +1,6 @@
 import { Utility } from '../../core/utility';
 import { Datepicker } from '../form/datepicker';
+import './mass-input.scss';
 
 const MASS_INPUT_CELL_SELECTOR = '.massinput__cell';
 const MASS_INPUT_ADD_CELL_SELECTOR = '.massinput__cell--add';

frontend/src/utils/mass-input/mass-input.scss

@@ -0,0 +1,18 @@
+.massinput-list__wrapper, .massinput-list__cell {
+  display: grid;
+  grid: auto / auto 50px;
+  max-width: 600px;
+  grid-gap: 7px;
+}
+
+.massinput-list__field {
+  grid-column: 1;
+}
+
+.massinput-list__add, .massinput-list__delete {
+  grid-column: 2;
+}
+
+.massinput-list__cell {
+  grid-column: 1 / 3;
+}

messages/uniworx/de.msg

@@ -581,7 +581,7 @@ RatingFilesUpdated: Korrigierte Dateien überschrieben
 RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
 RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
 RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
-RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
+RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
 RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
 RatingNegative: Bewertungspunkte dürfen nicht negativ sein
 RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
@@ -615,7 +615,8 @@ TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
 CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
 ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
 UserListTitle: Komprehensive Benutzerliste
-AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
+AccessRightsSaved: Berechtigungen erfolgreich verändert
+AccessRightsNotChanged: Berechtigungen wurden nicht verändert
 
 LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"}
 
@@ -628,6 +629,8 @@ DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern a
 WarningDays: Fristen-Vorschau
 WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
 NotificationSettings: Erwünschte Benachrichtigungen
+UserSchools: Relevante Institute
+UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute, die hier ausgewählt sind.
 FormNotifications: Benachrichtigungen
 FormBehaviour: Verhalten
 FormCosmetics: Oberfläche
@@ -662,7 +665,8 @@ CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermi
 CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
 CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
 CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
-CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr}
+CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Campus-Logins keine Studiengänge ermitteln
+CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Campus-Logins keine Institute ermitteln
 
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
@@ -861,6 +865,8 @@ NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
 NotificationTriggerKindCorrector: Für Korrektoren
 NotificationTriggerKindLecturer: Für Dozenten
 NotificationTriggerKindAdmin: Für Administratoren
+NotificationTriggerKindExamOffice: Für das Prüfungsamt
+NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
 
 CorrCreate: Abgaben erstellen
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@@ -1031,6 +1037,8 @@ MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
 MenuLecturerInvite: Dozenten hinzufügen
 MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
 MenuCourseApplicationsFiles: Dateien aller Bewerbungen
+MenuSchoolList: Institute
+MenuSchoolNew: Neues Institut anlegen
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1489,17 +1497,18 @@ PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
 UserPasswordHeadingFor: Passwort ändern für
 PasswordChangedSuccess: Passwort erfolgreich geändert
 
-LecturerInviteSchool: Institut
+FunctionaryInviteFunction: Funktion
-LecturerInviteField: Einzuladende EMail Addressen
+FunctionaryInviteSchool: Institut
-LecturerInviteHeading: Dozenten hinzufügen
+FunctionaryInviteField: Einzuladende EMail Addressen
+FunctionaryInviteHeading: Institut-Funktionäre hinzufügen
 
-LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen
+FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per EMail eingeladen
-LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen
+FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen
 
-MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“
+MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“
-MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“
+MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“
-SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
+SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts.
-SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
+SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen
 
 AllocationActive: Aktiv
 AllocationName: Name
@@ -1562,4 +1571,20 @@ CourseApplicationNoRatingPoints: Keine Bewertung
 CourseApplicationNoRatingComment: Kein Kommentar
 
 UserDisplayName: Voller Name
-UserMatriculation: Matrikelnummer
+UserMatriculation: Matrikelnummer
+
+SchoolShort: Kürzel
+SchoolName: Name
+SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
+SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
+
+SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
+SchoolTitle ssh@SchoolId: Institut „#{ssh}“
+TitleSchoolNew: Neues Institut anlegen
+SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt
+SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits
+
+SchoolAdmin: Admin
+SchoolLecturer: Dozent
+SchoolEvaluation: Kursumfragenverwaltung
+SchoolExamOffice: Prüfungsamt

models/schools

@@ -6,4 +6,11 @@ School json
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
     Primary shorthand        -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
-    deriving Eq Show Generic
+    deriving Ord Eq Show Generic
+SchoolLdap
+    school  SchoolId Maybe
+    orgUnit (CI Text)
+    UniqueOrgUnit orgUnit
+SchoolTerms
+    school  SchoolId
+    terms   StudyTermsId

models/users

@@ -14,6 +14,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     ident          (CI Text)                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
+    created        UTCTime default=now()
+    lastLdapSynchronisation UTCTime Maybe
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
     firstName      Text                     -- For export in tables, pre-split firstName from displayName
@@ -30,14 +32,20 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
-UserAdmin      -- Each row in this table grants school-specific administrator-rights to a specific user
+UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
-    user   UserId
+    user     UserId
-    school SchoolId
+    school   SchoolId
-    UniqueUserAdmin user school       -- combination of user+school must be unique, i.e. no duplicate rows
+    function SchoolFunction
-UserLecturer   -- Each row in this table grants school-specific lecturer-rights to a specific user
+    UniqueUserFunction user school function
-    user   UserId
+UserExamOffice
-    school SchoolId
+    user     UserId
-    UniqueSchoolLecturer user school  -- combination of user+school must be unique, i.e. no duplicate rows
+    field    StudyTermsId
+    UniqueUserExamOffice user field
+UserSchool -- Managed by users themselves, encodes "schools of interest"
+    user     UserId
+    school   SchoolId
+    isOptOut Bool     -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically 
+    UniqueUserSchool user school
 StudyFeatures  -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
     user          UserId
     degree        StudyDegreeId   -- Abschluss, i.e. Master, Bachelor, etc.

routes

@@ -49,8 +49,8 @@
 /users/#CryptoUUIDUser/hijack AdminHijackUserR     POST       !adminANDno-escalation
 /users/#CryptoUUIDUser/notifications UserNotificationR GET POST   !self
 /users/#CryptoUUIDUser/password      UserPasswordR     GET POST   !selfANDis-pw-hash
-!/users/lecturer-invite/new    AdminNewLecturerInviteR  GET POST
+!/users/functionary-invite/new AdminNewFunctionaryInviteR  GET POST
-!/users/lecturer-invite        AdminLecturerInviteR     GET POST
+!/users/functionary-invite     AdminFunctionaryInviteR     GET POST
 /admin                        AdminR           GET
 /admin/features               AdminFeaturesR   GET POST
 /admin/test                   AdminTestR       GET POST
@@ -78,8 +78,10 @@
 !/term/#TermId             TermCourseListR     GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET          !free
 
-/school                    SchoolListR         GET             !development
+/school                    SchoolListR         GET
-/school/#SchoolId          SchoolShowR         GET             !development
+!/school/new               SchoolNewR          GET POST
+/school/#SchoolId          SchoolR:
+  /                        SchoolEditR         GET POST
 
 /allocation/               AllocationListR     GET             !free
 /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:

src/Auth/LDAP.hs

@@ -2,14 +2,15 @@ module Auth.LDAP
   ( apLdap
   , campusLogin
   , CampusUserException(..)
-  , campusUser
+  , campusUser, campusUser'
   , CampusMessage(..)
   , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
   , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
   , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
+  , ldapUserSchoolAssociation
   ) where
 
-import Import.NoFoundation hiding (userEmail, userDisplayName)
+import Import.NoFoundation
 import Network.Connection
 
 import Data.CaseInsensitive (CI)
@@ -58,16 +59,17 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
       , Ldap.derefAliases Ldap.DerefAlways
       ]
 
-ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
+ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
-ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
+ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
-ldapUserEmail         = Ldap.Attr "mail"
+ldapUserEmail             = Ldap.Attr "mail"
-ldapUserDisplayName   = Ldap.Attr "displayName"
+ldapUserDisplayName       = Ldap.Attr "displayName"
-ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
+ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
-ldapUserFirstName     = Ldap.Attr "givenName"
+ldapUserFirstName         = Ldap.Attr "givenName"
-ldapUserSurname       = Ldap.Attr "sn"
+ldapUserSurname           = Ldap.Attr "sn"
-ldapUserTitle         = Ldap.Attr "title"
+ldapUserTitle             = Ldap.Attr "title"
-ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
+ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
-ldapUserFieldName     = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+ldapUserFieldName         = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" 
 
 
 data CampusUserException = CampusUserLdapError LdapPoolError
@@ -80,6 +82,8 @@ data CampusUserException = CampusUserLdapError LdapPoolError
 
 instance Exception CampusUserException
 
+makePrisms ''CampusUserException
+
 campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
 campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
   Ldap.bind ldap ldapDn ldapPassword
@@ -105,6 +109,10 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
                   , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
                   ]
 
+campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
+campusUser' conf pool User{userIdent}
+  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
+
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage

src/Database/Esqueleto/Utils.hs

@@ -64,6 +64,8 @@ false = E.val False
 isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
 isJust = E.not_ . E.isNothing
 
+infix 4 `isInfixOf`, `hasInfix`
+
 -- | Check if the first string is contained in the text derived from the second argument
 isInfixOf :: ( E.Esqueleto query expr backend
              , E.SqlString s1

src/Foundation.hs

@@ -65,6 +65,7 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
 import qualified Control.Monad.Catch as C
 
 import Handler.Utils.StudyFeatures
+import Handler.Utils.SchoolLdap
 import Utils.Form
 import Utils.Sheet
 import Utils.SystemMessage
@@ -152,6 +153,7 @@ deriving instance Generic TutorialR
 deriving instance Generic ExamR
 deriving instance Generic CourseApplicationR
 deriving instance Generic AllocationR
+deriving instance Generic SchoolR
 deriving instance Generic (Route UniWorX)
 
 -- | Convenient Type Synonyms:
@@ -310,6 +312,7 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
 embedRenderMessage ''UniWorX ''UploadModeDescr id
 embedRenderMessage ''UniWorX ''SecretJSONFieldException id
 embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
+embedRenderMessage ''UniWorX ''SchoolFunction id
 
 embedRenderMessage ''UniWorX ''AuthenticationMode id
 
@@ -606,8 +609,9 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
-      E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
+      E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
-      E.where_  $ userAdmin E.^. UserAdminUser E.==. E.val authId
+      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
+            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
@@ -617,17 +621,24 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
-      E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool
+      E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
-      E.where_  $ userAdmin E.^. UserAdminUser E.==. E.val authId
+      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
+            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
             E.&&. allocation E.^. AllocationTerm      E.==. E.val tid
             E.&&. allocation E.^. AllocationSchool    E.==. E.val ssh
             E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
     guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
     return Authorized
+  -- Schools: access only to school admins
+  SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
+    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
+    return Authorized
   -- other routes: access to any admin is granted here
   _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-    adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
+    adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
 tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
@@ -636,10 +647,9 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
     uid <- decrypt cID
-    otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
+    otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
-    otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
+    mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
-    mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
+    guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
-    guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
     return Authorized
   r -> $unsupportedAuthPredicate AuthNoEscalation r
 tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
@@ -680,7 +690,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
   -- lecturer for any school will do
   _ -> $cachedHereBinary mAuthId . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
+     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
      return Authorized
 tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -1736,6 +1746,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb AdminFeaturesR   = return ("Test"         , Just AdminR)
   breadcrumb AdminTestR       = return ("Test"         , Just AdminR)
   breadcrumb AdminErrMsgR     = return ("Test"         , Just AdminR)
+  
+  breadcrumb SchoolListR      = return ("Institute"    , Just AdminR)
+  breadcrumb (SchoolR ssh SchoolEditR) = return (original (unSchoolKey ssh), Just SchoolListR)
+  breadcrumb SchoolNewR       = return ("Neu"          , Just SchoolListR)
 
   breadcrumb InfoR            = return ("Information"  , Nothing)
   breadcrumb InfoLecturerR    = return ("Veranstalter" , Just InfoR)
@@ -2009,6 +2023,14 @@ pageActions (HomeR) =
   ]
 pageActions (AdminR) =
   [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuSchoolList
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute SchoolListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgAdminFeaturesHeading
       , menuItemIcon  = Nothing
@@ -2041,12 +2063,22 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (SchoolListR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuSchoolNew
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute SchoolNewR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (UsersR) =
   [ MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuLecturerInvite
       , menuItemIcon  = Nothing
-      , menuItemRoute = SomeRoute AdminNewLecturerInviteR
+      , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
@@ -2874,13 +2906,6 @@ pageHeading (TermSchoolCourseListR tid ssh)
       School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
       i18nHeading $ MsgTermSchoolCourseListHeading tid school
 
-pageHeading (SchoolListR)
-  = Just $ i18nHeading MsgSchoolListHeading
-pageHeading (SchoolShowR ssh)
-  = Just $ do
-      School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
-      i18nHeading $ MsgSchoolHeading school
-
 pageHeading (CourseListR)
   = Just $ i18nHeading $ MsgCourseListTitle
 pageHeading CourseNewR
@@ -3019,7 +3044,8 @@ data CampusUserConversionException
   | CampusUserInvalidSurname
   | CampusUserInvalidTitle
   | CampusUserInvalidMatriculation
-  | CampusUserInvalidFeaturesOfStudy String
+  | CampusUserInvalidFeaturesOfStudy Text
+  | CampusUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 instance Exception CampusUserConversionException
 
@@ -3097,12 +3123,15 @@ upsertCampusUser ldapData Creds{..} = do
       , userNotificationSettings = def
       , userMailLanguages        = def
       , userTokensIssuedAfter    = Nothing
+      , userCreated              = now
+      , userLastLdapSynchronisation = Just now
       , ..
       }
-    userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
+    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
-                  , UserDisplayName        =. userDisplayName
+                  , UserDisplayName             =. userDisplayName
-                  , UserSurname            =. userSurname
+                  , UserSurname                 =. userSurname
-                  , UserEmail              =. userEmail
+                  , UserEmail                   =. userEmail
+                  , UserLastLdapSynchronisation =. Just now
                   ] ++
                   [ UserLastAuthentication =. Just now | not isDummy ]
 
@@ -3124,7 +3153,7 @@ upsertCampusUser ldapData Creds{..} = do
       Right str <- return $ Text.decodeUtf8' v'
       return str
 
-  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
+  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
 
   let
     studyTermCandidates = Set.fromList $ do
@@ -3154,13 +3183,56 @@ upsertCampusUser ldapData Creds{..} = do
     insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
     insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
     void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
+  associateUserSchoolsByTerms userId
 
+  let
+    userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
+    userAssociatedSchools' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSchoolAssociation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+  
+  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
+
+  forM_ ss $ \frag -> void . runMaybeT $ do
+    let
+      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
+      infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
+        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
+             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
+        return schoolLdap
+    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
+    ssh <- hoistMaybe schoolLdapSchool
+
+    lift . void $ insertUnique UserSchool
+      { userSchoolUser     = userId
+      , userSchoolSchool   = ssh
+      , userSchoolIsOptOut = False
+      }
+
+  forM_ ss $ void . insertUnique . SchoolLdap Nothing
+  
   return user
   where
     insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
     isDummy  = credsPlugin == "dummy"
     isPWHash = credsPlugin == "PWHash"
 
+associateUserSchoolsByTerms :: UserId -> DB ()
+associateUserSchoolsByTerms uid = do
+  sfs <- selectList [StudyFeaturesUser ==. uid] []
+
+  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
+    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
+    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
+      void $ insertUnique UserSchool
+        { userSchoolUser     = uid
+        , userSchoolSchool   = schoolTermsSchool
+        , userSchoolIsOptOut = False
+        }
+
 
 instance YesodAuth UniWorX where
     type AuthId UniWorX = UserId
@@ -3222,6 +3294,11 @@ instance YesodAuth UniWorX where
 
         acceptExisting = do
           res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+          case res of
+            Authenticated uid
+              -> associateUserSchoolsByTerms uid
+            _other
+              -> return ()
           case res of
             Authenticated uid
               | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]

src/Handler/Admin.hs

@@ -289,6 +289,7 @@ instance Button UniWorX ButtonAdminStudyTerms where
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
+    uid <- requireAuthId
     ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
     let btnForm = wrapForm btnWdgt def
           { formAction = Just $ SomeRoute AdminFeaturesR
@@ -322,11 +323,21 @@ postAdminFeaturesR = do
     newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
-      , ((), candidateTable)) <- runDB $ (,,)
+      , ((), candidateTable)
-      <$> mkDegreeTable
+      , userSchools) <- runDB $ do
-      <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+      schools <- E.select . E.from $ \school -> do
-                            (Set.fromList $ map entityKey infConflicts)
+        E.where_ . E.exists . E.from $ \schoolFunction ->
-      <*> mkCandidateTable
+          E.where_ $ schoolFunction E.^. UserFunctionSchool   E.==. school E.^. SchoolId
+               E.&&. schoolFunction E.^. UserFunctionUser     E.==. E.val uid
+               E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+        return school
+      (,,,)
+        <$> mkDegreeTable
+        <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+                              (Set.fromList $ map entityKey infConflicts)
+                              (Set.fromList schools)
+        <*> mkCandidateTable
+        <*> pure schools
 
     -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
     unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
@@ -341,12 +352,16 @@ postAdminFeaturesR = do
       void . runDB $ Map.traverseWithKey updateDegree res
       addMessageI Success MsgStudyDegreeChangeSuccess
 
-    let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text))
+    let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
         studyTermsResult' = studyTermsResult <&> getDBFormResult
-          (\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
+          (\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
-                   , row ^. _dbrOutput . _entityVal . _studyTermsShorthand
+                   , row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
+                   , row ^. _dbrOutput . _2
           ))
-        updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
+        updateStudyTerms studyTermsKey (name,short,schools) = do
+          update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
+          forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
+          deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
     formResult studyTermsResult' $ \res -> do
       void . runDB $ Map.traverseWithKey updateStudyTerms res
       addMessageI Success MsgStudyTermsChangeSuccess
@@ -355,24 +370,41 @@ postAdminFeaturesR = do
       setTitleI MsgAdminFeaturesHeading
       $(widgetFile "adminFeatures")
   where
-    textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
+    textInputCell :: Ord i
+                  => Lens' a (Maybe Text)
+                  -> Getter (DBRow r) (Maybe Text)
+                  -> Getter (DBRow r) i
+                  -> DBRow r 
+                  -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
+    textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
       (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
         <$> mopt textField "" (Just $ row ^. lensDefault)
       )
+  
+    checkboxCell :: Ord i
+                 => Lens' a Bool
+                 -> Getter (DBRow r) Bool
+                 -> Getter (DBRow r) i
+                 -> DBRow r 
+                 -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
+    checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+        <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
+      )
 
 
     mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
     mkDegreeTable =
       let dbtIdent      = "admin-studydegrees" :: Text
           dbtStyle      = def
-          dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree))
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
           dbtSQLQuery   = return
           dbtRowKey     = (E.^. StudyDegreeKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
             [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
-            , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
+            , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
+            , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
             , dbRow
             ]
           dbtSorting    = Map.fromList
@@ -390,20 +422,29 @@ postAdminFeaturesR = do
           dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 
-    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
+    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
-    mkStudytermsTable newKeys badKeys =
+    mkStudytermsTable newKeys badKeys schools =
       let dbtIdent      = "admin-studyterms" :: Text
           dbtStyle      = def
-          dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
           dbtSQLQuery   = return
           dbtRowKey     = (E.^. StudyTermsKey)
-          dbtProj       = return
+          dbtProj field = do
+            fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
+              E.where_ . E.exists . E.from $ \schoolTerms ->
+                E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
+                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val (field ^. _dbrOutput . _entityKey)
+              E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
+              return $ school E.^. SchoolId
+            return $ field & _dbrOutput %~ (, fieldSchools)
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
+            , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
+                sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
             , dbRow
             ]
           dbtSorting    = Map.fromList

src/Handler/Course/Application/Edit.hs

@@ -19,8 +19,8 @@ postCAEditR tid ssh csh cID = do
     mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
     appUser <- get404 $ courseApplicationUser app
     isAdmin <- case mAlloc of
-      Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
+      Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin]
-      Nothing    -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool]
+      Nothing    -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin]
     return (mAlloc, course, app, isAdmin, appUser)
 
   afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR

src/Handler/Course/Application/List.hs

@@ -525,6 +525,7 @@ postCApplicationsR tid ssh csh = do
 
       psValidator :: PSValidator _ _
       psValidator = def
+        & defaultSorting [SortAscBy "user-name"]
 
     dbTableWidget' psValidator DBTable{..}
 

src/Handler/Course/Edit.hs

@@ -105,10 +105,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
     MsgRenderer mr <- getMsgRenderer
 
     uid <- liftHandlerT requireAuthId
-    (lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
+    userSchools <- liftHandlerT . runDB $ map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] []
-      <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
-      <*> (map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. uid] [] )
-    let userSchools = lecSchools ++ admSchools
 
     termsField <- case template of
           -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@@ -278,11 +275,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
       _ -> (result, widget)
 
 
-validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
+validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
 validateCourse CourseForm{..} = do
   now <- liftIO getCurrentTime
   uid <- liftHandlerT requireAuthId
-  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
+  userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
   MsgRenderer mr <- getMsgRenderer
   allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
 
@@ -291,7 +288,7 @@ validateCourse CourseForm{..} = do
     prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
 
     fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
-      | is _Just userAdmin
+      | userAdmin
         -> return Nothing
       | NTop allocationStaffRegisterTo <= NTop (Just now)
         -> Just . courseCapacity <$> getJust cid
@@ -309,7 +306,7 @@ validateCourse CourseForm{..} = do
           ( NTop cfRegFrom <= NTop cfDeRegUntil
           , MsgCourseDeregistrationEndMustBeAfterStart
           )
-        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+        , ( bool (anyOf (traverse . _Right . _1) (== uid) cfLecturers) True userAdmin
           , MsgCourseUserMustBeLecturer
           )
         , ( is _Nothing cfAllocation || is _Just cfCapacity
@@ -357,8 +354,9 @@ getCourseNewR = do
                       E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
           let lecturersSchool =
                 E.exists $ E.from $ \user ->
-                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                  E.where_ $ user E.^. UserFunctionUser     E.==. E.val uid
-                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+                      E.&&.  user E.^. UserFunctionSchool   E.==. course E.^. CourseSchool
+                      E.&&.  user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
           let courseCreated c =
                 E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
                   E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
@@ -527,17 +525,16 @@ courseEditHandler miButtonAction mbCourseForm = do
         , formEncoding = formEnctype
         }
 
-upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
+upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
 upsertAllocationCourse cid cfAllocation = do
   now <- liftIO getCurrentTime
-  uid <- liftHandlerT requireAuthId
   Course{..} <- getJust cid
   prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
   prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
-  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
+  userAdmin <- hasWriteAccessTo $ SchoolR courseSchool SchoolEditR
 
   doEdit <- if
-    | is _Just userAdmin
+    | userAdmin
       -> return True
     | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
     , NTop allocationStaffRegisterTo <= NTop (Just now)

src/Handler/Course/LecturerInvite.hs

@@ -61,7 +61,7 @@ lecturerInvitationConfig = InvitationConfig{..}
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
     invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
     invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

src/Handler/Course/ParticipantInvite.hs

@@ -74,7 +74,7 @@ participantInvitationConfig = InvitationConfig{..}
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
     invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
     invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
-    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
+    invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

src/Handler/Exam/CorrectorInvite.hs

@@ -61,7 +61,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 examCourse
       return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

src/Handler/Exam/RegistrationInvite.hs

@@ -69,7 +69,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 examCourse
       return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
     invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
       itAuthority <- liftHandlerT requireAuthId
       let itExpiresAt = Just $ Just invDBExamRegistrationDeadline

src/Handler/Profile.hs

@@ -15,6 +15,7 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 -- import           Database.Esqueleto      ((^.))
 
+import qualified Data.CaseInsensitive as CI
 
 
 data SettingsForm = SettingsForm
@@ -25,15 +26,31 @@ data SettingsForm = SettingsForm
       , stgTime          :: DateTimeFormat
       , stgDownloadFiles :: Bool
       , stgWarningDays   :: NominalDiffTime
+      , stgSchools       :: Set SchoolId
       , stgNotificationSettings :: NotificationSettings
       }
 
-data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin
+data NotificationTriggerKind
-  deriving (Eq, Ord, Enum, Bounded, Generic, Typeable)
+  = NTKAll
-instance Universe NotificationTriggerKind
+  | NTKCourseParticipant
-instance Finite NotificationTriggerKind
+  | NTKExamParticipant
+  | NTKCorrector
+  | NTKFunctionary SchoolFunction
+  deriving (Eq, Ord, Generic, Typeable)
+deriveFinite ''NotificationTriggerKind
 
-embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel
+instance RenderMessage UniWorX NotificationTriggerKind where
+  renderMessage f ls = \case
+    NTKAll -> mr MsgNotificationTriggerKindAll
+    NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
+    NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
+    NTKCorrector -> mr MsgNotificationTriggerKindCorrector
+    NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
+    NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
+    NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
+    NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation
+    where
+      mr = renderMessage f ls
 
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@@ -55,38 +72,36 @@ makeSettingForm template html = do
                 & setTooltip MsgWarningDaysTip
               ) (stgWarningDays <$> template)
         <*  aformSection MsgFormNotifications
+        <*> schoolsForm (stgSchools <$> template)
         <*> notificationForm (stgNotificationSettings <$> template)
     return (result, widget) -- no validation required here
   where
     themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]
---
+
--- Version with proper grouping:
+schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
---
+schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
--- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
+  where
--- makeSettingForm template = identForm FIDsettings $ \html -> do
+    schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
---     (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2
+    schoolsForm' = do
---       <$> aFormGroup "Cosmetics"     cosmeticsForm
+      allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
---       <*> aFormGroup "Notifications" notificationsForm
+
---       <*  submitButton
+      let
---     return (result, widget) -- no validation required here
+        schoolForm (Entity ssh School{schoolName})
---   where
+          = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template)
---     settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm
+
---     settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm
+      fold <$> mapM schoolForm allSchools
---     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
+
---     cosmeticsForm = (,,,,)
+    schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX])
---       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
+    schoolsFormView (res, fvInput) = do
---             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+      mr <- getMessageRender
---       <*> areq (selectField . return $ mkOptionList themeList)
+      let fvLabel = toHtml $ mr MsgUserSchools
---             (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
+          fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
+          fvRequired = False
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
+          fvErrors
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+            | FormFailure (err : _) <- res = Just $ toHtml err
---     notificationsForm = (,)
+            | otherwise = Nothing
---       <$> areq checkBoxField (fslI MsgDownloadFiles
+      fvId <- newIdent
---                                & setTooltip MsgDownloadFilesTip
+      return (res, pure FieldView{..})
---                              ) (stgDownloadFiles <$> template)
---       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
---     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
 notificationForm template = wFormToAForm $ do
@@ -99,13 +114,10 @@ notificationForm template = wFormToAForm $ do
       | isAdmin
       = return False
       | Just uid <- mbUid
-      , NTKAdmin <- nt
+      , NTKFunctionary f <- nt
-      = fmap not . E.selectExists . E.from $ \userAdmin ->
+      = fmap not . E.selectExists . E.from $ \userFunction ->
-          E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+          E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
-      | Just uid <- mbUid
+               E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
-      , NTKLecturer <- nt
-      = fmap not . E.selectExists . E.from $ \userLecturer ->
-          E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
       | Just uid <- mbUid
       , NTKCorrector <- nt
       = fmap not . E.selectExists . E.from $ \sheetCorrector ->
@@ -141,9 +153,9 @@ notificationForm template = wFormToAForm $ do
       NTSubmissionRated           -> Just NTKCourseParticipant
       NTSheetActive               -> Just NTKCourseParticipant
       NTSheetSoonInactive         -> Just NTKCourseParticipant
-      NTSheetInactive             -> Just NTKLecturer
+      NTSheetInactive             -> Just $ NTKFunctionary SchoolLecturer
       NTCorrectionsAssigned       -> Just NTKCorrector
-      NTCorrectionsNotDistributed -> Just NTKLecturer
+      NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
       NTUserRightsUpdate          -> Just NTKAll
       NTUserAuthModeUpdate        -> Just NTKAll
       NTExamResult                -> Just NTKExamParticipant
@@ -177,6 +189,12 @@ getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR
 postProfileR = do
   (uid, User{..}) <- requireAuthPair
+  userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
+    E.where_ . E.exists . E.from $ \userSchool ->
+      E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
+           E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
+           E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
+    return $ school E.^. SchoolId
   let settingsTemplate = Just SettingsForm
         { stgMaxFavourties = userMaxFavourites
         , stgTheme         = userTheme
@@ -184,6 +202,7 @@ postProfileR = do
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
         , stgDownloadFiles = userDownloadFiles
+        , stgSchools       = userSchools
         , stgNotificationSettings = userNotificationSettings
         , stgWarningDays   = userWarningDays
         }
@@ -207,6 +226,25 @@ postProfileR = do
                                   , OffsetBy stgMaxFavourties
                                   ]
         mapM_ delete oldFavs
+      let
+        symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
+      forM_ symDiff $ \ssh -> if
+        | ssh `Set.member` stgSchools
+          -> void $ upsert UserSchool
+               { userSchoolSchool   = ssh
+               , userSchoolUser     = uid
+               , userSchoolIsOptOut = False
+               }
+               [ UserSchoolIsOptOut =. False
+               ]
+        | otherwise
+          -> void $ upsert UserSchool
+               { userSchoolSchool   = ssh
+               , userSchoolUser     = uid
+               , userSchoolIsOptOut = True
+               }
+               [ UserSchoolIsOptOut =. True
+               ]
     addMessageI Info MsgSettingsUpdate
     redirect $ ProfileR :#: ProfileSettings
 
@@ -255,14 +293,7 @@ getProfileDataR = do
 makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   -- MsgRenderer mr <- getMsgRenderer
-  admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
+  functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
-      E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
-      E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
-      return (school E.^. SchoolShorthand)
-  lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
-      E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
-      E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
-      return (school E.^. SchoolShorthand)
   lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
       E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
       E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
@@ -314,7 +345,7 @@ mkOwnedCoursesTable =
               return $ indicatorCell -- return True if one cell is produced here
                 `mappend` termCell tid
           , sortable (Just "school") (i18nCell MsgCourseSchool) $
-              schoolCell <$> view (_dbrOutput . _1 . re _Just)
+              schoolCell <$> view (_dbrOutput . _1)
                          <*> view (_dbrOutput . _2 )
           , sortable (Just "course") (i18nCell MsgCourse) $
               courseCellCL <$> view _dbrOutput
@@ -362,8 +393,8 @@ mkEnrolledCoursesTable =
           , sortable (Just "term") (i18nCell MsgTerm) $
               termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
           , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
-              schoolCell <$> view ( _courseTerm . re _Just)
+              schoolCell <$> view _courseTerm
-                          <*> view  _courseSchool
+                         <*> view _courseSchool
           , sortable (Just "course") (i18nCell MsgCourse) $
               courseCell <$> view (_dbrOutput . _1 . _entityVal)
           , sortable (Just "time") (i18nCell MsgRegistered) $ do
@@ -430,7 +461,7 @@ mkSubmissionTable =
         , sortable (Just "term") (i18nCell MsgTerm) $
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
-            schoolCell  <$> view ( _1. re _Just)
+            schoolCell  <$> view  _1
                         <*> view  _2
         , sortable (Just "course") (i18nCell MsgCourse) $
             courseCellCL <$> view (_dbrOutput . _1)
@@ -512,7 +543,7 @@ mkSubmissionGroupTable =
         , sortable (Just "term") (i18nCell MsgTerm) $
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
-            schoolCell  <$> view ( _1. re _Just)
+            schoolCell  <$> view _1
                         <*> view _2
         , sortable (Just "course") (i18nCell MsgCourse) $
             courseCellCL <$> view (_dbrOutput . _1)

src/Handler/School.hs

@@ -1,10 +1,169 @@
 module Handler.School where
 
 import Import
+import Handler.Utils
+import Handler.Utils.Table.Columns
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.Set as Set
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as Text
+  
 
 getSchoolListR :: Handler Html
-getSchoolListR = error "getSchoolListR: Not implemented"
+getSchoolListR = do
+  let
+    schoolLink :: SchoolId -> SomeRoute UniWorX
+    schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR
+    
+    dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
+    dbtSQLQuery = return
 
-getSchoolShowR :: SchoolId -> Handler Html
+    dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
-getSchoolShowR = error "getSchoolShowR: Not implemented"
+    dbtProj = return
 
+    dbtRowKey = (E.^. SchoolId)
+
+    dbtColonnade :: Colonnade Sortable _ _
+    dbtColonnade = mconcat
+      [ colSchoolShort $ _dbrOutput . _entityKey
+      , anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName)
+      ]
+
+    dbtSorting = mconcat
+      [ sortSchoolShort $ to (E.^. SchoolId)
+      , sortSchoolName $ to (E.^. SchoolName)
+      ]
+
+    dbtFilter = mempty
+    dbtFilterUI = mempty
+
+    dbtStyle = def
+    dbtParams = def
+
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+
+    dbtIdent :: Text
+    dbtIdent = "schools"
+
+    psValidator = def
+      & defaultSorting [SortAscBy "school-name"]
+    
+
+  table <- runDB $ dbTableWidget' psValidator DBTable{..}
+
+  let title = MsgMenuSchoolList
+  siteLayoutMsg title $ do
+    setTitleI title
+    table
+
+data SchoolForm = SchoolForm
+  { sfShorthand :: CI Text
+  , sfName :: CI Text
+  , sfOrgUnits :: Set (CI Text)
+  }
+
+mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
+mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
+  <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
+  <*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
+  <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) <$> massInputListA (textField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (fmap CI.original . Set.toList . sfOrgUnits <$> template))
+  where
+    ldapOrgs :: WidgetT UniWorX IO (Set (CI Text))
+    ldapOrgs = liftHandlerT . runDB $
+      setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
+
+schoolToForm :: SchoolId -> DB (Form SchoolForm)
+schoolToForm ssh = do
+  School{..} <- get404 ssh
+  ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
+  return . mkSchoolForm (Just ssh) $ Just SchoolForm
+    { sfShorthand = schoolShorthand
+    , sfName = schoolName
+    , sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
+    }
+
+
+getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
+getSchoolEditR = postSchoolEditR
+postSchoolEditR ssh = do
+  sForm <- runDB $ schoolToForm ssh
+  
+  ((sfResult, sfView), sfEnctype) <- runFormPost sForm
+
+  formResult sfResult $ \SchoolForm{..} -> do
+    runDB $ do
+      update ssh [ SchoolName =. sfName ]
+      forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
+        void $ upsert SchoolLdap
+          { schoolLdapSchool = Just ssh
+          , ..
+          }
+          [ SchoolLdapSchool =. Just ssh
+          ]
+      deleteWhere [SchoolLdapSchool ==. Just ssh, SchoolLdapOrgUnit /<-. Set.toList sfOrgUnits]
+      addMessageI Success $ MsgSchoolUpdated ssh
+    redirect $ SchoolR ssh SchoolEditR
+
+  let sfView' = wrapForm sfView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ SchoolR ssh SchoolEditR
+        , formEncoding = sfEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Nothing :: Maybe Text
+        }
+
+  siteLayoutMsg (MsgSchoolTitle ssh) $ do
+    setTitleI $ MsgSchoolTitle ssh
+    sfView'
+
+getSchoolNewR, postSchoolNewR :: Handler Html
+getSchoolNewR = postSchoolNewR
+postSchoolNewR = do
+  uid <- requireAuthId
+  ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
+
+  formResult sfResult $ \SchoolForm{..} -> do
+    let ssh = SchoolKey sfShorthand
+    insertOkay <- runDB $ do
+      didInsert <- is _Just <$> insertUnique School
+        { schoolShorthand = sfShorthand
+        , schoolName = sfName
+        }
+      when didInsert $ do
+        insert_ UserFunction
+          { userFunctionUser     = uid
+          , userFunctionSchool   = ssh
+          , userFunctionFunction = SchoolAdmin
+          }
+        forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
+          void $ upsert SchoolLdap
+            { schoolLdapSchool = Just ssh
+            , ..
+            }
+            [ SchoolLdapSchool =. Just ssh
+            ]
+      return didInsert
+
+    if
+      | insertOkay -> do
+          addMessageI Success $ MsgSchoolCreated ssh
+          redirect $ SchoolR ssh SchoolEditR
+      | otherwise
+        -> addMessageI Error $ MsgSchoolExists ssh
+
+  let sfView' = wrapForm sfView FormSettings
+        { formMethod = POST
+        , formAction = Just $ SomeRoute SchoolNewR
+        , formEncoding = sfEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Nothing :: Maybe Text
+        }
+
+  siteLayoutMsg MsgTitleSchoolNew $ do
+    setTitleI MsgTitleSchoolNew
+    sfView'

src/Handler/Sheet.hs

@@ -902,7 +902,7 @@ correctorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 sheetCourse
       return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
     invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

src/Handler/Submission.hs

@@ -100,7 +100,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
     invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse

src/Handler/Term.hs

@@ -257,7 +257,14 @@ newTermForm template html = do
         = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
         | otherwise
         = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
-      holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
+      holidayForm = massInputListA
+        dayField
+        (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
+        (const Nothing)
+        ("holidays" :: Text)
+        (fslI MsgTermHolidays & setTooltip MsgMassInputTip)
+        True
+        (tftHolidays template)
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
       <$> tidForm
       <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)

src/Handler/Tutorial.hs

@@ -258,7 +258,7 @@ tutorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 tutorialCourse
       return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
     invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

src/Handler/Users.hs

@@ -58,30 +58,20 @@ getUsersR = do
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
       , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
-      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+      , flip foldMap universeF $ \function ->
-          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
+          sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
+            schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
-            E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+              E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
-            E.orderBy [E.asc $ school E.^. SchoolShorthand]
+              E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
-            return $ school E.^. SchoolShorthand
+                   E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
-          return [whamlet|
+              E.orderBy [E.asc $ school E.^. SchoolShorthand]
-            $newline never
+              return $ school E.^. SchoolShorthand
-            <ul .list--inline .list--comma-separated>
+            return [whamlet|
-              $forall (E.Value sh) <- schools
+              $newline never
-                <li>#{sh}
+              <ul .list--inline .list--comma-separated>
-            |]
+                $forall (E.Value sh) <- schools
-      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+                  <li>#{sh}
-          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
+              |]
-            E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
-            E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
-            E.orderBy [E.asc $ school E.^. SchoolShorthand]
-            return $ school E.^. SchoolShorthand
-          return [whamlet|
-            $newline never
-            <ul .list--inline .list--comma-separated>
-              $forall (E.Value sh) <- schools
-                <li>#{sh}
-            |]
       , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
           cID <- encrypt uid
           mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
@@ -142,14 +132,8 @@ getUsersR = do
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> let schools = E.valList (Set.toList criterion) in
-                      E.exists ( E.from $ \ulectr -> do
+                    E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
-                        E.where_ $ ulectr E.^. UserLecturerUser    E.==. user E.^. UserId
+                                                       E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
-                        E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools
-                    ) E.||.
-                      E.exists ( E.from $ \uadmin -> do
-                        E.where_ $ uadmin E.^. UserAdminUser       E.==. user E.^. UserId
-                        E.where_ $ uadmin E.^. UserAdminSchool    `E.in_` schools
-                    )
             )
           ]
       , dbtFilterUI  = \mPrev -> mconcat
@@ -199,56 +183,57 @@ getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
     adminId <- requireAuthId
     uid <- decrypt uuid
-    let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
+    (user@User{..}, adminSchools, functions, schools) <- runDB $ do
-    let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer)
+      user <- get404 uid
-    (user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
+
-        <$> get404 uid
+      schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
-        <*> selectList [UserAdminUser ==. adminId] []
+        E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId)
-        <*> E.select ( E.from $ \school -> do
+         E.&&. userFunction E.?. UserFunctionUser   E.==. E.just (E.val uid)
-              E.orderBy [E.asc $ school E.^. SchoolName]
+        let isAdmin = E.exists . E.from $ \adminFunction ->
-              let schAdmin    = E.exists $ E.from $ \userAdmin    -> do
+              E.where_ $ adminFunction E.^. UserFunctionUser     E.==. E.val adminId
-                    E.where_ $ userAdmin    E.^. UserAdminSchool    E.==. school E.^. SchoolId
+                   E.&&. adminFunction E.^. UserFunctionSchool   E.==. school E.^. SchoolId
-                    E.where_ $ userAdmin    E.^. UserAdminUser      E.==. E.val uid
+                   E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
-              let schLecturer = E.exists $ E.from $ \userLecturer -> do
+        return (school, userFunction E.?. UserFunctionFunction, isAdmin)
-                    E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
+
-                    E.where_ $ userLecturer E.^. UserLecturerUser   E.==. E.val uid
+      return ( user
-              return (school,schAdmin,schLecturer)
+             , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
-            )
+             , setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools
+             , setOf (folded . _1) schools
+             )
+    let allFunctions = Set.fromList universeF
+        allSchools   = Set.mapMonotonic entityKey schools
+
     -- above data is needed for both form generation and result evaluation
-    let userRightsForm :: Form [(SchoolId, Bool, Bool)]
+    let userRightsForm :: Form (Set (SchoolFunction, SchoolId))
         userRightsForm = identifyForm FIDuserRights $ \csrf -> do
-          boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) ->
+          boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
-            if Set.member sid adminSchools
+            | sid `Set.member` adminSchools
-              then do
+              -> mpopt   checkBoxField "" . Just $ (function, sid) `Set.member` functions
-                cbAdmin    <- mreq    checkBoxField "" (Just isAdmin)
+            | otherwise
-                cbLecturer <- mreq    checkBoxField "" (Just isLecturer)
+              -> mforced checkBoxField "" $ (function, sid) `Set.member` functions
-                return (school, cbAdmin, cbLecturer)
+          let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights
-              else do
+          return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
-                cbAdmin    <- mforced checkBoxField ""       isAdmin
-                cbLecturer <- mforced checkBoxField ""       isLecturer
-                return (school, cbAdmin, cbLecturer)
-          let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
-                        (,,) <$> pure sid <*> resAdmin <*> resLecturer
-          return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
         userAuthenticationForm :: Form ButtonAuthMode
         userAuthenticationForm = buttonForm' $ if
           | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
           | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
     let userRightsAction changes = do
-          runDBJobs $ do
+          let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
-            forM_ changes $ \(sid, userAdmin, userLecturer) ->
+              updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
-              if Set.notMember sid adminSchools
+          if
-                then return ()
+            | not $ Set.null updates -> runDBJobs $ do
-                else do
+                $logInfoS "user-rights-update" $ tshow updates
-                  if userAdmin
+                forM_ updates $ \(function, sid) -> do
-                    then void . insertUnique $ UserAdmin uid sid
+                  $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
-                    else deleteBy $ UniqueUserAdmin uid sid
+                  if
-                  if userLecturer
+                    | (function, sid) `Set.member` changes
-                    then void . insertUnique $ UserLecturer uid sid
+                      -> void . insertUnique $ UserFunction uid sid function
-                    else deleteBy $ UniqueSchoolLecturer uid sid
+                    | otherwise
-                -- Note: deleteWhere would not work well here since we filter by adminSchools
+                      -> deleteBy $ UniqueUserFunction uid sid function
-            queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
+                queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference
-          addMessageI Info MsgAccessRightsSaved
+                addMessageI Success MsgAccessRightsSaved
+            | otherwise
+              -> addMessageI Info MsgAccessRightsNotChanged
           redirect $ AdminUserR uuid
           
         userAuthenticationAction = \case
@@ -435,54 +420,76 @@ postUserPasswordR cID = do
       }
 
 
-instance IsInvitableJunction UserLecturer where
+instance IsInvitableJunction UserFunction where
-  type InvitationFor UserLecturer = School
+  type InvitationFor UserFunction = School
-  data InvitableJunction UserLecturer = JunctionUserLecturer
+  data InvitableJunction UserFunction = JunctionUserFunction
+    { jFunction :: SchoolFunction
+    }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  data InvitationDBData UserLecturer = InvDBDataUserLecturer
+  data InvitationDBData UserFunction = InvDBDataUserFunction
+    { invDBUserFunctionDeadline :: UTCTime
+    }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  data InvitationTokenData UserLecturer = InvTokenDataUserLecturer
+  data InvitationTokenData UserFunction = InvTokenDataUserFunction
-    { invTokenUserLecturerSchool :: SchoolShorthand
+    { invTokenUserFunctionSchool :: SchoolShorthand
+    , invTokenUserFunctionFunction :: SchoolFunction
     }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _InvitableJunction = iso
-    (\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer))
+    (\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction))
-    (\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..})
+    (\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..})
 
-instance ToJSON (InvitableJunction UserLecturer) where
+instance ToJSON (InvitableJunction UserFunction) where
-  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+                                        , fieldLabelModifier = camelToPathPiece' 1
-instance FromJSON (InvitableJunction UserLecturer) where
+                                        }
-  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1
+                                                , fieldLabelModifier = camelToPathPiece' 1
+                                                }
+instance FromJSON (InvitableJunction UserFunction) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
+                                              , fieldLabelModifier = camelToPathPiece' 1
+                                              }
 
-instance ToJSON (InvitationDBData UserLecturer) where
+instance ToJSON (InvitationDBData UserFunction) where
-  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
-instance FromJSON (InvitationDBData UserLecturer) where
+instance FromJSON (InvitationDBData UserFunction) where
-  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
 
-instance ToJSON (InvitationTokenData UserLecturer) where
+instance ToJSON (InvitationTokenData UserFunction) where
-  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
-instance FromJSON (InvitationTokenData UserLecturer) where
+instance FromJSON (InvitationTokenData UserFunction) where
-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
 
-lecturerInvitationConfig :: InvitationConfig UserLecturer
+functionInvitationConfig :: InvitationConfig UserFunction
-lecturerInvitationConfig = InvitationConfig{..}
+functionInvitationConfig = InvitationConfig{..}
   where
-    invitationRoute _ _ = return AdminLecturerInviteR
+    invitationRoute _ _ = return AdminFunctionaryInviteR
-    invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool
+    invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool
-    invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName
+    invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
-    invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName
+      MsgRenderer mr <- getMsgRenderer
-    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|]
+      return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction
-    invitationTokenConfig _ _ = do
+    invitationHeading (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
+      MsgRenderer mr <- getMsgRenderer
+      return . SomeMessage . MsgMailSchoolFunctionInviteHeading schoolName $ mr invTokenUserFunctionFunction
+    invitationExplanation _ (_, InvTokenDataUserFunction{..}) = do
+      MsgRenderer mr <- getMsgRenderer
+      return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
+    invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
       itAuthority <- liftHandlerT requireAuthId
-      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+      let itExpiresAt = Just $ Just invDBUserFunctionDeadline
+          itAddAuth = Nothing
+          itStartsAt = Nothing
+      return InvitationTokenConfig{..}
     invitationRestriction _ _ = return Authorized
-    invitationForm _ _ _ = pure $ (JunctionUserLecturer, ())
+    invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
     invitationInsertHook _ _ _ _ = id
-    invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName
+    invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
+      MsgRenderer mr <- getMsgRenderer
+      return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction
     invitationUltDest (Entity ssh _) _ = do
       currentTerm <- E.select . E.from $ \term -> do
         E.where_ $ term E.^. TermActive
@@ -494,39 +501,50 @@ lecturerInvitationConfig = InvitationConfig{..}
         _other        -> CourseListR
       
       
-getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html
+getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
-getAdminNewLecturerInviteR = postAdminNewLecturerInviteR
+getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR
-postAdminNewLecturerInviteR = do
+postAdminNewFunctionaryInviteR = do
   uid <- requireAuthId
   userSchools <- runDB . E.select . E.from $ \userAdmin -> do
-    E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+    E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid
-    return $ userAdmin E.^. UserAdminSchool
+         E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+    return $ userAdmin E.^. UserFunctionSchool
   
   ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
-    school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing
+    now <- liftIO getCurrentTime
-    users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+    let
-    return $ (,) <$> school <*> users
+      localNow = utcToLocalTime now
+      beginToday = case localTimeToUTC (LocalTime (localDay localNow) midnight) of
+        LTUUnique utc' _ -> utc'
+        _other           -> UTCTime (utctDay now) 0
+      defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday }
 
-  formResultModal invitesResult UsersR $ \(schoolId, users) -> do
+    function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing
+    school   <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing
+    deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
+    users    <- wreq (multiUserField False Nothing) (fslI MsgFunctionaryInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+    return $ (,,,) <$> function <*> school <*> deadline <*> users
+
+  formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do
     let (emails, uids) = partitionEithers $ Set.toList users
     lift . runDBJobs $ do
       forM_ uids $ \lecId ->
-        void . insertUnique $ UserLecturer lecId schoolId
+        void . insertUnique $ UserFunction lecId schoolId function
 
-      sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ]
+      sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ]
 
     unless (null emails) $ 
-      tell . pure <=< messageI Success . MsgLecturersInvited $ length emails
+      tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails
     unless (null uids) $ 
-      tell . pure <=< messageI Success . MsgLecturersAdded $ length uids
+      tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids
 
-  siteLayoutMsg MsgLecturerInviteHeading $ do
+  siteLayoutMsg MsgFunctionaryInviteHeading $ do
-    setTitleI MsgLecturerInviteHeading
+    setTitleI MsgFunctionaryInviteHeading
     wrapForm invitesWgt def
       { formEncoding = invitesEncoding
-      , formAction = Just $ SomeRoute AdminNewLecturerInviteR
+      , formAction = Just $ SomeRoute AdminNewFunctionaryInviteR
       }
 
-getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html
+getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html
-getAdminLecturerInviteR = postAdminLecturerInviteR
+getAdminFunctionaryInviteR = postAdminFunctionaryInviteR
-postAdminLecturerInviteR = invitationR lecturerInvitationConfig
+postAdminFunctionaryInviteR = invitationR functionInvitationConfig

src/Handler/Utils/Form/MassInput.hs

@@ -7,7 +7,7 @@ module Handler.Utils.Form.MassInput
   , massInput
   , module Handler.Utils.Form.MassInput.Liveliness
   , massInputA, massInputW
-  , massInputList
+  , massInputList, massInputListA
   , massInputAccum, massInputAccumA, massInputAccumW
   , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
   , ListLength(..), ListPosition(..), miDeleteList
@@ -486,6 +486,22 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m
   miRequired
   (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
 
+massInputListA :: forall handler cellResult ident.
+                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                  , MonadLogger handler
+                  , PathPiece ident
+                  )
+               => Field handler cellResult
+               -> (ListPosition -> FieldSettings UniWorX)
+               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+               -> ident
+               -> FieldSettings UniWorX
+               -> Bool
+               -> Maybe [cellResult]
+               -> AForm handler [cellResult]
+massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = formToAForm . fmap (over _2 pure) $ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult mempty
+
+
 -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
 massInputAccum :: forall handler cellData ident.
                   ( MonadHandler handler, HandlerSite handler ~ UniWorX

src/Handler/Utils/Invitations.hs

@@ -122,7 +122,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
     -- ^ Subject of the e-mail which sends the token to the user
   , invitationHeading     :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
     -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
-  , invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
+  , invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> DB (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
     -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
   , invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
     -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
@@ -218,7 +218,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
         jwt <- encodeToken token
         jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
         jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
-        let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur
+        jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat)
 
         when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation
                                                                        { invitationEmail = jInvitee
@@ -311,7 +311,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
     MsgRenderer mr <- getMsgRenderer
     ur <- getUrlRenderParams
     heading <- invitationHeading fEnt iData
-    let explanation = invitationExplanation fEnt iData (toHtml . mr) ur
+    explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> invitationExplanation fEnt iData
 
     fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
       Nothing -> do

src/Handler/Utils/Rating.hs

@@ -157,7 +157,7 @@ parseRating File{ fileContent = Just input, .. } = do
     ratingStr = Text.unpack $ Text.strip ratingLine
   ratingPoints <- case () of
     _ | null ratingStr -> return Nothing
-      | otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
+      | otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr
   return Rating'{ ratingTime = Just fileModified, .. }
 parseRating _ = throwM RatingFileIsDirectory
 

src/Handler/Utils/SchoolLdap.hs

@@ -0,0 +1,32 @@
+module Handler.Utils.SchoolLdap
+  ( parseLdapSchools
+  ) where
+
+import Import.NoFoundation hiding (try, (<|>), choice)
+
+import Text.Parsec
+import Text.Parsec.Text
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Set as Set
+  
+
+parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
+parseLdapSchools = parse pLdapSchools ""
+
+pLdapSchools :: Parser (Set (CI Text))
+pLdapSchools = Set.fromList . map CI.mk <$> pSegment `sepBy` char ','
+
+pSegment :: Parser Text
+pSegment = do
+  let
+    fragStart = flip label "fragment start" $ do
+      void . choice . map (try . string) $ sortOn Down
+        [ "l", "st", "o", "ou", "c", "street", "dc" ]
+      void $ char '='
+
+  fragStart
+  pack <$> manyTill anyChar (try (lookAhead $ char ',' >> fragStart) <|> eof)
+  

src/Handler/Utils/StudyFeatures.hs

@@ -8,8 +8,8 @@ import Text.Parsec
 import Text.Parsec.Text
 
 
-parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
+parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
+parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
 
 
 pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]

src/Handler/Utils/Table/Cells.hs

@@ -234,18 +234,14 @@ termCell tid = anchorCell link name
 termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
 termCellCL (tid,_,_) = termCell tid
 
-schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a
+schoolCell :: IsDBTable m a => TermId -> SchoolId -> DBCell m a
-schoolCell (Just tid) ssh  = anchorCell link name
+schoolCell tid ssh  = anchorCell link name
   where
     link = TermSchoolCourseListR tid ssh
     name = toWgt ssh
-schoolCell Nothing ssh  = anchorCell link name
-  where
-    link = SchoolShowR ssh
-    name = toWgt ssh
 
 schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
-schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
+schoolCellCL (tid,ssh,_) = schoolCell tid ssh
 
 courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a
 courseCellCL (tid,ssh,csh) = anchorCell link name

src/Handler/Utils/Table/Columns.hs

@@ -102,8 +102,8 @@ fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) m
 -- Schools --
 -------------
 
-colSchoolShort :: OpticColonnade SchoolId
+colSchool :: OpticColonnade SchoolId
-colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
+colSchool resultSsh = Colonnade.singleton (fromSortable header) body
   where
     header = Sortable (Just "school") (i18nCell MsgSchool)
     body = i18nCell . unSchoolKey . view resultSsh
@@ -111,6 +111,24 @@ colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
 sortSchool :: OpticSortColumn SchoolId
 sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh
 
+colSchoolShort :: OpticColonnade SchoolId
+colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "school-short") (i18nCell MsgSchoolShort)
+    body = i18nCell . unSchoolKey . view resultSsh
+
+sortSchoolShort :: OpticSortColumn SchoolId
+sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh
+  
+colSchoolName :: OpticColonnade SchoolName
+colSchoolName resultSn = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "school-name") (i18nCell MsgSchoolName)
+    body = i18nCell . view resultSn
+
+sortSchoolName :: OpticSortColumn SchoolName
+sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn
+  
 fltrSchool :: OpticFilterColumn t SchoolId
 fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh)
 

src/Jobs.hs

@@ -66,6 +66,7 @@ import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.Invitation
 import Jobs.Handler.SendPasswordReset
 import Jobs.Handler.TransactionLog
+import Jobs.Handler.SynchroniseLdap
 import Jobs.Handler.PruneInvitations
 
 import Jobs.HealthReport
@@ -429,11 +430,19 @@ jLocked jId act = do
 pruneLastExecs :: Crontab JobCtl -> DB ()
 pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
   where
-    ensureCrontab (Entity leId CronLastExec{..})
+    ensureCrontab (Entity leId CronLastExec{..}) = void . runMaybeT $ do
-      | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+      now <- liftIO getCurrentTime
-      , HashMap.member (JobCtlQueue job) crontab
+      flushInterval <- MaybeT . getsYesod . view $ appSettings . _appJobFlushInterval
-      = return ()
+      
-      | otherwise = delete leId
+  
+      if
+        | abs (now `diffUTCTime` cronLastExecTime) > flushInterval * 2
+          -> return ()
+        | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+        , HashMap.member (JobCtlQueue job) crontab
+          -> return ()
+        | otherwise
+          -> lift $ delete leId
 
 determineCrontab' :: DB (Crontab JobCtl)
 determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab

src/Jobs/Crontab.hs

@@ -11,6 +11,7 @@ import qualified Data.Map as Map
 import Data.Semigroup (Max(..))
 
 import Data.Time.Zones
+import Data.Time.Clock.POSIX
 
 import Handler.Utils.DateTime
 
@@ -25,7 +26,7 @@ import qualified Database.Esqueleto as E
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
 determineCrontab = execWriterT $ do
-  AppSettings{..} <- getsYesod appSettings'
+  UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
 
   case appJobFlushInterval of
     Just interval -> tell $ HashMap.singleton
@@ -96,6 +97,48 @@ determineCrontab = execWriterT $ do
         , cronNotAfter  = Right CronNotScheduled
         }
 
+
+  if
+    | is _Just appLdapConf
+    , is _Just appLdapConf
+    , Just syncWithin <- appSynchroniseLdapUsersWithin
+      -> do
+        now <- liftIO getPOSIXTime
+        let
+          interval = appSynchroniseLdapUsersInterval
+          
+          (ldapEpoch, epochNow) = now `divMod'` syncWithin
+          ldapInterval = epochNow `div'` interval
+          numIntervals = floor $ syncWithin / interval
+
+          nextIntervals = do
+            let
+              n = ceiling $ 4 * appJobCronInterval / appSynchroniseLdapUsersInterval
+            i <- [negate (ceiling $ n % 2) .. ceiling $ n % 2]
+            let
+              ((+ ldapEpoch) -> nextEpoch, nextInterval) = (ldapInterval + i) `divMod` numIntervals
+              nextIntervalTime
+                = posixSecondsToUTCTime $ fromInteger nextEpoch * syncWithin + fromInteger nextInterval * interval
+            return (nextEpoch, nextInterval, nextIntervalTime)
+
+        forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime) -> do
+          $logDebugS "SynchroniseLdap" [st|currentTime: #{tshow ldapEpoch}.#{tshow epochNow}; upcomingSync: #{tshow nextEpoch}.#{tshow (fromInteger nextInterval * interval)}; upcomingData: #{tshow (numIntervals, nextEpoch, nextInterval)}|]
+          tell $ HashMap.singleton
+            (JobCtlQueue JobSynchroniseLdap
+               { jEpoch         = fromInteger nextEpoch
+               , jNumIterations = fromInteger numIntervals
+               , jIteration     = fromInteger nextInterval
+               })
+            Cron
+              { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
+              , cronRepeat    = CronRepeatNever
+              , cronRateLimit = appSynchroniseLdapUsersInterval
+              , cronNotAfter  = Left syncWithin
+              }
+    | otherwise
+      -> return ()
+    
+
   let
     sheetJobs (Entity nSheet Sheet{..}) = do
       tell $ HashMap.singleton

src/Jobs/Handler/QueueNotification.hs

@@ -2,9 +2,9 @@ module Jobs.Handler.QueueNotification
   ( dispatchJobQueueNotification
   ) where
 
-import Import hiding ((\\))
+import Import
 
-import Data.List (nub, (\\))
+import Data.List (nub)
 
 import Jobs.Types
 
@@ -12,6 +12,8 @@ import qualified Database.Esqueleto as E
 import Utils.Sql
 import Jobs.Queue
 
+import qualified Data.Set as Set
+
 
 dispatchJobQueueNotification :: Notification -> Handler ()
 dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
@@ -59,14 +61,15 @@ determineNotificationCandidates NotificationUserRightsUpdate{..} = do
   -- always send to affected user
   affectedUser <- selectList [UserId ==. nUser] []
   -- send to same-school admins only if there was an update
-  currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] []
+  currentAdminSchools <- setOf (folded . _entityVal . _userFunctionSchool) <$> selectList [UserFunctionUser ==. nUser, UserFunctionFunction ==. SchoolAdmin] []
-  let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ]
+  let oldAdminSchools = setOf (folded . filtered ((== SchoolAdmin) . view _1) . _2 . from _SchoolId) nOriginalRights
-      newAdminSchools = currentAdminSchools \\ oldAdminSchools
+      newAdminSchools = currentAdminSchools `Set.difference` oldAdminSchools
   affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
-    E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId
+    E.on $ admin E.^. UserFunctionUser E.==. user E.^. UserId
-    E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools
+    E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools)
+         E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
     return user
-  return $ nub $ affectedUser <> affectedAdmins
+  return . nub $ affectedUser <> affectedAdmins
 determineNotificationCandidates NotificationUserAuthModeUpdate{..}
   = selectList [UserId ==. nUser] []
 determineNotificationCandidates notif@NotificationExamResult{..} = do

src/Jobs/Handler/SendNotification/UserRightsUpdate.hs

@@ -6,24 +6,25 @@ module Jobs.Handler.SendNotification.UserRightsUpdate
 
 import Import
 
-import Handler.Utils.Database
 import Handler.Utils.Mail
 import Jobs.Handler.SendNotification.Utils
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 import Text.Hamlet
 -- import qualified Data.CaseInsensitive as CI
 
-dispatchNotificationUserRightsUpdate :: UserId -> [(SchoolShorthand,Bool,Bool)]-> UserId -> Handler ()
+dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Handler ()
 dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMailT jRecipient $ do
-    (User{..}, adminSchools, lecturerSchools)  <-  liftHandlerT . runDB $ do
+    (User{..}, functions)  <-  liftHandlerT . runDB $ do
-      user <-getJust nUser
+      user <- getJust nUser
-      adminSchools    <- getSchoolsOf nUser UserAdminSchool    UserAdminUser
+      functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] []
-      lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
+      return (user, functions)
-      return (user,adminSchools,lecturerSchools)
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
     editNotifications <- mkEditNotifications jRecipient
     addAlternatives $
-      providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+      providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
 

src/Jobs/Handler/SendNotification/Utils.hs

@@ -1,5 +1,6 @@
 module Jobs.Handler.SendNotification.Utils
   ( mkEditNotifications
+  , ihamletSomeMessage
   ) where
 
 import Import
@@ -9,6 +10,9 @@ import Text.Hamlet
 import qualified Data.HashSet as HashSet
 
 
+ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
+ihamletSomeMessage f trans = f $ trans . SomeMessage
+  
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
 mkEditNotifications uid = liftHandlerT $ do
   cID <- encrypt uid

src/Jobs/Handler/SynchroniseLdap.hs

@@ -0,0 +1,55 @@
+module Jobs.Handler.SynchroniseLdap
+  ( dispatchJobSynchroniseLdap
+  , SynchroniseLdapException(..)
+  ) where
+
+import Import
+
+import qualified Data.Conduit.List as C
+import qualified Data.CaseInsensitive as CI
+
+import Auth.LDAP
+
+data SynchroniseLdapException
+  = SynchroniseLdapNoLdap
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Exception SynchroniseLdapException
+
+dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> Handler ()
+dispatchJobSynchroniseLdap numIterations epoch iteration = do
+  UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
+  case (,) <$> appLdapConf <*> appLdapPool of
+    Just (ldapConf, ldapPool) -> 
+      runDB . runConduit $
+        readUsers .| filterIteration .| synchroniseUser ldapConf ldapPool
+    Nothing ->
+      throwM SynchroniseLdapNoLdap
+  where
+    readUsers :: Source (YesodDB UniWorX) UserId
+    readUsers = selectKeys [] []
+
+    filterIteration :: Conduit UserId (YesodDB UniWorX) User
+    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
+      let
+        userIteration, currentIteration :: Integer
+        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
+        currentIteration = toInteger iteration `mod` toInteger numIterations
+      $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
+      guard $ userIteration == currentIteration
+
+      MaybeT $ get userId
+
+    synchroniseUser :: LdapConf -> LdapPool -> Sink User (YesodDB UniWorX) ()
+    synchroniseUser conf pool = C.mapM_ $ \user -> void . runMaybeT . handleExc $ do
+      $logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent user}|]
+      
+      ldapAttrs <- MaybeT $ campusUser' conf pool user
+      void . lift $ upsertCampusUser ldapAttrs Creds
+        { credsIdent  = CI.original $ userIdent user
+        , credsPlugin = "dummy"
+        , credsExtra  = []
+        }
+      where
+        handleExc
+          = catchMPlus (Proxy @CampusUserException)
+          . catchMPlus (Proxy @CampusUserConversionException)

src/Jobs/Queue.hs

@@ -80,6 +80,7 @@ writeJobCtlBlock = writeJobCtlBlock' writeJobCtl
 
 queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId
 queueJobUnsafe queuedJobWriteLastExec job = do
+  $logInfoS "queueJob" $ tshow job
   queuedJobCreationTime <- liftIO getCurrentTime
   queuedJobCreationInstance <- getsYesod appInstanceID
   insert QueuedJob

src/Jobs/Types.hs

@@ -51,6 +51,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
          | JobTruncateTransactionLog
          | JobPruneInvitations
          | JobDeleteTransactionLogIPs
+         | JobSynchroniseLdap { jNumIterations
+                              , jEpoch
+                              , jIteration :: Natural
+                              }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
@@ -58,7 +62,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetInactive { nSheet :: SheetId }
                   | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
                   | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
-                  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
+                  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
                   | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
                   | NotificationExamResult { nExam :: ExamId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)

src/Ldap/Client/Pool.hs

@@ -103,7 +103,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
         setup <- liftIO newEmptyTMVarIO
 
         ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do
-          $logInfoS "LdapExecutor" "Starting"
+          $logDebugS "LdapExecutor" "Starting"
           res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
           case res of
             Left exc -> do

src/Model/Migration.hs

@@ -454,6 +454,37 @@ customMigrations = Map.fromListWith (>>)
         whenM (tableExists "allocation_deregister") $ do
           [executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|]
     )
+  , ( AppliedMigrationKey [migrationVersion|18.0.0|] [version|19.0.0|]
+    , do
+        [executeQQ|
+          CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
+        |]
+
+        whenM (tableExists "user_admin") $ do
+          let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] []
+              moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
+                [executeQQ|
+                  INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin});
+                  DELETE FROM "user_admin" WHERE "id" = #{eId};
+                |]
+              moveAdminEntry _ = return ()
+          runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry
+          tableDropEmpty "user_admin"
+        whenM (tableExists "user_lecturer") $ do
+          let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] []
+              moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
+                [executeQQ|
+                  INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer});
+                  DELETE FROM "user_lecturer" WHERE "id" = #{eId};
+                |]
+              moveLecturerEntry _ = return ()
+          runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry
+          tableDropEmpty "user_lecturer"
+        whenM (tableExists "invitation") $ do
+          [executeQQ|
+            DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"';
+          |]
+    )
   ]
 
 

src/Model/Rating.hs

@@ -25,7 +25,7 @@ data Rating' = Rating'
 data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
                      | RatingMissingSeparator -- ^ Could not split rating header from comments
                      | RatingMultiple -- ^ Encountered multiple point values in rating
-                     | RatingInvalid String -- ^ Failed to parse rating point value
+                     | RatingInvalid Text -- ^ Failed to parse rating point value
                      | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
                      | RatingNegative -- ^ Rating points must be non-negative
                      | RatingExceedsMax -- ^ Rating point must not exceed maximum points

src/Model/Types.hs

@@ -12,3 +12,4 @@ import Model.Types.Security as Types
 import Model.Types.Sheet as Types
 import Model.Types.Submission as Types
 import Model.Types.Misc as Types
+import Model.Types.School as Types

src/Model/Types/School.hs

@@ -0,0 +1,19 @@
+module Model.Types.School where
+
+import Import.NoModel
+import Model.Types.TH.PathPiece
+
+data SchoolFunction
+  = SchoolAdmin
+  | SchoolLecturer
+  | SchoolEvaluation
+  | SchoolExamOffice
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe SchoolFunction
+instance Finite SchoolFunction
+instance Hashable SchoolFunction
+
+nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1
+pathPieceJSON ''SchoolFunction
+pathPieceJSONKey ''SchoolFunction
+derivePersistFieldPathPiece ''SchoolFunction

src/Model/Types/TH/PathPiece.hs

@@ -0,0 +1,47 @@
+module Model.Types.TH.PathPiece
+  ( derivePersistFieldPathPiece
+  ) where
+
+import ClassyPrelude.Yesod
+import Data.List (foldl)
+import Database.Persist.Sql
+
+import qualified Data.Text.Encoding as Text
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+
+derivePersistFieldPathPiece :: Name -> DecsQ
+derivePersistFieldPathPiece tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+  vars <- forM datatypeVars (const $ newName "a")
+  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
+      iCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|PathPiece|] `appT` t]
+      sqlCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|PersistField|] `appT` t]
+  sequence
+    [ instanceD iCxt ([t|PersistField|] `appT` t)
+      [ funD 'toPersistValue
+        [ clause [] (normalB [e|PersistText . toPathPiece|]) []
+        ]
+      , funD 'fromPersistValue
+        [ do
+            bs <- newName "bs"
+            clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
+        , do
+            text <- newName "text"
+            clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistTetx") Right $ fromPathPiece $(varE text)|]) []
+        , clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText or PersistByteString"|]) []
+        ]
+      ]
+    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
+      [ funD 'sqlType
+        [ clause [wildP] (normalB [e|SqlString|]) []
+        ]
+      ]
+    ]
+

src/Settings.hs

@@ -118,6 +118,9 @@ data AppSettings = AppSettings
     , appHealthCheckHTTP        :: Bool
     , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
 
+    , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
+    , appSynchroniseLdapUsersInterval :: NominalDiffTime
+
     , appInitialLogSettings     :: LogSettings
 
     , appTransactionLogIPRetentionTime :: NominalDiffTime
@@ -396,6 +399,9 @@ instance FromJSON AppSettings where
 
         appSessionTimeout         <- o .: "session-timeout"
 
+        appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
+        appSynchroniseLdapUsersInterval <- o .:  "synchronise-ldap-users-interval"
+
         appMaximumContentLength   <- o .: "maximum-content-length"
 
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev

src/Utils.hs

@@ -51,7 +51,7 @@ import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
-import Control.Monad.Catch hiding (throwM)
+import Control.Monad.Catch (catchIf)
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Instances ()
@@ -395,6 +395,9 @@ setIntersections (h:t) = foldl' Set.intersection h t
 setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
 setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
 
+setProduct :: (Ord a, Ord b) => Set a -> Set b -> Set (a, b)
+setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
+
 ----------
 -- Maps --
 ----------
@@ -494,6 +497,12 @@ hoistMaybe = maybe mzero return
 catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
 catchIfMaybeT p act = catchIf p (lift act) (const mzero)
 
+catchMaybeT :: forall p m e a. (MonadCatch m, Exception e) => p e -> m a -> MaybeT m a
+catchMaybeT _ act = catch (lift act) (const mzero :: e -> MaybeT m a)
+
+catchMPlus :: forall p m e a. (MonadPlus m, MonadCatch m, Exception e) => p e -> m a -> m a
+catchMPlus _ = handle (const mzero :: e -> m a)
+
 mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs

src/Utils/Lens.hs

@@ -43,6 +43,9 @@ _nullable = prism' toNullable fromNullable
 _SchoolId :: Iso' SchoolId SchoolShorthand
 _SchoolId = iso unSchoolKey SchoolKey
 
+_Maybe :: Iso' (Maybe ()) Bool
+_Maybe = iso (is _Just) (bool Nothing (Just ()))
+
 
 -----------------------------------
 -- Lens Definitions for our Types
@@ -169,6 +172,11 @@ makeLenses_ ''Allocation
 
 makeLenses_ ''File
 
+makeLenses_ ''School
+makeLenses_ ''SchoolLdap
+
+makeLenses_ ''UserFunction
+
 
 -- makeClassy_ ''Load
 

start.sh

@@ -4,13 +4,15 @@ set -e
 
 [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
 
-unset HOST
+__HOST=${HOST:-$(hostname -s | awk '{ print $0; }')}
+
 export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
 export LOG_ALL=${LOG_ALL:-false}
 export LOGLEVEL=${LOGLEVEL:-info}
 export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
 export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
-export RIBBON=${RIBBON:-Localhost}
+export RIBBON=${RIBBON:-${__HOST:-localhost}}
+unset HOST
 
 move-back() {
     mv -v .stack-work .stack-work-run

templates/mail/userRightsUpdate.hamlet

@@ -11,25 +11,21 @@ $newline never
       }
   <body>
     <h1>
-      _{MsgMailUserRightsIntro userDisplayName userEmail}
+      _{SomeMessage $ MsgMailUserRightsIntro userDisplayName userEmail}
-    $with numSchools <- length adminSchools
+    <dl>
-      $if numSchools > 0
+      $forall (function, schools) <- Map.toList functions
-        <p>
+        <dt>_{SomeMessage $ function}
-          <h2>_{MsgAdminFor} _{MsgForSchools numSchools}
+        <dd>
           <ul>
-            $forall sn <- adminSchools
+            $forall sn <- schools
-              <li>#{sn}
+              <li>
-    $with numSchools <- length lecturerSchools
+                #{sn}
+    $with numSchools <- maybe 0 Set.size $ Map.lookup SchoolLecturer functions
       $if numSchools > 0
-        <p>
-          <h2>_{MsgLecturerFor} _{MsgForSchools numSchools}
-          <ul>
-            $forall sn <- lecturerSchools
-              <li>#{sn}
         <p>
           <a href=@{CourseNewR}>
-            _{MsgMailLecturerRights numSchools}
+            _{SomeMessage $ MsgMailLecturerRights numSchools}
       $else
-        <p>_{MsgMailNoLecturerRights}
+        <p>_{SomeMessage $ MsgMailNoLecturerRights}
 
-    ^{editNotifications}
+    ^{ihamletSomeMessage editNotifications}

templates/profileData.hamlet

@@ -16,22 +16,13 @@
           #{llogin}
         $nothing
           _{MsgNever}
-    $if not $ null admin_rights
+    $forall (function, schools) <- Map.toList functions
-      <dt .deflist__dt>_{MsgAdminFor}
+      <dt .deflist__dt>_{function}
       <dd .deflist__dd>
         <ul .list-ul>
-          $forall (E.Value institute) <- admin_rights
+          $forall ssh <- schools
             <li .list-ul__item>
-              <a href=@{SchoolShowR $ SchoolKey institute}>
+              #{ssh}
-                #{institute}
-    $if not $ null lecturer_rights
-      <dt .deflist__dt>_{MsgLecturerFor}
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value institute) <- lecturer_rights
-            <li .list-ul__item>
-              <a href=@{SchoolShowR $ SchoolKey institute}>
-                #{institute}
     $if not $ null lecture_corrector
       <dt .deflist__dt> Korrektor
       <dd .deflist__dd>

templates/widgets/massinput/list/layout.hamlet

@@ -1,14 +1,10 @@
 $newline never
-<table>
+<div .massinput-list__wrapper>
-  <tbody>
+  $forall coord <- review liveCoords lLength
-    $forall coord <- review liveCoords lLength
+    <div .massinput-list__cell .massinput__cell>
-      <tr .massinput__cell>
+      <div .massinput-list__field>
-        <td>
+        ^{cellWdgts ! coord}
-          ^{cellWdgts ! coord}
+      <div .massinput-list__delete>
-        <td>
+        ^{fvInput (delButtons ! coord)}
-          ^{fvInput (delButtons ! coord)}
+  <div .massinput-list__add .massinput__cell .massinput__cell--add>
-  <tfoot>
+    ^{addWdgts ! (0, 0)}
-    <tr .massinput__cell.massinput__cell--add>
-      <td>
-      <td>
-        ^{addWdgts ! (0, 0)}

templates/widgets/user-rights-form/user-rights-form.hamlet

@@ -5,10 +5,15 @@ $newline never
     <tr .table__row .table__row--head>
       <th>
         $# empty cell
-      <th .table__th>_{MsgAdminFor}
+      $forall function <- allFunctions
-      <th .table__th>_{MsgLecturerFor}
+        <th .table__th>
-    $forall (Entity _ (School name _), (_,cbAdmin), (_,cbLecturer)) <- boxRights
+          _{function}
-      <tr .table__row>
+    $forall school <- schools
-        <th .table__th>#{name}
+      $with Entity sid School{schoolName} <- school
-        <td .table__td>^{fvInput cbAdmin}
+        <tr .table__row>
-        <td .table__td>^{fvInput cbLecturer}
+          <th .table__th>
+            #{schoolName}
+          $forall function <- allFunctions
+            <td .table__td>
+              $maybe (_, boxView) <- Map.lookup (function, sid) boxRights
+                ^{fvInput boxView}

test/Database.hs

@@ -106,6 +106,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["en"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
@@ -127,6 +129,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
@@ -148,6 +152,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   maxMuster <- insert User
     { userIdent  = "max@campus.lmu.de"
@@ -169,6 +175,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
@@ -190,6 +198,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   svaupel <- insert User
     { userIdent  = "vaupel.sarah@campus.lmu.de"
@@ -211,6 +221,8 @@ fillDb = do
     , userWarningDays = userDefaultWarningDays
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
     }
   void . repsert (TermKey summer2017) $ Term
     { termName     = summer2017
@@ -241,17 +253,17 @@ fillDb = do
     }
   ifi <- insert' $ School "Institut für Informatik" "IfI"
   mi  <- insert' $ School "Institut für Mathematik" "MI"
-  void . insert' $ UserAdmin gkleen ifi
+  void . insert' $ UserFunction gkleen ifi SchoolAdmin
-  void . insert' $ UserAdmin gkleen mi
+  void . insert' $ UserFunction gkleen mi SchoolAdmin
-  void . insert' $ UserAdmin fhamann ifi
+  void . insert' $ UserFunction fhamann ifi SchoolAdmin
-  void . insert' $ UserAdmin jost ifi
+  void . insert' $ UserFunction jost ifi SchoolAdmin
-  void . insert' $ UserAdmin jost mi
+  void . insert' $ UserFunction jost mi SchoolAdmin
-  void . insert' $ UserAdmin svaupel ifi
+  void . insert' $ UserFunction svaupel ifi SchoolAdmin
-  void . insert' $ UserAdmin svaupel mi
+  void . insert' $ UserFunction svaupel mi SchoolAdmin
-  void . insert' $ UserLecturer gkleen ifi
+  void . insert' $ UserFunction gkleen ifi SchoolLecturer
-  void . insert' $ UserLecturer fhamann ifi
+  void . insert' $ UserFunction fhamann ifi SchoolLecturer
-  void . insert' $ UserLecturer jost ifi
+  void . insert' $ UserFunction jost ifi SchoolLecturer
-  void . insert' $ UserLecturer svaupel ifi
+  void . insert' $ UserFunction svaupel ifi SchoolLecturer
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88

test/FoundationSpec.hs

@@ -23,6 +23,10 @@ instance Arbitrary (Route EmbeddedStatic) where
     paramNum <- getNonNegative <$> arbitrary
     params <- replicateM paramNum $ (,) <$> printableText <*> printableText
     return $ embeddedResourceR path params
+  
+instance Arbitrary SchoolR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
 
 instance Arbitrary CourseR where
   arbitrary = genericArbitrary

test/Handler/Utils/SchoolLdapSpec.hs

@@ -0,0 +1,18 @@
+module Handler.Utils.SchoolLdapSpec where
+
+import TestImport
+
+import Handler.Utils.SchoolLdap
+
+import qualified Data.Set as Set
+
+spec :: Spec
+spec = describe "ldap school extraction" $ do
+  it "works for some examples" . example $ do
+    let matches str frags = parseLdapSchools str `shouldBe` Right (Set.fromList frags)
+
+    "ou=Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat),o=uni-muenchen,c=de" `matches` ["Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat)", "uni-muenchen", "de"]
+    "ou=Katholisch-Theologische Fakultät (01 Fak. Kathol. Theologie),o=uni-muenchen,c=de" `matches` ["Katholisch-Theologische Fakultät (01 Fak. Kathol. Theologie)", "uni-muenchen", "de"]
+    "ou=C4-Professur für Informatik (1603 C4 Hofmann),ou=Department Institut für Informatik (1603 Dept. Informatik),ou=Fakultät für Mathematik, Informatik und Statistik (16 Fak. Mathe Info. Stat.),o=uni-muenchen,c=de" `matches` ["C4-Professur für Informatik (1603 C4 Hofmann)", "Department Institut für Informatik (1603 Dept. Informatik)", "Fakultät für Mathematik, Informatik und Statistik (16 Fak. Mathe Info. Stat.)", "uni-muenchen", "de"]
+    "ou=Department Mathematisches Institut (1601_Dept_Mathemat_Inst),ou=Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat),o=uni-muenchen,c=de" `matches` ["Department Mathematisches Institut (1601_Dept_Mathemat_Inst)", "Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat)", "uni-muenchen", "de"]
+    "ou=Fakultät für Physik (17_Fakultät_Physik),o=uni-muenchen,c=de" `matches` ["Fakultät für Physik (17_Fakultät_Physik)", "uni-muenchen", "de"]

test/ModelSpec.hs

@@ -102,6 +102,9 @@ instance Arbitrary User where
     userMailLanguages <- arbitrary
     userNotificationSettings <- arbitrary
 
+    userCreated <- arbitrary
+    userLastLdapSynchronisation <- arbitrary
+
     return User{..}
   shrink = genericShrink
 

test/TestImport.hs

@@ -108,6 +108,7 @@ authenticateAs (Entity _ User{..}) = do
 createUser :: (User -> User) -> YesodExample UniWorX (Entity User)
 createUser adjUser = do
   UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod
+  now <- liftIO getCurrentTime
   let
     userMatrikelnummer = Nothing
     userAuthentication = AuthLDAP
@@ -128,6 +129,8 @@ createUser adjUser = do
     userWarningDays = userDefaultWarningDays
     userMailLanguages = def
     userNotificationSettings = def
+    userCreated = now
+    userLastLdapSynchronisation = Nothing
   runDB . insertEntity $ adjUser User{..}
 
 lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec