From 2afa33895949584e5c19a6f3f70050990d555e77 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 12:15:03 +0200 Subject: [PATCH 1/7] chore: display hostname in dev-ribbon --- start.sh | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/start.sh b/start.sh index ffe083bea..40da9eb05 100755 --- a/start.sh +++ b/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 From 18ae28abbcfcff6015b419f6791bc60fe6dd88f5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 12:15:18 +0200 Subject: [PATCH 2/7] feat(schools): implement cru --- messages/uniworx/de.msg | 13 ++- routes | 5 +- src/Foundation.hs | 22 +++++ src/Handler/Course/Application/List.hs | 1 + src/Handler/School.hs | 129 ++++++++++++++++++++++++- src/Handler/Utils/Table/Columns.hs | 22 ++++- src/Utils/Lens.hs | 2 + 7 files changed, 186 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8568ce0e3..3521e81cb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1031,6 +1031,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 @@ -1562,4 +1564,13 @@ CourseApplicationNoRatingPoints: Keine Bewertung CourseApplicationNoRatingComment: Kein Kommentar UserDisplayName: Voller Name -UserMatriculation: Matrikelnummer \ No newline at end of file +UserMatriculation: Matrikelnummer + +SchoolShort: Kürzel +SchoolName: Name + +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 \ No newline at end of file diff --git a/routes b/routes index b8c14a9e7..1c42a5478 100644 --- a/routes +++ b/routes @@ -78,8 +78,9 @@ !/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 SchoolShowR GET POST /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: diff --git a/src/Foundation.hs b/src/Foundation.hs index 1852150ac..e0472c50e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1723,6 +1723,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 (SchoolShowR ssh) = return (original (unSchoolKey ssh), Just SchoolListR) + breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR) breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) @@ -1996,6 +2000,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 @@ -2028,6 +2040,16 @@ 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 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/School.hs b/src/Handler/School.hs index 9dad647e0..04eac6bc8 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -1,10 +1,133 @@ module Handler.School where import Import +import Handler.Utils +import Handler.Utils.Table.Columns + +import qualified Database.Esqueleto as E getSchoolListR :: Handler Html -getSchoolListR = error "getSchoolListR: Not implemented" +getSchoolListR = do + let + schoolLink :: SchoolId -> SomeRoute UniWorX + schoolLink ssh = SomeRoute $ SchoolShowR ssh + + 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 + } + +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) + +schoolToForm :: SchoolId -> DB (Form SchoolForm) +schoolToForm ssh = do + School{..} <- get404 ssh + return . mkSchoolForm (Just ssh) $ Just SchoolForm + { sfShorthand = schoolShorthand + , sfName = schoolName + } + + +getSchoolShowR, postSchoolShowR :: SchoolId -> Handler Html +getSchoolShowR = postSchoolShowR +postSchoolShowR ssh = do + sForm <- runDB $ schoolToForm ssh + + ((sfResult, sfView), sfEnctype) <- runFormPost sForm + + formResult sfResult $ \SchoolForm{..} -> do + runDB $ do + update ssh [ SchoolName =. sfName ] + addMessageI Success $ MsgSchoolUpdated ssh + redirect $ SchoolShowR ssh + + let sfView' = wrapForm sfView FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ SchoolShowR ssh + , 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 + ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing + + formResult sfResult $ \SchoolForm{..} -> do + let ssh = SchoolKey sfShorthand + insertOkay <- runDB $ do + fmap (is _Just) $ insertUnique School + { schoolShorthand = sfShorthand + , schoolName = sfName + } + + if + | insertOkay -> do + addMessageI Success $ MsgSchoolCreated ssh + redirect $ SchoolShowR ssh + | 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/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 3fe114257..595b5ebe8 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -102,8 +102,8 @@ fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) m -- Schools -- ------------- -colSchoolShort :: OpticColonnade SchoolId -colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body +colSchool :: OpticColonnade SchoolId +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) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index d72fdac3e..17159f659 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -167,6 +167,8 @@ makeLenses_ ''Allocation makeLenses_ ''File +makeLenses_ ''School + -- makeClassy_ ''Load From 76f8da52e0f532ef08df5ad649aa3d2bb24159f5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 28 Aug 2019 09:46:03 +0200 Subject: [PATCH 3/7] feat(users): generalise UserLecturer and UserAdmin to UserFunction Closes #320 BREAKING CHANGE: Remove UserLecturer and UserAdmin --- messages/uniworx/de.msg | 31 +- models/schools | 6 +- models/users | 21 +- routes | 7 +- src/Auth/LDAP.hs | 10 +- src/Foundation.hs | 39 +-- src/Handler/Course/Application/Edit.hs | 4 +- src/Handler/Course/Edit.hs | 25 +- src/Handler/Course/LecturerInvite.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Exam/CorrectorInvite.hs | 2 +- src/Handler/Exam/RegistrationInvite.hs | 2 +- src/Handler/Profile.hs | 59 ++-- src/Handler/School.hs | 18 +- src/Handler/Sheet.hs | 2 +- src/Handler/Submission.hs | 2 +- src/Handler/Tutorial.hs | 2 +- src/Handler/Users.hs | 274 ++++++++++-------- src/Handler/Utils/Invitations.hs | 6 +- src/Handler/Utils/Table/Cells.hs | 10 +- src/Jobs/Handler/QueueNotification.hs | 19 +- .../SendNotification/UserRightsUpdate.hs | 17 +- src/Jobs/Handler/SendNotification/Utils.hs | 4 + src/Jobs/Types.hs | 2 +- src/Model/Migration.hs | 31 ++ src/Model/Types.hs | 1 + src/Model/Types/School.hs | 19 ++ src/Model/Types/TH/PathPiece.hs | 47 +++ src/Utils.hs | 3 + src/Utils/Lens.hs | 2 + templates/mail/userRightsUpdate.hamlet | 28 +- templates/profileData.hamlet | 17 +- .../user-rights-form/user-rights-form.hamlet | 19 +- 33 files changed, 443 insertions(+), 290 deletions(-) create mode 100644 src/Model/Types/School.hs create mode 100644 src/Model/Types/TH/PathPiece.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3521e81cb..6194df7d2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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"} @@ -861,6 +862,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}" @@ -1491,17 +1494,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 @@ -1573,4 +1577,9 @@ 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 \ No newline at end of file +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..da7859057 100644 --- a/models/schools +++ b/models/schools @@ -6,4 +6,8 @@ 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 + orgUnit (CI Text) + UniqueOrgUnit orgUnit \ No newline at end of file diff --git a/models/users b/models/users index f66651dd5..330102901 100644 --- a/models/users +++ b/models/users @@ -30,14 +30,19 @@ 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 + 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 1c42a5478..fe7902d98 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 @@ -80,7 +80,8 @@ /school SchoolListR GET !/school/new SchoolNewR GET POST -/school/#SchoolId SchoolShowR GET POST +/school/#SchoolId SchoolR: + / SchoolShowR 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..e14a79b9a 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -2,14 +2,14 @@ module Auth.LDAP ( apLdap , campusLogin , CampusUserException(..) - , campusUser + , campusUser, campusUser' , CampusMessage(..) , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName ) where -import Import.NoFoundation hiding (userEmail, userDisplayName) +import Import.NoFoundation import Network.Connection import Data.CaseInsensitive (CI) @@ -80,6 +80,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 +107,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/Foundation.hs b/src/Foundation.hs index e0472c50e..7d0354425 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -310,6 +310,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 +607,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 +619,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 +645,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 +688,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 @@ -1725,7 +1733,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb AdminErrMsgR = return ("Test" , Just AdminR) breadcrumb SchoolListR = return ("Institute" , Just AdminR) - breadcrumb (SchoolShowR ssh) = return (original (unSchoolKey ssh), Just SchoolListR) + breadcrumb (SchoolR ssh SchoolShowR) = return (original (unSchoolKey ssh), Just SchoolListR) breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR) breadcrumb InfoR = return ("Information" , Nothing) @@ -2055,7 +2063,7 @@ pageActions (UsersR) = { menuItemType = PageActionPrime , menuItemLabel = MsgMenuLecturerInvite , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminNewLecturerInviteR + , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR , menuItemModal = True , menuItemAccessCallback' = return True } @@ -2883,13 +2891,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 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/Edit.hs b/src/Handler/Course/Edit.hs index 248c17571..5888fecd6 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 SchoolShowR 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 SchoolShowR 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..bbf6803da 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -28,12 +28,27 @@ data SettingsForm = SettingsForm , 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 @@ -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 @@ -255,14 +267,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 +319,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 +367,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 +435,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 +517,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 04eac6bc8..d5cd61820 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -10,7 +10,7 @@ getSchoolListR :: Handler Html getSchoolListR = do let schoolLink :: SchoolId -> SomeRoute UniWorX - schoolLink ssh = SomeRoute $ SchoolShowR ssh + schoolLink ssh = SomeRoute $ SchoolR ssh SchoolShowR dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ dbtSQLQuery = return @@ -84,11 +84,11 @@ postSchoolShowR ssh = do runDB $ do update ssh [ SchoolName =. sfName ] addMessageI Success $ MsgSchoolUpdated ssh - redirect $ SchoolShowR ssh + redirect $ SchoolR ssh SchoolShowR let sfView' = wrapForm sfView FormSettings { formMethod = POST - , formAction = Just . SomeRoute $ SchoolShowR ssh + , formAction = Just . SomeRoute $ SchoolR ssh SchoolShowR , formEncoding = sfEnctype , formAttrs = [] , formSubmit = FormSubmit @@ -102,20 +102,28 @@ postSchoolShowR ssh = do 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 - fmap (is _Just) $ insertUnique School + didInsert <- fmap (is _Just) $ insertUnique School { schoolShorthand = sfShorthand , schoolName = sfName } + when didInsert $ + insert_ UserFunction + { userFunctionUser = uid + , userFunctionSchool = ssh + , userFunctionFunction = SchoolAdmin + } + return didInsert if | insertOkay -> do addMessageI Success $ MsgSchoolCreated ssh - redirect $ SchoolShowR ssh + redirect $ SchoolR ssh SchoolShowR | otherwise -> addMessageI Error $ MsgSchoolExists ssh 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/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 -