diff --git a/config/settings.yml b/config/settings.yml index ca2520708..05984ad70 100644 --- a/config/settings.yml +++ b/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" diff --git a/frontend/src/services/html-helpers/html-helpers.js b/frontend/src/services/html-helpers/html-helpers.js index b8bf7771b..5799fee24 100644 --- a/frontend/src/services/html-helpers/html-helpers.js +++ b/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) => { diff --git a/frontend/src/utils/mass-input/mass-input.js b/frontend/src/utils/mass-input/mass-input.js index 01bdd3920..f6c8357b2 100644 --- a/frontend/src/utils/mass-input/mass-input.js +++ b/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'; diff --git a/frontend/src/utils/mass-input/mass-input.scss b/frontend/src/utils/mass-input/mass-input.scss new file mode 100644 index 000000000..d8f006d36 --- /dev/null +++ b/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; +} diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8568ce0e3..a3aa6fa5b 100644 --- a/messages/uniworx/de.msg +++ b/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 -LecturerInviteField: Einzuladende EMail Addressen -LecturerInviteHeading: Dozenten hinzufügen +FunctionaryInviteFunction: Funktion +FunctionaryInviteSchool: Institut +FunctionaryInviteField: Einzuladende EMail Addressen +FunctionaryInviteHeading: Institut-Funktionäre hinzufügen -LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen -LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen +FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per EMail eingeladen +FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen -MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ -MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent 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. -SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen +MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +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. +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 \ No newline at end of file +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 \ No newline at end of file diff --git a/models/schools b/models/schools index f877a1aeb..2da425cf4 100644 --- a/models/schools +++ b/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 \ No newline at end of file diff --git a/models/users b/models/users index f66651dd5..223cd2b8a 100644 --- a/models/users +++ b/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 - user UserId - school SchoolId - UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows -UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user - user UserId - school SchoolId - UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows +UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...) + user UserId + school SchoolId + function SchoolFunction + UniqueUserFunction user school function +UserExamOffice + user UserId + 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. diff --git a/routes b/routes index b8c14a9e7..2461c235c 100644 --- a/routes +++ b/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/lecturer-invite AdminLecturerInviteR GET POST +!/users/functionary-invite/new AdminNewFunctionaryInviteR 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/#SchoolId SchoolShowR GET !development +/school SchoolListR GET +!/school/new SchoolNewR GET POST +/school/#SchoolId SchoolR: + / SchoolEditR GET POST /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 406a3a2d4..74c669f3c 100644 --- a/src/Auth/LDAP.hs +++ b/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 = Ldap.Attr "userPrincipalName" -ldapUserEmail = Ldap.Attr "mail" -ldapUserDisplayName = Ldap.Attr "displayName" -ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" -ldapUserFirstName = Ldap.Attr "givenName" -ldapUserSurname = Ldap.Attr "sn" -ldapUserTitle = Ldap.Attr "title" -ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString" +ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr +ldapUserPrincipalName = Ldap.Attr "userPrincipalName" +ldapUserEmail = Ldap.Attr "mail" +ldapUserDisplayName = Ldap.Attr "displayName" +ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" +ldapUserFirstName = Ldap.Attr "givenName" +ldapUserSurname = Ldap.Attr "sn" +ldapUserTitle = Ldap.Attr "title" +ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" +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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 74bfbb7d6..c038f2152 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8698da41c..eb0991496 100644 --- a/src/Foundation.hs +++ b/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.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool + 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.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool + 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] [] - otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] - mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] [] - guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) + otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] + mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] + guardMExceptT (otherSchoolsFunctions `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 - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , 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 ] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index db6096bec..9d8c03552 100644 --- a/src/Handler/Admin.hs +++ b/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 $ (,,) - <$> mkDegreeTable - <*> mkStudytermsTable (Set.fromList newStudyTermKeys) - (Set.fromList $ map entityKey infConflicts) - <*> mkCandidateTable + , ((), candidateTable) + , userSchools) <- runDB $ do + schools <- E.select . E.from $ \school -> do + E.where_ . E.exists . E.from $ \schoolFunction -> + 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 ^. _dbrOutput . _entityVal . _studyTermsShorthand + (\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName + , 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 "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand)) + , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey)) + , 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 newKeys badKeys = + 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 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 "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) - , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) - , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) + [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey)) + , 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 . _1 . _entityKey)) + , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey)) + , 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 diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs index 281a21826..29544bd90 100644 --- a/src/Handler/Course/Application/Edit.hs +++ b/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] - Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool] + Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin] + Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin] return (mAlloc, course, app, isAdmin, appUser) afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index a3faa9a89..b9dac3f39 100644 --- a/src/Handler/Course/Application/List.hs +++ b/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{..} diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 248c17571..a6a1e4159 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 $ (,) - <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] ) - <*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] ) - let userSchools = lecSchools ++ admSchools + userSchools <- liftHandlerT . runDB $ map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [] 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.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + E.where_ $ user E.^. UserFunctionUser E.==. E.val uid + 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) diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 7bc870396..696ba927b 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 97b79e54c..a54af6349 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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 diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index f8398487a..738c2a3fb 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/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 diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 2b41622b9..5810d3516 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 11b9728a3..e9d0a6ad0 100644 --- a/src/Handler/Profile.hs +++ b/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 - deriving (Eq, Ord, Enum, Bounded, Generic, Typeable) -instance Universe NotificationTriggerKind -instance Finite NotificationTriggerKind +data NotificationTriggerKind + = NTKAll + | NTKCourseParticipant + | 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: --- --- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm --- makeSettingForm template = identForm FIDsettings $ \html -> do --- (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2 --- <$> aFormGroup "Cosmetics" cosmeticsForm --- <*> aFormGroup "Notifications" notificationsForm --- <* submitButton --- return (result, widget) -- no validation required here --- where --- settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm --- settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm --- themeList = [Option (display t) t (toPathPiece t) | t <- universeF] --- cosmeticsForm = (,,,,) --- <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here --- (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) --- <*> areq (selectField . return $ mkOptionList themeList) --- (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) --- notificationsForm = (,) --- <$> areq checkBoxField (fslI MsgDownloadFiles --- & setTooltip MsgDownloadFilesTip --- ) (stgDownloadFiles <$> template) --- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) --- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template) + +schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) +schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty + where + schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) + schoolsForm' = do + allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName] + + let + schoolForm (Entity ssh School{schoolName}) + = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template) + + fold <$> mapM schoolForm allSchools + + schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX]) + schoolsFormView (res, fvInput) = do + mr <- getMessageRender + let fvLabel = toHtml $ mr MsgUserSchools + fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip + fvRequired = False + fvErrors + | FormFailure (err : _) <- res = Just $ toHtml err + | otherwise = Nothing + fvId <- newIdent + return (res, pure FieldView{..}) 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 - = fmap not . E.selectExists . E.from $ \userAdmin -> - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - | Just uid <- mbUid - , NTKLecturer <- nt - = fmap not . E.selectExists . E.from $ \userLecturer -> - E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid + , NTKFunctionary f <- nt + = fmap not . E.selectExists . E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f | 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 - 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) + functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] 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) - <*> view _courseSchool + schoolCell <$> view _courseTerm + <*> 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) diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 9dad647e0..c743dfae2 100644 --- a/src/Handler/School.hs +++ b/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 -getSchoolShowR = error "getSchoolShowR: Not implemented" + dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School)) + 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' diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5ee6ba68f..96f2ec55f 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 1d14a8d9f..72dca3ce9 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 26cba329a..ba4be993c 100644 --- a/src/Handler/Term.hs +++ b/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) diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index ae2c26ea0..4bacd9cd7 100644 --- a/src/Handler/Tutorial.hs +++ b/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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a8df63296..0b5b3bdac 100644 --- a/src/Handler/Users.hs +++ b/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 - schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do - E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - E.orderBy [E.asc $ school E.^. SchoolShorthand] - return $ school E.^. SchoolShorthand - return [whamlet| - $newline never -