diff --git a/CHANGELOG.md b/CHANGELOG.md index 5ce661834..e8f7e52c1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,59 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [21.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.2...v21.0.3) (2020-11-05) + + +### Bug Fixes + +* **mails:** prevent emails being resent to due archiving errors ([8cf39dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8cf39dcbe68cefcc50691ae8a7194315d18420d6)) + +### [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04) + + +### Bug Fixes + +* build ([fa61b46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa61b46d308753354623df17241b5312f324321e)) + +### [21.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.0...v21.0.1) (2020-11-04) + + +### Bug Fixes + +* **mail:** better separation of sender/from/envelope-from ([0dbf4f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0dbf4f8bde99431cafeec954dc164a73227154ad)) + +## [21.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.14.0...v21.0.0) (2020-11-04) + + +### ⚠ BREAKING CHANGES + +* **course:** AccessPredicates now take continuation + +### Features + +* **course:** warning if re-registration is not possible ([4451cee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4451ceedf7bde0da7f3bb4c0818b79d7c5df1cbd)), closes [#646](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/646) +* **mail:** archive all sent mail & better verp ([1666081](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1666081fea0eec0bf5440a100db0e8cc69be8295)) + + +### Bug Fixes + +* **course:** don't delete applications when deregistering ([b666408](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b6664089f75dcb3b2c89dbd2941c064e8aa86404)), closes [#648](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/648) +* **courses:** better defaults for application/registration ([1c2c8fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c2c8fe3d99176e079d0473dd45039b44128c491)) + +## [20.14.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.13.0...v20.14.0) (2020-11-02) + + +### Features + +* **users:** assimilation ([ef51c6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ef51c6e7c34effa691125e4313876d95feda96af)) + + +### Bug Fixes + +* **exam-users:** prevent exam results without registration via csv ([1c6ac4c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c6ac4cb4a52ac7e69e615e0e3ff96432b173962)) +* work around conduit-bug releasing fh to early ([3ff2cf1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ff2cf1fec1bf582fe1d5e1f6ee08dcc85d6bc00)) +* **exams:** error messages for foreign key constraint violations ([ca29a66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca29a66330a977a1f28bbdbe9a733aef10371427)) + ## [20.13.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.1...v20.13.0) (2020-10-20) diff --git a/config/settings.yml b/config/settings.yml index 3b64d7f84..4ded0132e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -18,10 +18,11 @@ mail-from: mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-verp: separator: "_env:VERP_SEPARATOR:+" - at-replacement: "_env:VERP_AT_REPLACEMENT:=" + prefix: "_env:VERP_PREFIX:bounce" mail-support: name: "_env:MAILSUPPORT_NAME:" email: "_env:MAILSUPPORT:uni2work@ifi.lmu.de" +mail-retain-sent: 31470547 job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" diff --git a/frontend/src/app.sass b/frontend/src/app.sass index fda5a0551..bbef8618a 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -723,6 +723,10 @@ section .uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text font-family: var(--font-monospace) +.shown + font-family: var(--font-monospace) + white-space: pre-wrap + .token font-family: var(--font-monospace) white-space: pre-wrap diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b6afc568c..ec8021ecb 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -212,7 +212,9 @@ CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese si CourseApplicationTemplate: Bewerbungsvorlagen CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden CourseApplicationsText: Text-Bewerbungen -CourseApplicationsTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen? +CourseApplicationsTextTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu abgegebenen Dateien) auch unformatierten Text einreichen können? +CourseApplicationsFiles: Bewerbungsdateien +CourseApplicationsFilesTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu unformatiertem Text) auch Dateien abgeben können? CourseApplicationRatingsVisible: Feedback für Bewerbungen CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden? CourseApplicationRequired: Bewerbungsverfahren @@ -225,6 +227,8 @@ CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand CourseApplication: Bewerbung CourseApplicationIsParticipant: Kursteilnehmer +CourseApplicationInstructionsRecommended: Studierende können bei ihrer Anmeldung/Bewerbung nach aktuellen Einstellungen Texte bzw. Dateien abgeben. Es wurden jedoch keine Anweisungen zur Bewerbung oder Vorlage-Dateien hinterlegt. Sie sollten entweder keine Texte bzw. Dateien verlangen oder über Anweisungen bzw. Vorlagen klarstellen, was Sie von den Studierenden erwarten. + CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben CourseApplicationInvalidAction: Angegebene Aktion kann nicht durchgeführt werden CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben @@ -254,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgelad CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben. CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden. +CourseDeregistrationNoReRegistration: Wenn Sie sich jetzt vom Kurs abmelden, können Sie sich nicht wieder selbstständig anmelden. + CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in Uni2work anmelden CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden @@ -787,6 +793,12 @@ AccessRightsNotChanged: Berechtigungen wurden nicht verändert UserSystemFunctions: Systemweite Rollen UserSystemFunctionsSaved: Systemweite Rollen gespeichert UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst +UserAssimilateUser: Benutzer +BtnUserAssimilate: Assimilieren +AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden +AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten +AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben +AssimilateUserSuccess: Benutzer erfolgreich assimiliert LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} @@ -2023,6 +2035,7 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst +ExamUsersExamDataRequiresRegistration: Wenn Prüfungsbezogene Daten (Teil-/Ergebnis, Termin/Raum, Bonus) gesetzt bzw. angepasst werden sollen, muss der jeweilige Teilnehmer zur Prüfung angemeldet sein bzw. werden. CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet @@ -2348,6 +2361,8 @@ UserDisplayEmail: Angezeigte E-Mail-Adresse UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzern mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse. UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail-Adresse wurden an „#{displayEmail}” versandt +UserCreated: Account erstellt + SchoolShort: Kürzel SchoolName: Name SchoolLdapOrganisations: Assoziierte LDAP-Fragmente @@ -2455,6 +2470,7 @@ AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer AdminUserSex: Geschlecht +AdminUserAssimilate: Benutzer assimilieren AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung UserAdded: Benutzer erfolgreich angelegt diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index d38d280c7..0d0db9c02 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -212,7 +212,9 @@ CourseApplicationInstructionsTip: Will be shown to students if they decide to ap CourseApplicationTemplate: Application template CourseApplicationTemplateTip: Students can download this template if they decide to apply for this course CourseApplicationsText: Text application -CourseApplicationsTextTip: Should students submit a plaintext application (in addition to submitted files if applicable)? +CourseApplicationsTextTip: Should students submit plaintext with their application/registration (in addition to submitted files if applicable)? +CourseApplicationsFiles: Application files +CourseApplicationsFilesTip: Should students submit files with their application/registration (in addition to plaintext if applicable)? CourseApplicationRatingsVisible: Feedback to applications CourseApplicationRatingsVisibleTip: Should students be allowed to view rating and comments on their application after the rating period? CourseApplicationRequired: Applications required @@ -225,6 +227,8 @@ CourseApplicationTemplateArchiveName tid ssh csh: #{foldCase (termToText (unTerm CourseApplication: Application CourseApplicationIsParticipant: Course participant +CourseApplicationInstructionsRecommended: Students can, as per the current course settings, submit files and/or texts with their applications/registrations. There are, however, no instructions for application or template files. You should either not require files/texts or clarify through instructions or templates what is expected of the students. + CourseApplicationExists: You already applied for this course CourseApplicationInvalidAction: Invalid action CourseApplicationCreated csh: Successfully applied for #{csh} @@ -254,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Registration files need to be reuploaded ev CourseApplicationDeleteToEdit: You need to withdraw your application and reapply to edit your application. CourseRegistrationDeleteToEdit: You need to deregister and reregister to edit your registration. +CourseDeregistrationNoReRegistration: If you deregister from the course now, you will not be able to re-register yourself. + CourseLoginToApply: You need to login to Uni2work before you can apply for this course. CourseLoginToRegister: Your need to login to Uni2work before you can register for this course. @@ -772,6 +778,12 @@ AccessRightsNotChanged: Permissions left unchanged UserSystemFunctions: System wide roles UserSystemFunctionsSaved: Successfully saved system wide roles UserSystemFunctionsNotChanged: No system wide roles were changed +UserAssimilateUser: User +BtnUserAssimilate: Assimilate +AssimilateUserNotFound: Email could not be resolved to an user +AssimilateUserHaveError: An error occurred during assimilation +AssimilateUserHaveWarnings: Warnings were ermitted during assimilation +AssimilateUserSuccess: Successfully assimilated user LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"} @@ -1982,6 +1994,7 @@ ExamUsersResultsReset count: Successfully reset result for #{show count} #{plura ExamUsersPartResultsSet count: Successfully modified exam part result for #{show count} #{pluralEN count "participant" "participants"} ExamUsersBonusSet count: Successfully modified exam bonus for #{show count} #{pluralEN count "participant" "participants"} ExamUsersResultSet count: Sucessfully modified exam result for #{show count} #{pluralEN count "participant" "participants"} +ExamUsersExamDataRequiresRegistration: If exam data (part-/result, occurrence/room, bonus) is to be modified/set, the relenvant participant needs to be registered for the exam. CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from #{show count} #{pluralEN count "tutorial" "tutorials"} CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected tutorials CourseUserExamsDeregistered count: Successfully deregistered participant from #{show count} #{pluralEN count "exam" "exams"} @@ -2308,6 +2321,8 @@ UserDisplayEmail: Display email UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. Notifications and other communication from Uni2work or users with elevated permissions are always sent to your primary email address as specified under "personal information". UserDisplayEmailChangeSent displayEmail: Instructions to change your display email have been sent to “#{displayEmail}”. +UserCreated: Account created + SchoolShort: Shorthand SchoolName: Name SchoolLdapOrganisations: Associated LDAP fragments @@ -2415,6 +2430,7 @@ AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserMatriculation: Matriculation AdminUserSex: Sex +AdminUserAssimilate: Assimilate user AuthKindLDAP: Campus account AuthKindPWHash: Uni2work account UserAdded: Successfully added user diff --git a/models/allocations.model b/models/allocations.model index a8263979b..0bbebbea5 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -45,12 +45,14 @@ AllocationUser totalCourses Natural -- number of total allocated courses for this user must be <= than this number priority AllocationPriority Maybe UniqueAllocationUser allocation user + deriving Eq Ord Show AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) + deriving Eq Ord Show AllocationNotificationSetting user UserId diff --git a/models/courses.model b/models/courses.model index 0dfebc12f..6033ff0a9 100644 --- a/models/courses.model +++ b/models/courses.model @@ -60,6 +60,7 @@ CourseParticipant -- course enrolement allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course + deriving Eq Ord Show -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- course CourseId diff --git a/models/exams.model b/models/exams.model index 7fbe1251d..4963e4075 100644 --- a/models/exams.model +++ b/models/exams.model @@ -43,24 +43,28 @@ ExamRegistration occurrence ExamOccurrenceId Maybe time UTCTime default=now() UniqueExamRegistration exam user + deriving Eq Ord Show ExamPartResult examPart ExamPartId user UserId result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user + deriving Eq Ord Show ExamBonus exam ExamId user UserId bonus Points lastChanged UTCTime default=now() UniqueExamBonus exam user + deriving Eq Ord Show ExamResult exam ExamId user UserId result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user + deriving Eq Ord Show ExamCorrector exam ExamId user UserId diff --git a/models/external-exams.model b/models/external-exams.model index 945284399..0efe62669 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -13,6 +13,7 @@ ExternalExamResult time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user + deriving Eq Ord Show ExternalExamStaff user UserId exam ExternalExamId diff --git a/models/jobs.model b/models/jobs.model index 7caa80506..4b8cf82f2 100644 --- a/models/jobs.model +++ b/models/jobs.model @@ -17,14 +17,6 @@ CronLastExec instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job - -SentNotification - content Value - user UserId - time UTCTime - instance InstanceId - - TokenBucket ident TokenBucketIdent lastValue Int64 diff --git a/models/mail.model b/models/mail.model new file mode 100644 index 000000000..114c37ce9 --- /dev/null +++ b/models/mail.model @@ -0,0 +1,13 @@ +SentMail + sentAt UTCTime + sentBy InstanceId + objectId MailObjectId Maybe + bounceSecret BounceSecret Maybe + recipient UserId Maybe + headers MailHeaders + contentRef SentMailContentId + +SentMailContent + hash MailContentReference + content MailContent + Primary hash \ No newline at end of file diff --git a/models/submissions.model b/models/submissions.model index f2c87fdc4..abfe0c6bd 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -31,3 +31,4 @@ SubmissionGroupUser -- Registered submission groups, just for check submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user + deriving Eq Ord Show \ No newline at end of file diff --git a/models/tutorials.model b/models/tutorials.model index 6650f24ef..90066fcb1 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -20,4 +20,5 @@ Tutor TutorialParticipant tutorial TutorialId user UserId - UniqueTutorialParticipant tutorial user \ No newline at end of file + UniqueTutorialParticipant tutorial user + deriving Eq Ord Show \ No newline at end of file diff --git a/package-lock.json b/package-lock.json index d64371801..1cd386ad9 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.13.0", + "version": "21.0.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 26b0c1388..2e46a75d3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.13.0", + "version": "21.0.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1d7a50b1d..7acb1ecc1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.13.0 +version: 21.0.3 dependencies: - base diff --git a/src/Application.hs b/src/Application.hs index 970337dc8..252eb7aba 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -183,7 +183,7 @@ makeFoundation appSettings'@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -199,6 +199,7 @@ makeFoundation appSettings'@AppSettings{..} = do (error "ClusterID forced in tempFoundation") (error "memcached forced in tempFoundation") (error "MinioConn forced in tempFoundation") + (error "VerpSecret forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -242,6 +243,7 @@ makeFoundation appSettings'@AppSettings{..} = do appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool + appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" @@ -259,7 +261,7 @@ makeFoundation appSettings'@AppSettings{..} = do handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing return conn - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret -- Return the foundation $logDebugS "setup" "Done" diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 7b5757e94..84fd31336 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -170,6 +170,11 @@ data Transaction , transactionUser :: UserId } + | TransactionUserAssimilated + { transactionUser :: UserId + , transactionAssimilatedUser :: UserId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7db0e3c39..66061ec3e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -4,7 +4,7 @@ module Database.Esqueleto.Utils ( true, false , justVal, justValList - , isJust + , isJust, alt , isInfixOf, hasInfix , strConcat, substring , or, and @@ -30,6 +30,7 @@ module Database.Esqueleto.Utils , selectCountRows , selectMaybe , day, diffDays + , exprLift , module Database.Esqueleto.Utils.TH ) where @@ -83,6 +84,9 @@ justValList = E.valList . map Just isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing +alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) +alt a b = E.case_ [(isJust a, a), (isJust b, b)] b + infix 4 `isInfixOf`, `hasInfix` -- | Check if the first string is contained in the text derived from the second argument @@ -388,3 +392,29 @@ infixl 6 `diffDays` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) -- ^ PostgreSQL is weird. diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b + + +class ExprLift e a | e -> a where + exprLift :: a -> e + +instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where + exprLift = E.val + +instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where + exprLift f v = E.case_ + [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v') + | v' <- universeF + ] + (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + +instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where + exprLift f v1 v2 = E.case_ + [ E.when_ ( v1 E.==. E.val v1' + E.&&. v2 E.==. E.val v2' + ) + E.then_ (E.val $ f v1' v2') + | v1' <- universeF + , v2' <- universeF + ] + (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 265fd9cea..109b967a4 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -46,7 +46,6 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4) import Data.Aeson.Lens hiding (_Value, key) @@ -82,25 +81,27 @@ newtype InvalidAuthTag = InvalidAuthTag Text instance Exception InvalidAuthTag +type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult + data AccessPredicate = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) - | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) + | APDB ((forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult + evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandler $ case aPred of + evalAccessPred aPred cont aid r w = liftHandler $ case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w - (APDB p) -> runDBRead $ p aid r w + (APDB p) -> runDBRead $ p cont aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of + evalAccessPred aPred cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w - (APDB p) -> p aid r w + (APDB p) -> p cont aid r w orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -178,7 +179,9 @@ isDryRun = $cachedHere . liftHandler $ orM noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar dnf <- either throwM return $ routeAuthTags currentRoute - guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' + in guardAuthResult <=< fmap fst . runWriterT $ eval dnf mAuthId currentRoute isWrite return False @@ -230,6 +233,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority forM_ bearerAuthority' $ \uid -> do @@ -238,12 +243,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val authorityVal <- do dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite + fmap fst . runWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite guardExceptT (is _Authorized authorityVal) authorityVal whenIsJust bearerAddAuth $ \addDNF -> do $logDebugS "validateToken" $ tshow addDNF - additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite + additionalVal <- fmap fst . runWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite guardExceptT (is _Authorized additionalVal) additionalVal return Authorized @@ -295,7 +300,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do tagAccessPredicate :: BearerAuthSite UniWorX => AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of -- Courses: access only to school admins CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -332,12 +337,12 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do +tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do @@ -375,7 +380,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation @@ -391,7 +396,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route of AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation @@ -407,9 +412,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin return Authorized -tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ +tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $ lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe -tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthNoEscalation = APDB $ \_ mAuthId route _ -> case route of AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID @@ -430,7 +435,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do @@ -469,7 +474,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] return Authorized -tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId @@ -497,7 +502,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized -tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do @@ -522,7 +527,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId @@ -545,14 +550,14 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized -tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthTutorControl = APDB $ \_ _ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn guard tutorialTutorControlled return Authorized r -> $unsupportedAuthPredicate AuthTutorControl r -tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route of CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn @@ -577,7 +582,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o return Authorized r -> $unsupportedAuthPredicate AuthSubmissionGroup r -tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -677,9 +682,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh - registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] - _ -> return False + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) | not registered @@ -759,7 +762,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of +tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -784,16 +787,14 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of return Authorized r -> $unsupportedAuthPredicate AuthStaffTime r -tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mba <- mbAllocation tid ssh csh case mba of Nothing -> return Authorized - Just (cid, Allocation{..}) -> do - registered <- case mAuthId of - Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - _ -> return False + Just (_, Allocation{..}) -> do + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite if | not registered , NTop allocationRegisterByCourse >= NTop (Just now) @@ -830,7 +831,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid (cid,) <$> MaybeT (get allocationCourseAllocation) -tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of +tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do now <- liftIO getCurrentTime courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do @@ -841,7 +842,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do @@ -854,7 +855,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthCourseRegistered r -tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do @@ -879,7 +880,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r -tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse @@ -891,7 +892,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case ro guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r -tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do @@ -932,7 +933,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> cas guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r -tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do @@ -973,7 +974,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do @@ -1026,14 +1027,14 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationRegistered = APDB $ \_ mAuthId route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do uid <- hoistMaybe mAuthId aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid return Authorized r -> $unsupportedAuthPredicate AuthAllocationRegistered r -tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId @@ -1141,7 +1142,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID isApplicant <- isCourseApplicant tid ssh csh uid @@ -1162,7 +1163,7 @@ tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn @@ -1182,7 +1183,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn @@ -1198,7 +1199,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do +tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _ -> do let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do scope <- fromRouteWorkflowScope rScope @@ -1247,20 +1248,20 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return Authorized r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthOwner = APDB $ \_ mAuthId route _ -> case route of CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> case route of CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -1275,28 +1276,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count return Authorized r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r -tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthRated = APDB $ \_ _ route _ -> case route of CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ route _ -> case route of CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn guard $ is _Just submissionModeUser return Authorized r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do referencedUser' <- case route of AdminUserR cID -> return $ Left cID AdminUserDeleteR cID -> return $ Left cID @@ -1317,7 +1318,7 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ | uid == referencedUser -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf -tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1331,7 +1332,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do User{..} <- MaybeT $ get referencedUser' guard $ userAuthentication == AuthLDAP return Authorized -tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1345,7 +1346,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d User{..} <- MaybeT $ get referencedUser' guard $ is _AuthPWHash userAuthentication return Authorized -tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId @@ -1359,7 +1360,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do +tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do mr <- getMsgRenderer let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR' = shortCircuitM (is _Authorized) (orAR mr) @@ -1454,6 +1455,11 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do MsgRenderer mr <- ask return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite +runTACont :: forall m. MonadAP m + => (forall m'. MonadAP m' => AuthTagsEval m') + -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool +runTACont cont dnf mAuthId route isWrite = is _Authorized . fst <$> runWriterT (cont dnf mAuthId route isWrite) + authTagSpecificity :: AuthTag -> AuthTag -> Ordering -- ^ Heuristic for which `AuthTag`s to evaluate first @@ -1495,9 +1501,9 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti | otherwise = Left $ InvalidAuthTag t -evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite +evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite = do mr <- getMsgRenderer let @@ -1507,11 +1513,11 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf authTagIsInactive = not . authTagIsActive evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult - evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route isWrite where evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') - evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' + evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite' evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral PLVariable{..} = evalAuthTag plVar @@ -1547,14 +1553,16 @@ evalAccessWithFor assumptions mAuthId route isWrite = do | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags | otherwise -> return . AuthTagActive $ const True dnf <- either throwM return $ routeAuthTags route - let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf - case dnf' of - Nothing -> return Authorized - Just dnf'' -> do - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite - when isSelf $ - tellSessionJson SessionInactiveAuthTags deactivated - return result + let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just + evalAdj :: forall m'. MonadAP m' => AuthTagsEval m' + evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of + Nothing -> return Authorized + Just dnf'' -> evalAuthTags ('evalAccessWithFor, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite' + in do + (result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite + when isSelf $ + tellSessionJson SessionInactiveAuthTags deactivated + return result evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor = evalAccessWithFor [] @@ -1621,14 +1629,14 @@ evalWorkflowRoleFor' :: forall m backend. , BearerAuthSite UniWorX , BackendCompatible SqlReadBackend backend ) - => AuthTagActive + => (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe UserId -> Maybe WorkflowWorkflowId -> WorkflowRole UserId -> Route UniWorX -> Bool -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult -evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBinary (tagActive, mAuthId, mwwId, wRole, route, isWrite) $ case wRole of +evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = case wRole of WorkflowRoleUser{..} -> lift . exceptT return return $ do uid <- maybeExceptT AuthenticationRequired $ return mAuthId unless (uid == workflowRoleUser) $ @@ -1653,7 +1661,7 @@ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBi unless (uid `Set.member` uids) $ throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch return Authorized - WorkflowRoleAuthorized{..} -> evalAuthTags tagActive workflowRoleAuthorized mAuthId route isWrite + WorkflowRoleAuthorized{..} -> eval workflowRoleAuthorized mAuthId route isWrite evalWorkflowRoleFor :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1671,7 +1679,10 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do tagActive <- if | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags | otherwise -> return . AuthTagActive $ const True - (result, deactivated) <- runWriterT $ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite + (result, deactivated) <- + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'evalWorkflowRoleFor tagActive eval dnf' mAuthId' route' isWrite' + in runWriterT $ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite when isSelf $ tellSessionJson SessionInactiveAuthTags deactivated return result diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index aa8f4bb50..362af9d60 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -37,9 +37,18 @@ import Foundation.DB import Network.Wai.Parse (lbsBackEnd) -import Control.Monad.Writer.Class (MonadWriter(..)) import UnliftIO.Pool (withResource) +import qualified Control.Monad.State.Class as State +import qualified Crypto.Hash as Crypto +import qualified Crypto.MAC.KMAC as Crypto + +import qualified Data.Binary as Binary + +import qualified Data.CaseInsensitive as CI + +import qualified Database.Esqueleto as E + data instance ButtonClass UniWorX = BCIsButton @@ -178,23 +187,102 @@ instance YesodAuthPersist UniWorX where instance YesodMail UniWorX where defaultFromAddress = getsYesod $ view _appMailFrom + envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom mailObjectIdDomain = getsYesod $ view _appMailObjectDomain - mailVerp = getsYesod $ view _appMailVerp mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act - mailT ctx mail = defMailT ctx $ do - void setMailObjectIdRandom - setDateCurrent - replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) + mailT ctx mail = do + mailRecord <- newEmptyTMVarIO + mailProcess <- allocateLinkedAsync $ do + defMailT ctx $ do + void setMailObjectIdRandom + sentMailSentAt <- liftIO getCurrentTime + setDate sentMailSentAt + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress) - (mRes, smtpData) <- listen mail - unless (view _MailSmtpDataSet smtpData) - setMailSmtpData + (mRes, smtpData) <- listen mail - return mRes + sentMailObjectId <- getMailObjectId + + mContent <- State.get + + smtpData' <- if | smtpData ^. _MailSmtpDataSet -> return smtpData + | otherwise -> getMailSmtpData + verpMode <- getsYesod $ view _appMailVerp + (smtpData'', sentMailBounceSecret) <- if + | Verp{..} <- verpMode + , [_] <- smtpData' ^.. _smtpRecipients . folded + , Just [l, d] <- previews (_smtpEnvelopeFrom . _Wrapped . _Just) (Text.splitOn "@") smtpData' + -> do + verpSecret <- getsYesod appVerpSecret + let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent + verpAddr = l <> Text.singleton verpSeparator <> verpPrefix <> "." <> toPathPiece bounceSecret <> "@" <> d + return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr } + , Just bounceSecret + ) + | otherwise -> return (smtpData', Nothing) + tell smtpData'' + sentMailSentBy <- getsYesod appInstanceID + let sentMailRecipient = Nothing -- Fill in later + sentMailHeaders = MailHeaders $ mconcat + [ renderAddressHeader "From" [mailFrom mContent] + , fromMaybe [] $ do + toAddrs <- assertM' (not . null) $ mailTo mContent + return $ renderAddressHeader "To" toAddrs + , fromMaybe [] $ do + ccAddrs <- assertM' (not . null) $ mailCc mContent + return $ renderAddressHeader "Cc" ccAddrs + , fromMaybe [] $ do + bccAddrs <- assertM' (not . null) $ mailBcc mContent + return $ renderAddressHeader "Bcc" bccAddrs + , mailHeaders mContent + ] + where + renderAddressHeader :: ByteString -> [Address] -> [(ByteString, Text)] + renderAddressHeader lbl = pure . (lbl, ) . Text.intercalate ", " . map renderAddress + sentMailContent = MailContent $ mailParts mContent + sentMailContentRef = SentMailContentKey . MailContentReference . Crypto.hashlazy $ Binary.encode sentMailContent + + atomically $ putTMVar mailRecord + ( smtpData'' ^.. _smtpRecipients . folded + , sentMailContent + , SentMail{..} + ) + atomically . guardM $ isEmptyTMVar mailRecord + return mRes + + (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord + void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging + sentMailRecipient <- if + | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do + recipUsers <- E.select . E.from $ \user -> do + E.where_ $ user E.^. UserDisplayEmail E.==. E.val recipAddr + E.||. user E.^. UserEmail E.==. E.val recipAddr + E.||. user E.^. UserIdent E.==. E.val recipAddr + return user + let recipUserCompare = mconcat + [ comparing $ Down . (== recipAddr) . userIdent . entityVal + , comparing $ Down . (== recipAddr) . userEmail . entityVal + , comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal + ] + return $ if + | ( bU : us ) <- sortBy recipUserCompare recipUsers + , maybe True (\u -> recipUserCompare bU u == LT) $ listToMaybe us + -> Just $ entityKey bU + | otherwise -> Nothing + | otherwise -> return Nothing + + -- @insertUnique@ _does not_ work here + unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $ + insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail + , sentMailContentContent + } + insert_ sentMail{ sentMailRecipient } + wait mailProcess -- Abort transaction if sending failed + wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 096f909c9..f76730a78 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -43,6 +43,29 @@ deriving instance Generic GlobalWorkflowInstanceR deriving instance Generic GlobalWorkflowWorkflowR deriving instance Generic (Route UniWorX) +instance Ord (Route Auth) where + compare = compare `on` renderRoute +instance Ord (Route EmbeddedStatic) where + compare = compare `on` renderRoute + +deriving instance Ord CourseR +deriving instance Ord SheetR +deriving instance Ord SubmissionR +deriving instance Ord MaterialR +deriving instance Ord TutorialR +deriving instance Ord ExamR +deriving instance Ord EExamR +deriving instance Ord CourseApplicationR +deriving instance Ord AllocationR +deriving instance Ord SchoolR +deriving instance Ord ExamOfficeR +deriving instance Ord CourseNewsR +deriving instance Ord CourseEventR +deriving instance Ord AdminWorkflowDefinitionR +deriving instance Ord GlobalWorkflowInstanceR +deriving instance Ord GlobalWorkflowWorkflowR +deriving instance Ord (Route UniWorX) + data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5257f1c35..9ca763f3f 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -57,6 +57,7 @@ data UniWorX = UniWorX , appHealthReport :: TVar (Set (UTCTime, HealthReport)) , appMemcached :: Maybe (AEAD.Key, Memcached.Connection) , appUploadCache :: Maybe MinioConn + , appVerpSecret :: VerpSecret } makeLenses_ ''UniWorX diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 321f80691..f1c1c3a40 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -40,7 +40,6 @@ import qualified Data.Binary as Binary import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Control.Monad.Writer.Class (MonadWriter(..)) import Crypto.Hash.Conduit (sinkHash) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 088886e8b..311321ae8 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -18,9 +18,6 @@ import qualified Network.Wai as W import qualified Data.Aeson as JSON import qualified Data.CaseInsensitive as CI -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild)) import qualified Data.Map as Map diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 57ed2f2db..8e9f53d79 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -402,6 +402,7 @@ postCApplicationsR tid ssh csh = do CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting + , dbtCsvValidateActions = return () , dbtCsvExecuteActions = do C.mapM_ $ \case CourseApplicationsTableCsvSetVetoData{..} -> do diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 9071a9ef0..d1a340740 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -305,7 +305,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) - <*> uploadModeForm (cfAppFiles <$> template) + <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) @@ -376,6 +376,10 @@ validateCourse = do $ length (CI.original cfShort) <= 10 warnValidation MsgCourseNotAlwaysVisibleDuringRegistration $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo + + warnValidation MsgCourseApplicationInstructionsRecommended + $ (is _Just cfAppInstructions || is _Just cfAppInstructionFiles) + || not (cfAppText || isn't _NoUpload cfAppFiles) getCourseNewR :: Handler Html -- call via toTextUrl diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 92297d3d9..331f94461 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -1,7 +1,7 @@ module Handler.Course.Register ( ButtonCourseRegister(..) , CourseRegisterForm(..) - , courseRegisterForm + , courseRegisterForm, courseMayReRegister , getCRegisterR, postCRegisterR , deregisterParticipant ) where @@ -147,18 +147,29 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do E.||. isCourseExamCorrector muid ata (course E.^. CourseId) ) + mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..} + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow when (isRegistered && not mayViewCourseAfterDeregistration) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse + unless mayReRegister $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration return $ CourseRegisterForm <$ secretRes <*> appTextRes <*> appFilesRes +courseMayReRegister :: Entity Course -> DB Bool +courseMayReRegister (Entity cid Course{..}) = do + registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ] + let capacity = maybe True (>= registrations) courseCapacity + + wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR + -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. @@ -273,7 +284,6 @@ deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication == deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do - deleteApplications uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{}) -> do update partId [CourseParticipantState =. CourseParticipantInactive False] diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 619c79818..f34d5048f 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -106,7 +106,9 @@ getCShowR tid ssh csh = do return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) + mayReRegister <- lift . courseMayReRegister $ Entity cid course + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 30b351113..6e76ed20b 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -43,6 +43,8 @@ import Control.Lens.Indexed ((<.), (.>)) import Jobs.Queue +import qualified Control.Monad.State.Class as State + type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User) @@ -613,8 +615,7 @@ postEUsersR tid ssh csh examn = do -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser' dbCsvNew - unless isPart $ - yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew + yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ @@ -706,6 +707,22 @@ postEUsersR tid ssh csh examn = do ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting + , dbtCsvValidateActions = do + selectedActions <- State.get + availableActions <- ask + let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions + where + examDataUsers = flip mapMaybe selectedActions $ \case + ExamUserCsvSetResultData{..} -> Just examUserCsvActUser + ExamUserCsvSetBonusData{..} -> Just examUserCsvActUser + ExamUserCsvSetPartResultData{..} -> Just examUserCsvActUser + _other -> Nothing + isRegisterAction uid = \case + ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser + ExamUserCsvRegisterData{..} -> uid == examUserCsvActUser + _other -> False + unless (null missingExamDataUsers) $ + tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 743bb67f2..53382e491 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -476,8 +476,6 @@ makeProfileData (Entity uid User{..}) = do examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip tutorialTable = i18n MsgPersonalInfoTutorialsWip - lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication - lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation cID <- encrypt uid mCRoute <- getCurrentRoute diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2a2400919..b652b2cc4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -52,18 +52,16 @@ hijackUserForm csrf = do data UserAction = UserLdapSync | UserHijack deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe UserAction -instance Finite UserAction nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe AllUsersAction -instance Finite AllUsersAction nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllUsersAction id @@ -276,6 +274,19 @@ instance Button UniWorX ButtonAuthMode where btnClasses _ = [BCIsButton] +data UserAssimilateButton = BtnUserAssimilate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + +instance Button UniWorX UserAssimilateButton where + btnClasses _ = [BCIsButton, BCPrimary] + +nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''UserAssimilateButton id + + + + getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR = postAdminUserR postAdminUserR uuid = do @@ -392,9 +403,33 @@ postAdminUserR uuid = do | otherwise -> addMessageI Info MsgUserSystemFunctionsNotChanged redirect $ AdminUserR uuid - ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm - ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm - ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' + let assimilateForm' = renderAForm FormStandard $ + areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing + assimilateAction oldUserId = do + res <- try . runDB . setSerializable $ assimilateUser uid oldUserId + case res of + Left (err :: UserAssimilateException) -> + addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right + [whamlet| +
+ #{tshow err} + |] + Right warnings -> do + unless (null warnings) $ + addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right + [whamlet| + $newline never +