diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index da018ff3f..547092e46 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -7,6 +7,8 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnCourseRegister: Zum Kurs anmelden BtnCourseDeregister: Vom Kurs abmelden +BtnCourseApply: Zum Kurs bewerben +BtnCourseRetractApplication: Bewerbung zum Kurs zurückziehen BtnExamRegister: Anmelden zur Prüfung BtnExamDeregister: Von der Prüfung abmelden BtnHijack: Sitzung übernehmen @@ -86,16 +88,19 @@ CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschrä CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. +CourseRegistration: Kursanmeldung CourseRegisterOpen: Anmeldung möglich -CourseRegisterOk: Anmeldung erfolgreich -CourseDeregisterOk: Erfolgreich abgemeldet +CourseRegisterOk: Erfolgreich zum Kurs angemeldet +CourseDeregisterOk: Erfolgreich vom Kurs abgemeldet +CourseApplyOk: Erfolgreich zum Kurs beworben +CourseRetractApplyOk: Bewerbung zum Kurs erfolgreich zurückgezogen CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren -CourseStudyFeature: Assoziiertes Hauptfach -CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert -CourseStudyFeatureNone: Kein assoziiertes Hauptfach +CourseStudyFeature: Assoziiertes Studienfach +CourseStudyFeatureTip: Dient ausschließlich der Information der Kursverwalter +CourseStudyFeatureUpdated: Assoziiertes Studienfach geändert +CourseStudyFeatureNone: Kein assoziiertes Studienfach CourseTutorial: Tutorium -CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen -CourseSecretWrong: Falsches Kennwort +CourseSecretWrong: Falsches Passwort CourseSecret: Zugangspasswort CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert. CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester. @@ -113,7 +118,7 @@ CourseMembers: Teilnehmer CourseMemberOf: Teilnehmer CourseMembersCount n@Int: #{n} CourseMembersCountLimited n@Int max@Int: #{n}/#{max} -CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Anmeldungen #{maybeToMessage " von " mbNum " möglichen"} +CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"} CourseName: Name CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet @@ -137,8 +142,8 @@ CourseUserNote: Notiz CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht -CourseUserDeregister: Abmelden -CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +CourseUserDeregister: Vom Kurs abmelden +CourseUsersDeregistered count@Int64: #{show count} Teilnehmer vom Kurs abgemeldet CourseUserSendMail: Mitteilung verschicken TutorialUserDeregister: Vom Tutorium Abmelden TutorialUserSendMail: Mitteilung verschicken @@ -150,20 +155,48 @@ CourseAllocationOption term@Text name@Text: #{name} (#{term}) CourseAllocationMinCapacity: Minimale Teilnehmeranzahl CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein -CourseAllocationInstructions: Anweisungen zur Bewerbung -CourseAllocationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben -CourseAllocationApplicationTemplate: Bewerbungsvorlagen -CourseAllocationApplicationText: Text-Bewerbungen -CourseAllocationApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen? -CourseAllocationApplicationRatingsVisible: Feedback für Bewerbungen -CourseAllocationApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden? +CourseApplicationInstructions: Anweisungen zur Bewerbung/Anmeldung +CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden +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? +CourseApplicationRatingsVisible: Feedback für Bewerbungen +CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden? +CourseApplicationRequired: Bewerbungsverfahren +CourseApplicationRequiredTip: Sollen Anmeldungen zu diesem Kurs zunächst provisorisch (ohne Kapazitätsbeschränkung) sein, bis sie durch einen Kursverwalter (nach Bewertung der Bewerbungen) akzeptiert werden? +CourseApplicationInstructionsApplication: Anweisungen zur Bewerbung +CourseApplicationInstructionsRegistration: Anweisungen zur Anmeldung +CourseApplicationTemplateApplication: Bewerbungsvorlage(n) +CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) +CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen +CourseApplicationText: Text-Bewerbung +CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! +CourseRegistrationText: Text zur Anmeldung +CourseRegistrationFollowInstructions: Beachten Sie die Anweisungen zur Anmeldung! + +CourseApplicationFile: Bewerbung +CourseApplicationFiles: Bewerbungsdatei(en) +CourseApplicationArchive: Zip-Archiv der Bewerbungsdatei(en) +CourseRegistrationFile: Datei zur Anmeldung +CourseRegistrationFiles: Datei(en) zur Anmeldung +CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung +CourseApplicationNoFiles: Keine Datei(en) + +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. + +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 + +CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName} CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden -CourseFormSectionRegistration: Anmeldung +CourseFormSectionRegistration: Anmeldung zum Kurs CourseFormSectionAdministration: Verwaltung CourseLecturers: Kursverwalter @@ -293,11 +326,13 @@ MaterialDeleteCaption: Wollen Sie das unten aufgeführte Material wirklich lösc MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Dateien"} MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht. MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht +MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName} Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) +UnauthorizedNot i@Text: (NICHT #{i}) UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. @@ -314,9 +349,11 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen. UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen. UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. +UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. @@ -448,6 +485,10 @@ UpdatedSheetCorrectorsAutoFailed n@Int: #{n} #{pluralDE n "Abgabe konnte" "Abgab CouldNotAssignCorrectorsAuto num@Int64: #{num} Abgaben konnten nicht automatisch zugewiesen werden: SelfCorrectors num@Int64: #{num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt! +SubmissionOriginal: Original +SubmissionCorrected: Korrigiert +SubmissionArchiveName: abgaben +SubmissionTypeArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName subId@CryptoFileNameSubmission renderedSfType@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-#{foldCase (toPathPiece subId)}-#{foldCase renderedSfType} CorrectionSheets: Übersicht Korrekturen nach Blättern CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren @@ -647,7 +688,7 @@ StudyFeatureAge: Fachsemester StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach FieldSecondary: Nebenfach -NoPrimaryStudyField: (kein Hauptfach registriert) +NoStudyField: Kein Studienfach StudyFeatureType: StudyFeatureValid: Aktiv StudyFeatureUpdate: Abgeglichen @@ -775,6 +816,9 @@ SheetGroupMaxGroupsize: Maximale Gruppengröße SheetFiles: Übungsblatt-Dateien SheetFileTypeHeader: Zugehörigkeit +SheetArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} +SheetTypeArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName renderedSft@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-#{foldCase renderedSft} + NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen @@ -974,6 +1018,7 @@ AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind er AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer +AuthTagExamResult: Nutzer hat Prüfungsergebnisse AuthTagParticipant: Nutzer ist mit Kurs assoziiert AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe AuthTagCapacity: Kapazität ist ausreichend @@ -1151,13 +1196,13 @@ HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet -CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden ohne assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Studienfach" "wurden ohne assoziierte Studienfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Prüfung angemeldet ExamRegistrationNotRegisteredWithoutCourse n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} nicht zur Prüfung angemeldet, da #{pluralDE n "er" "sie"} nicht zum Kurs angemeldet #{pluralDE n "ist" "sind"} -ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Prüfung, als auch #{pluralDE n "ohne assoziiertes Hauptfach" "ohne assoziierte Hauptfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Prüfung, als auch #{pluralDE n "ohne assoziiertes Studienfach" "ohne assoziierte Studienfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Prüfung angemeldet ExamRegistrationInviteDeadline: Einladung nur gültig bis ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen @@ -1267,11 +1312,11 @@ ExamPassed: Bestanden ExamNotPassed: Nicht bestanden ExamResult: Prüfungsergebnis -ExamRegisteredSuccess exam@ExamName: Erfolgreich zur #{exam} angemeldet -ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der #{exam} abgemeldet -ExamRegistered: Angemeldet -ExamNotRegistered: Nicht angemeldet -ExamRegistration: Anmeldung +ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Prüfung #{exam} angemeldet +ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Prüfung #{exam} abgemeldet +ExamRegistered: Zur Prüfung angemeldet +ExamNotRegistered: Nicht zur Prüfung angemeldet +ExamRegistration: Prüfungsanmeldung ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen @@ -1296,7 +1341,7 @@ ImplementationDetails: Implementierung ExamUsersHeading: Prüfungsteilnehmer ExamUserDeregister: Teilnehmer von Prüfung abmelden ExamUserAssignOccurrence: Termin/Raum zuweisen -ExamUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt CsvFile: CSV-Datei @@ -1322,9 +1367,9 @@ CsvColumnExamUserSurname: Nachname(n) des Teilnehmers CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers -CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat -CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt -CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Hauptfach +CsvColumnExamUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat +CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt +CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach CsvColumnExamUserOccurrence: Prüfungstermin/-Raum, zu dem der Teilnehmer angemeldet ist CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb erreicht hat CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können @@ -1344,14 +1389,14 @@ ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden -ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern +ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden -ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden +ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden TableHeadingFilter: Filter @@ -1369,8 +1414,8 @@ BtnPasswordReset: Passwort zurücksetzen AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden -AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an -AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an +AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung in Uni2work an +AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung in Uni2work an AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an diff --git a/models/allocations b/models/allocations index 71341e876..f7522696f 100644 --- a/models/allocations +++ b/models/allocations @@ -31,38 +31,14 @@ AllocationCourse allocation AllocationId course CourseId minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course - instructions Html Maybe -- instructions from the lecturer to applicants - applicationText Bool -- lecturer will read application texts supplied by users - applicationFiles UploadMode -- lecturer wants to receive course specific application files - ratingsVisible Bool -- lecturer wants applicants to receive feedback on their application (Grade & comment) UniqueAllocationCourse course -AllocationCourseFile - allocationCourse AllocationCourseId - file FileId - UniqueAllocationCourseFile allocationCourse file - AllocationUser allocation AllocationId user UserId totalCourses Natural -- number of total allocated courses for this user must be <= than this number UniqueAllocationUser allocation user -AllocationApplication - allocationCourse AllocationCourseId - allocationUser AllocationUserId - text Text Maybe -- free text entered by user - priority Natural -- priority, higher number means higher priority - ratingVeto Bool - ratingPoints ExamGrade Maybe - ratingComment Text Maybe - UniqueAllocationApplication allocationCourse allocationUser - -AllocationApplicationFile -- supplemental file for application by a user for a certain course - application AllocationApplicationId - file FileId - UniqueAllocationUserFile application file - AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId allocation AllocationId Maybe diff --git a/models/courses b/models/courses index 1376af569..bcbdf4979 100644 --- a/models/courses +++ b/models/courses @@ -17,9 +17,20 @@ Course -- Information about a single course; contained info is always visible deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase materialFree Bool -- False: only enrolled users may see course materials not stored in this table + applicationsRequired Bool + applicationsInstructions Html Maybe + applicationsText Bool + applicationsFiles UploadMode + applicationsRatingsVisible Bool TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic + +CourseAppInstructionFile + course CourseId + file FileId + UniqueCourseAppInstructionFile course file + CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId time UTCTime @@ -59,3 +70,18 @@ CourseUserNoteEdit -- who edited a participants course note when user UserId time UTCTime note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more + +CourseApplication + course CourseId + user UserId + field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades + text Text Maybe -- free text entered by user + ratingPoints ExamGrade Maybe + ratingComment Text Maybe + allocation AllocationId Maybe + allocationPriority Natural Maybe + time UTCTime default=now() +CourseApplicationFile + application CourseApplicationId + file FileId + UniqueApplicationFile application file \ No newline at end of file diff --git a/routes b/routes index 8ebe100e7..54f0fc5c5 100644 --- a/routes +++ b/routes @@ -86,7 +86,8 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free - /register CRegisterR GET POST !timeANDcapacityANDallocation-time !lecturerANDallocation-time + /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time + /register-template CRegisterTemplateR GET !free /edit CEditR GET POST /lecturer-invite CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDemptyANDallocation-time @@ -152,7 +153,9 @@ /users EUsersR GET POST /users/new EAddUserR GET POST /users/invite EInviteR GET POST - /register ERegisterR POST !timeANDcourse-registered !timeANDexam-registered + /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result + /apps/#CryptoFileNameCourseApplication CourseApplicationR: + /files CAFilesR GET !self !lecturerANDtime /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 493b8b1b7..3fc832273 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -30,6 +30,24 @@ data Transaction { transactionExam :: ExamId , transactionUser :: UserId } + | TransactionCourseParticipantEdit + { transactionCourse :: CourseId + , transactionUser :: UserId + } + | TransactionCourseParticipantDeleted + { transactionCourse :: CourseId + , transactionUser :: UserId + } + | TransactionCourseApplicationEdit + { transactionCourse :: CourseId + , transactionUser :: UserId + , transactionCourseApplication :: CourseApplicationId + } + | TransactionCourseApplicationDeleted + { transactionCourse :: CourseId + , transactionUser :: UserId + , transactionCourseApplication :: CourseApplicationId + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 4259cb2fd..915ad5de0 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -29,6 +29,8 @@ import qualified Data.CaseInsensitive as CI import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText) import Data.Aeson.Encoding (text) +import Text.Blaze (ToMarkup(..)) + instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey @@ -46,19 +48,23 @@ decCryptoIDs [ ''SubmissionId , ''ExamOccurrenceId , ''ExamPartId , ''AllocationId + , ''CourseApplicationId ] -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where +-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" +instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (CI FilePath)) where fromPathPiece (Text.unpack -> piece) = do piece' <- (stripPrefix `on` map CI.mk) "uwa" piece return . CryptoID . CI.mk $ map CI.original piece' toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where +instance {-# OVERLAPS #-} ToJSON (E.CryptoID "Submission" (CI FilePath)) where toJSON = String . toPathPiece -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where +instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "Submission" (CI FilePath)) where toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece) -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where +instance {-# OVERLAPS #-} FromJSON (E.CryptoID "Submission" (CI FilePath)) where parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where +instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) where fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece +instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where + toMarkup = toMarkup . toPathPiece diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index 60b6e9081..3e842dd6a 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -10,5 +10,11 @@ import Text.Blaze (ToMarkup(..)) import ClassyPrelude +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where + toMarkup = toMarkup . CI.foldedCase . CID.ciphertext + instance ToMarkup s => ToMarkup (CID.CryptoID c s) where - toMarkup = toMarkup . CID.ciphertext \ No newline at end of file + toMarkup = toMarkup . CID.ciphertext diff --git a/src/Foundation.hs b/src/Foundation.hs index 790f8c988..8282f3a78 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -54,6 +54,7 @@ import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -179,6 +180,10 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) +pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX +pattern CApplicationR tid ssh csh appId ptn + = CourseR tid ssh csh (CourseApplicationR appId ptn) + pluralDE :: (Eq a, Num a) => a -- ^ Count @@ -282,6 +287,7 @@ embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id +embedRenderMessage ''UniWorX ''SubmissionFileType id embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) @@ -518,6 +524,11 @@ andAR _ _ reason@(Unauthorized _) = reason andAR _ Authorized other = other andAR _ AuthenticationRequired _ = AuthenticationRequired +notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult +notAR _ _ (Unauthorized _) = Authorized +notAR _ _ AuthenticationRequired = AuthenticationRequired +notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg + trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult trueAR = const Authorized falseAR = Unauthorized . ($ MsgUnauthorized) . render @@ -580,14 +591,13 @@ 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 - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do + 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.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized -- other routes: access to any admin is granted here _other -> $cachedHereBinary mAuthId . exceptT return return $ do @@ -622,14 +632,13 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do 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 - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do + isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) + guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) return Authorized -- lecturer for any school will do _ -> $cachedHereBinary mAuthId . exceptT return return $ do @@ -688,6 +697,22 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> 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 + allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation + + case allocation of + Nothing -> return () + Just Allocation{..} -> do + cTime <- liftIO getCurrentTime + guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) + guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo + + return Authorized + + + 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 @@ -781,9 +806,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of | not registered , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed , maybe True (now <=) courseRegisterTo -> return Authorized - (Just (Entity _ Course{courseDeregisterUntil})) + (Just (Entity cid Course{courseDeregisterUntil})) | registered - , maybe True (now <=) courseDeregisterUntil -> return Authorized + -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + guard $ maybe True (now <=) courseDeregisterUntil + forM_ mAuthId $ \uid -> do + exams <- lift . E.select . E.from $ \exam -> do + E.where_ . E.exists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return $ exam E.^. ExamDeregisterUntil + forM_ exams $ \(E.Value deregUntil) -> + guard $ NTop (Just now) >= NTop deregUntil + return Authorized _other -> unauthorizedI MsgUnauthorizedCourseTime MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do @@ -844,20 +880,19 @@ tagAccessPredicate AuthAllocationTime = 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 - [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthCourseRegistered r tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId @@ -865,26 +900,24 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. tutorial E.^. TutorialName E.==. E.val tutn - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId @@ -892,20 +925,47 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. exam E.^. ExamName E.==. E.val examn - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) return Authorized CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthExamRegistered r +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 `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do + E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId + E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam + E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId)) + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` (examResult `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do + E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId + E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam + E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId)) + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of @@ -1004,10 +1064,9 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do + assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return E.countRows return Authorized r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of @@ -1044,19 +1103,24 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do referencedUser <- case route of - AdminUserR cID -> return cID - AdminUserDeleteR cID -> return cID - AdminHijackUserR cID -> return cID - UserNotificationR cID -> return cID - UserPasswordR cID -> return cID - CourseR _ _ _ (CUserR cID) -> return cID + AdminUserR cID -> decrypt cID + AdminUserDeleteR cID -> decrypt cID + AdminHijackUserR cID -> decrypt cID + UserNotificationR cID -> decrypt cID + UserPasswordR cID -> decrypt cID + CourseR _ _ _ (CUserR cID) -> decrypt cID + CApplicationR _ _ _ cID _ -> do + appId <- decrypt cID + application <- $cachedHereBinary appId . lift $ get appId + case application of + Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf + Just CourseApplication{..} -> return courseApplicationUser _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route - referencedUser' <- decrypt referencedUser case mAuthId of Just uid - | uid == referencedUser' -> return Authorized + | uid == referencedUser -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do @@ -1159,10 +1223,7 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral PLVariable{..} = evalAuthTag plVar - evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case - Unauthorized _ -> return Authorized - AuthenticationRequired -> return AuthenticationRequired - Authorized -> unauthorizedI plVar + evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR' = shortCircuitM (is _Authorized) (orAR mr) @@ -2731,6 +2792,7 @@ routeNormalizers = , ncCourse , ncSheet , verifySubmission + , verifyCourseApplication ] where normalizeRender route = route <$ do @@ -2777,6 +2839,14 @@ routeNormalizers = let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr tell . Any $ route /= newRoute return newRoute + verifyCourseApplication = maybeOrig $ \route -> do + CApplicationR _tid _ssh _csh cID sr <- return route + aId <- decrypt cID + CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId + Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse + let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr + tell . Any $ route /= newRoute + return newRoute -- How to run database actions. diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index aae2bc46a..93b837fa9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,6 +15,7 @@ import Handler.Course.Register as Handler.Course import Handler.Course.Show as Handler.Course import Handler.Course.User as Handler.Course import Handler.Course.Users as Handler.Course +import Handler.Course.Application as Handler.Course getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs new file mode 100644 index 000000000..17fa5127b --- /dev/null +++ b/src/Handler/Course/Application.hs @@ -0,0 +1,37 @@ +module Handler.Course.Application + ( getCAFilesR + ) where + +import Import + +import Handler.Utils + +import qualified Database.Esqueleto as E + +import System.FilePath (addExtension) + +import qualified Data.Conduit.List as C + + +getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent +getCAFilesR tid ssh csh cID = do + appId <- decrypt cID + User{..} <- runDB $ do + CourseApplication{..} <- get404 appId + Course{..} <- get404 courseApplicationCourse + let matches = and + [ tid == courseTerm + , ssh == courseSchool + , csh == courseShorthand + ] + unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR + get404 courseApplicationUser + + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName + let + fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do + E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId + E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId + return file + + serveSomeFiles archiveName $ fsSource .| C.map entityVal diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 8cb6a1bb5..cdedd90bb 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -41,6 +41,12 @@ data CourseForm = CourseForm , cfLink :: Maybe Text , cfMatFree :: Bool , cfAllocation :: Maybe AllocationCourseForm + , cfAppRequired :: Bool + , cfAppInstructions :: Maybe Html + , cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File)) + , cfAppText :: Bool + , cfAppFiles :: UploadMode + , cfAppRatingsVisible :: Bool , cfCapacity :: Maybe Int , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime @@ -51,43 +57,45 @@ data CourseForm = CourseForm data AllocationCourseForm = AllocationCourseForm { acfAllocation :: AllocationId - , acfInstructions :: Maybe Html - , acfFiles :: Maybe (Source Handler (Either FileId File)) - , acfApplicationText :: Bool - , acfApplicationFiles :: UploadMode - , acfApplicationRatingsVisible :: Bool , acfMinCapacity :: Int } courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm - { cfCourseId = Just cid - , cfName = courseName - , cfDesc = courseDescription - , cfLink = courseLinkExternal - , cfShort = courseShorthand - , cfTerm = courseTerm - , cfSchool = courseSchool - , cfCapacity = courseCapacity - , cfSecret = courseRegisterSecret - , cfMatFree = courseMaterialFree - , cfRegFrom = courseRegisterFrom - , cfRegTo = courseRegisterTo - , cfDeRegUntil = courseDeregisterUntil - , cfAllocation = allocationCourseToForm <$> alloc - , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] - ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ] + { cfCourseId = Just cid + , cfName = courseName + , cfDesc = courseDescription + , cfLink = courseLinkExternal + , cfShort = courseShorthand + , cfTerm = courseTerm + , cfSchool = courseSchool + , cfCapacity = courseCapacity + , cfSecret = courseRegisterSecret + , cfMatFree = courseMaterialFree + , cfAllocation = allocationCourseToForm <$> alloc + , cfAppRequired = courseApplicationsRequired + , cfAppInstructions = courseApplicationsInstructions + , cfAppInstructionFiles + , cfAppText = courseApplicationsText + , cfAppFiles = courseApplicationsFiles + , cfAppRatingsVisible = courseApplicationsRatingsVisible + , cfRegFrom = courseRegisterFrom + , cfRegTo = courseRegisterTo + , cfDeRegUntil = courseDeregisterUntil + , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] + ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ] } + where + cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue) + where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do + E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid + return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile + allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm { acfAllocation = allocationCourseAllocation , acfMinCapacity = allocationCourseMinCapacity - , acfInstructions = allocationCourseInstructions - , acfFiles = Nothing - , acfApplicationText = allocationCourseApplicationText - , acfApplicationFiles = allocationCourseApplicationFiles - , acfApplicationRatingsVisible = allocationCourseRatingsVisible } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm @@ -213,21 +221,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do _ -> do allocationOptions <- mkOptionList <$> mapM mkAllocationOption availableAllocations - oldFileIds <- for ((,) <$> (fmap acfAllocation $ template >>= cfAllocation) <*> (template >>= cfCourseId)) $ \(allId, cId) -> fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select . E.from $ \(allocationCourseFile `E.InnerJoin` allocationCourse) -> do - E.on $ allocationCourseFile E.^. AllocationCourseFileAllocationCourse E.==. allocationCourse E.^. AllocationCourseId - E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cId - E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allId - return $ allocationCourseFile E.^. AllocationCourseFileFile - - let allocationForm' = AllocationCourseForm <$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) - <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation)) - <*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation) - <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation) - <*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation) - <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ template >>= cfAllocation) <*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template) @@ -247,6 +243,12 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) <* aformSection MsgCourseFormSectionRegistration <*> allocationForm + <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) + <*> (assertM (not . null . renderHtml) <$> 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) + <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) @@ -425,20 +427,26 @@ courseEditHandler miButtonAction mbCourseForm = do } -> do -- create new course now <- liftIO getCurrentTime insertOkay <- runDBJobs $ do - insertOkay <- insertUnique Course - { courseName = cfName res - , courseDescription = cfDesc res - , courseLinkExternal = cfLink res - , courseShorthand = cfShort res - , courseTerm = cfTerm res - , courseSchool = cfSchool res - , courseCapacity = cfCapacity res - , courseRegisterSecret = cfSecret res - , courseMaterialFree = cfMatFree res - , courseRegisterFrom = cfRegFrom res - , courseRegisterTo = cfRegTo res - , courseDeregisterUntil = cfDeRegUntil res - } + insertOkay <- let CourseForm{..} = res + in insertUnique Course + { courseName = cfName + , courseDescription = cfDesc + , courseLinkExternal = cfLink + , courseShorthand = cfShort + , courseTerm = cfTerm + , courseSchool = cfSchool + , courseCapacity = cfCapacity + , courseRegisterSecret = cfSecret + , courseMaterialFree = cfMatFree + , courseApplicationsRequired = cfAppRequired + , courseApplicationsInstructions = cfAppInstructions + , courseApplicationsText = cfAppText + , courseApplicationsFiles = cfAppFiles + , courseApplicationsRatingsVisible = cfAppRatingsVisible + , courseRegisterFrom = cfRegFrom + , courseRegisterTo = cfRegTo + , courseDeregisterUntil = cfDeRegUntil + } whenIsJust insertOkay $ \cid -> do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds @@ -466,20 +474,26 @@ courseEditHandler miButtonAction mbCourseForm = do case old of Nothing -> addMessageI Error MsgInvalidInput $> False (Just _) -> do - updOkay <- myReplaceUnique cid Course - { courseName = cfName res - , courseDescription = cfDesc res - , courseLinkExternal = cfLink res - , courseShorthand = cfShort res - , courseTerm = cfTerm res -- dangerous - , courseSchool = cfSchool res - , courseCapacity = cfCapacity res - , courseRegisterSecret = cfSecret res - , courseMaterialFree = cfMatFree res - , courseRegisterFrom = cfRegFrom res - , courseRegisterTo = cfRegTo res - , courseDeregisterUntil = cfDeRegUntil res - } + updOkay <- let CourseForm{..} = res + in myReplaceUnique cid Course + { courseName = cfName + , courseDescription = cfDesc + , courseLinkExternal = cfLink + , courseShorthand = cfShort + , courseTerm = cfTerm -- dangerous + , courseSchool = cfSchool + , courseCapacity = cfCapacity + , courseRegisterSecret = cfSecret + , courseMaterialFree = cfMatFree + , courseApplicationsRequired = cfAppRequired + , courseApplicationsInstructions = cfAppInstructions + , courseApplicationsText = cfAppText + , courseApplicationsFiles = cfAppFiles + , courseApplicationsRatingsVisible = cfAppRatingsVisible + , courseRegisterFrom = cfRegFrom + , courseRegisterTo = cfRegTo + , courseDeregisterUntil = cfDeRegUntil + } case updOkay of (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do @@ -490,7 +504,19 @@ courseEditHandler miButtonAction mbCourseForm = do sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites insert_ $ CourseEdit aid now cid + + let + finsert val = do + fId <- lift $ either return insert val + tell $ Set.singleton fId + lift $ + void . insertUnique $ CourseAppInstructionFile cid fId + keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert + acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] + mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs + upsertAllocationCourse cid $ cfAllocation res + addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR @@ -522,38 +548,17 @@ upsertAllocationCourse cid cfAllocation = do when doEdit $ case cfAllocation of - Just AllocationCourseForm{..} -> do - Entity acId _ <- upsert AllocationCourse - { allocationCourseAllocation = acfAllocation - , allocationCourseCourse = cid - , allocationCourseMinCapacity = acfMinCapacity - , allocationCourseInstructions = acfInstructions - , allocationCourseApplicationText = acfApplicationText - , allocationCourseApplicationFiles = acfApplicationFiles - , allocationCourseRatingsVisible = acfApplicationRatingsVisible + Just AllocationCourseForm{..} -> + void $ upsert AllocationCourse + { allocationCourseAllocation = acfAllocation + , allocationCourseCourse = cid + , allocationCourseMinCapacity = acfMinCapacity } - [ AllocationCourseAllocation =. acfAllocation - , AllocationCourseCourse =. cid - , AllocationCourseMinCapacity =. acfMinCapacity - , AllocationCourseInstructions =. acfInstructions - , AllocationCourseApplicationText =. acfApplicationText - , AllocationCourseApplicationFiles =. acfApplicationFiles - , AllocationCourseRatingsVisible =. acfApplicationRatingsVisible + [ AllocationCourseAllocation =. acfAllocation + , AllocationCourseCourse =. cid + , AllocationCourseMinCapacity =. acfMinCapacity ] - - let - finsert val = do - fId <- lift $ either return insert val - tell $ Set.singleton fId - lift $ - void . insertUnique $ AllocationCourseFile acId fId - keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert - acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] [] - mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs Nothing | Just (Entity prevId _) <- prevAllocationCourse - -> do - acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] [] - mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs - delete prevId + -> delete prevId _other -> return () diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 529f64fc6..292d0bf26 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -82,10 +82,13 @@ participantInvitationConfig = InvitationConfig{..} invitationRestriction _ _ = return Authorized invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime - studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) - (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing + studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) + (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False - invitationInsertHook _ _ _ _ = id + invitationInsertHook _ _ CourseParticipant{..} _ act = do + res <- act + audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser + return res invitationSuccessMsg (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR @@ -165,6 +168,7 @@ postCAddUserR tid ssh csh = do , courseParticipantAllocated = False , .. } + lift . lift . audit $ TransactionCourseParticipantEdit cid uid return $ case courseParticipantField of Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 542e617d2..36a82ac97 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -1,66 +1,155 @@ module Handler.Course.Register ( ButtonCourseRegister(..) + , CourseRegisterForm(..) , courseRegisterForm , getCRegisterR, postCRegisterR ) where import Import -import Utils.Form +import Utils.Lens import Handler.Utils import Data.Function ((&)) +import qualified Data.Text as Text + +import qualified Data.Conduit.List as C + +import Database.Persist.Sql (transactionUndo) +import qualified Database.Esqueleto as E + -- Dedicated CourseRegistrationButton -data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister +data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCourseRegister instance Finite ButtonCourseRegister nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonCourseRegister id instance Button UniWorX ButtonCourseRegister where - btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] - btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] + btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] + btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] + btnClasses BtnCourseApply = [BCIsButton, BCPrimary] + btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger] - btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] - btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] + btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] + btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] + btnLabel BtnCourseApply = [whamlet|#{iconApply True} _{MsgBtnCourseApply}|] + btnLabel BtnCourseRetractApplication = [whamlet|#{iconApply False} _{MsgBtnCourseRetractApplication}|] + + +data CourseRegisterForm = CourseRegisterForm + { crfStudyFeatures :: Maybe StudyFeaturesId + , crfApplicationText :: Maybe Text + , crfApplicationFiles :: Maybe (Source Handler File) + } + +courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) +-- ^ `CourseRegisterForm` for current user +courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do + muid <- maybeAuthId + (registration, application) <- runDB $ do + registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid + application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] + return (registration, application) + let btn | courseApplicationsRequired + , is _Just application + = BtnCourseRetractApplication + | is _Just registration + = BtnCourseDeregister + | courseApplicationsRequired + = BtnCourseApply + | otherwise + = BtnCourseRegister + isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister] + return . (, btn) . wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + + secretRes <- if + | Just secret <- courseRegisterSecret + , not isRegistered + -> let guardSecret (FormSuccess secret') + | secret == secret' = return $ FormSuccess () + | otherwise = formFailure [MsgCourseSecretWrong] + guardSecret FormMissing = return FormMissing + guardSecret (FormFailure errs) = return $ FormFailure errs + in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing + | otherwise + -> return $ FormSuccess () + + fieldRes <- if + | is _Nothing muid + -> return $ FormSuccess Nothing + | is _Just muid + , isRegistered + , Just mFeature <- courseApplicationField . entityVal <$> application + <|> courseParticipantField . entityVal <$> registration + -> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature + | otherwise + -> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing + + appTextRes <- let fs | courseApplicationsRequired + , is _Just courseApplicationsInstructions + = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions + | courseApplicationsRequired + = fslI MsgCourseApplicationText + | is _Just courseApplicationsInstructions + = fslI MsgCourseRegistrationText & setTooltip MsgCourseRegistrationFollowInstructions + | otherwise + = fslI MsgCourseRegistrationText + textField' = convertField unTextarea Textarea textareaField + in if + | not courseApplicationsText + -> return $ FormSuccess Nothing + | is _Just muid + , isRegistered + -> wforced (convertField Just (fromMaybe Text.empty) textField') fs (application >>= courseApplicationText . entityVal) + | otherwise + -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) + + hasFiles <- for application $ \(Entity appId _) + -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + appCID <- for application $ encrypt . entityKey + let appFilesInfo = (,) <$> hasFiles <*> appCID + filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired + + if + | isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles + -> let filesLinkField = Field{..} + where + fieldParse _ _ = return $ Right Nothing + fieldEnctype = mempty + fieldView theId _ attrs _ _ + = [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appCID) + + _{filesMsg} + $of _ + + _{MsgCourseApplicationNoFiles} + |] + in void $ wforced filesLinkField (fslI filesMsg) Nothing + | otherwise + -> return () + + appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive + | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive + in if + | isRegistered + -> return $ FormSuccess Nothing + | otherwise + -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + + return $ CourseRegisterForm + <$ secretRes + <*> fieldRes + <*> appTextRes + <*> appFilesRes --- | Registration button with maybe a userid if logged in --- , maybe existing features if already registered --- , maybe some default study features --- , maybe a course secret -courseRegisterForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) --- unfinished WIP: must take study features if registred and show as mforced field -courseRegisterForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do - -- secret fields - (msecretRes', msecretView) <- case msecret of - (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing - _ -> return (Nothing,Nothing) - -- study features - (msfRes', msfView) <- case loggedin of - Nothing -> return (Nothing,Nothing) - Just _ -> bimap Just Just <$> case participant of - Just CourseParticipant{courseParticipantField=Just sfid} - -> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid) - _other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature - & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid) - -- button de-/register - (btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister isRegistered) "buttonField ignores settings anyway" Nothing - - let widget = $(widgetFile "widgets/register-form/register-form") - let msecretRes | Just res <- msecretRes' = Just <$> res - | otherwise = FormSuccess Nothing - let msfRes | Just res <- msfRes' = res - | otherwise = FormSuccess Nothing - -- checks that correct button was pressed, and ignores result of btnRes - let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes) - return (formRes, widget) - where - isRegistered = isJust participant - - -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -76,21 +165,85 @@ getCRegisterR tid ssh csh = do postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do - aid <- requireAuthId - (cid, course, registration) <- runDB $ do - (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh - registration <- getBy (UniqueParticipant aid cid) - return (cid, course, entityVal <$> registration) - let isRegistered = isJust registration - ((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course - formResult regResult $ \(mbSfId,codeOk) -> if - | isRegistered -> do - runDB $ deleteBy $ UniqueParticipant aid cid - addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk - | codeOk -> do - actTime <- liftIO getCurrentTime - regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False - when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk - | otherwise -> addMessageI Warning MsgCourseSecretWrong - -- addMessage Info $ toHtml $ show regResult -- For debugging only + uid <- requireAuthId + course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course + ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm' + formResult regResult $ \CourseRegisterForm{..} -> do + cTime <- liftIO getCurrentTime + let + mkApplication + | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles) + = void <$> do + appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] + appRes <- case appIds of + [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText Nothing Nothing Nothing Nothing cTime + (prevId:ps) -> do + forM_ ps $ \appId -> do + deleteApplicationFiles appId + delete appId + audit $ TransactionCourseApplicationDeleted cid uid appId + + deleteApplicationFiles prevId + update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ] + + return $ Just prevId + + whenIsJust appRes $ + audit . TransactionCourseApplicationEdit cid uid + whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do + runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) + return appRes + | otherwise + = return $ Just () + mkRegistration = do + audit $ TransactionCourseParticipantEdit cid uid + insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False + + deleteApplications = do + appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] + forM_ appIds $ \appId -> do + deleteApplicationFiles appId + delete appId + audit $ TransactionCourseApplicationDeleted cid uid appId + + deleteApplicationFiles appId = do + fs <- selectList [ CourseApplicationFileApplication ==. appId ] [] + deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ] + case courseRegisterButton of + BtnCourseRegister -> runDB $ do + regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration + case regOk of + Nothing -> transactionUndo + Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk + BtnCourseDeregister -> runDB $ do + deleteApplications + deleteBy $ UniqueParticipant uid cid + audit $ TransactionCourseParticipantDeleted cid uid + + examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do + E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return examRegistration + forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do + delete erId + audit $ TransactionExamDeregister examRegistrationExam uid + + examResults <- E.select . E.from $ \(examResult `E.InnerJoin` exam) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return examResult + forM_ examResults $ \(Entity erId ExamResult{..}) -> do + delete erId + audit $ TransactionExamResultDeleted examResultExam uid + + addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk + BtnCourseApply -> runDB $ do + regOk <- mkApplication + case regOk of + Nothing -> transactionUndo + Just _ -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk + BtnCourseRetractApplication -> runDB $ do + deleteApplications + addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk redirect $ CourseR tid ssh csh CShowR diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index d5b24b951..0eca71463 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,5 +1,6 @@ module Handler.Course.Show ( getCShowR + , getCRegisterTemplateR ) where import Import @@ -11,7 +12,7 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import qualified Data.CaseInsensitive as CI -import Data.Function ((&)) +import Utils.Lens import qualified Data.Map as Map @@ -19,11 +20,15 @@ import qualified Database.Esqueleto as E import Handler.Course.Register +import System.FilePath (addExtension) + +import qualified Data.Conduit.List as C + getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -38,7 +43,6 @@ getCShowR tid ssh csh = do E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId return ( E.countRows :: E.SqlExpr (E.Value Int)) return (course,school E.^. SchoolName, numParticipants, participant) - defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid @@ -66,19 +70,27 @@ getCShowR tid ssh csh = do E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid E.limit 1 return allocation - return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors,mAllocation) + hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> + E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid + mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] + return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration - (regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course - let regForm = wrapForm regWidget def - { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR - , formEncoding = regEnctype - , formSubmit = FormNoSubmit - } - registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True + regForm <- if + | is _Just mbAid -> do + (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course) + (regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm' + return $ wrapForm' regButton regWidget def + { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR + , formEncoding = regEnctype + , formSubmit = FormSubmit + } + | otherwise + -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR + registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR let tutorialDBTable = DBTable{..} @@ -224,3 +236,15 @@ getCShowR tid ssh csh = do siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") + +getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent +getCRegisterTemplateR tid ssh csh = do + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh + let source = (.| C.map entityVal) . E.selectSource . E.from $ \(file `E.InnerJoin` courseAppInstructionFile `E.InnerJoin` course) -> do + E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse + E.on $ courseAppInstructionFile E.^. CourseAppInstructionFileFile E.==. file E.^. FileId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return file + serveSomeFiles archiveName source diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 0fa340a08..798e23244 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -95,7 +95,7 @@ postCUserR tid ssh csh uCId = do ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf -> let currentField :: Maybe (Maybe StudyFeaturesId) currentField = courseParticipantField . entityVal <$> mRegistration - in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField + in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField let registrationFieldFrag :: Text registrationFieldFrag = "registration-field" @@ -111,6 +111,7 @@ postCUserR tid ssh csh uCId = do formResult regFieldRes $ \courseParticipantField' -> do runDB $ do update pId [ CourseParticipantField =. courseParticipantField' ] + audit $ TransactionCourseParticipantEdit cid uid addMessageI Success MsgCourseStudyFeatureUpdated redirect $ currentRoute :#: registrationFieldFrag @@ -140,17 +141,22 @@ postCUserR tid ssh csh uCId = do -> invalidArgs ["User not registered"] BtnCourseRegister -> do now <- liftIO getCurrentTime - let primaryField - | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies + let field + | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies = Just featId | otherwise = Nothing - pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField False + pId <- runDB $ do + pId <- insertUnique $ CourseParticipant cid uid now field False + when (is _Just pId) $ + audit $ TransactionCourseParticipantEdit cid uid + return pId case pId of Just _ -> do addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute Nothing -> invalidArgs ["User already registered"] + _other -> fail "Invalid @regButton@" mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c7e0f1378..f0c0da708 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -251,10 +251,14 @@ postCUsersR tid ssh csh = do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregister,selectedUsers) -> do - nrDel <- runDB $ deleteWhereCount - [ CourseParticipantCourse ==. cid - , CourseParticipantUser <-. Set.toList selectedUsers - ] + Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do + nrDel <- deleteWhereCount + [ CourseParticipantCourse ==. cid + , CourseParticipantUser ==. uid + ] + unless (nrDel == 0) $ + audit $ TransactionCourseParticipantDeleted cid uid + return $ Sum nrDel addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index fdc7fc3b0..f8e250831 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -149,6 +149,7 @@ postEAddUserR tid ssh csh examn = do , courseParticipantAllocated = False , .. } + lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift $ lift examRegister return $ case courseParticipantField of diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index e9d19f338..6ebcae157 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -90,12 +90,13 @@ examRegistrationInvitationConfig = InvitationConfig{..} case (isRegistered, invDBExamRegistrationCourseRegister) of (False, False) -> permissionDeniedI MsgUnauthorizedParticipant (False, True ) -> do - fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing + fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do - whenIsJust mField $ \cpField -> + whenIsJust mField $ \cpField -> do insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False + audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser act <* doAudit diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index ac590c7ba..35a8842a4 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -443,6 +443,7 @@ postEUsersR tid ssh csh examn = do , courseParticipantField = examUserCsvActCourseField , courseParticipantAllocated = False } + audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser @@ -461,8 +462,10 @@ postEUsersR tid ssh csh examn = do audit $ TransactionExamRegister eid examUserCsvActUser ExamUserCsvAssignOccurrenceData{..} -> update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] - ExamUserCsvSetCourseFieldData{..} -> + ExamUserCsvSetCourseFieldData{..} -> do update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] + CourseParticipant{..} <- getJust examUserCsvActCourseParticipant + audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> do deleteBy $ UniqueExamResult eid examUserCsvActUser @@ -481,6 +484,10 @@ postEUsersR tid ssh csh examn = do ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration audit $ TransactionExamDeregister eid examRegistrationUser delete examUserCsvActRegistration + result <- getBy $ UniqueExamResult eid examRegistrationUser + forM_ result $ \(Entity erId _) -> do + delete erId + audit $ TransactionExamResultDeleted eid examRegistrationUser ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse whenIsJust noteId $ \nid -> do @@ -631,7 +638,6 @@ postEUsersR tid ssh csh examn = do , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester ] E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid - E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True E.limit 2 return $ studyFeatures E.^. StudyFeaturesId diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 3ff0c1349..d0abf6824 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -23,6 +23,8 @@ import Handler.Utils.Table.Columns import Control.Monad.Writer (MonadWriter(..), execWriterT) +import System.FilePath (addExtension) + data MaterialForm = MaterialForm { mfName :: MaterialName @@ -358,16 +360,19 @@ postMDelR tid ssh csh mnm = do -- | Serve all material-files getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent -getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery - where - archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip" - getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ - \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do - E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile - E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial - E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. material E.^. MaterialName E.==. E.val mnm - return file +getMArchiveR tid ssh csh mnm = do + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm + + let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ + \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do + E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile + E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial + E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. material E.^. MaterialName E.==. E.val mnm + return file + + serveSomeFiles archiveName getMatQuery + diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index b6fc50cfa..4a5cccef9 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -60,6 +60,8 @@ import Utils.Sql import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) +import System.FilePath (addExtension) + {- * Implement Handlers @@ -439,9 +441,8 @@ getSShowR tid ssh csh shn = do getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSArchiveR tid ssh csh shn = do - MsgRenderer mr <- getMsgRenderer - let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <.> "zip" - sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetArchiveName tid ssh csh shn + let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound] serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal @@ -476,8 +477,8 @@ getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh s getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent getSZipR tid ssh csh shn sft = do - MsgRenderer mr <- getMsgRenderer - let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <> "_" <> (unpack $ toPathPiece sft) <.> "zip" + sft' <- ap getMessageRender $ pure sft + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft' serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index fa8decc7f..0d2268d24 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -45,6 +45,8 @@ import Text.Hamlet (ihamlet) -- import qualified Yesod.Colonnade as Yesod -- import qualified Text.Blaze.Html5.Attributes as HA +import System.FilePath (addExtension) + -- DEPRECATED: We always show all edits! -- numberOfSubmissionEditDates :: Int64 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. @@ -124,26 +126,9 @@ submissionUserInvitationConfig = InvitationConfig{..} makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) - <$> fileUploadForm + <$> fileUploadForm (is _Just msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode <*> wFormToAForm submittorsForm where - fileUploadForm = case uploadMode of - NoUpload - -> pure Nothing - UploadAny{..} - -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing - UploadSpecific{..} - -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) - - specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File)) - specificFileForm spec@UploadSpecificFile{..} - = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing - - mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File) - mergeFileSources (catMaybes -> sources) = case sources of - [] -> Nothing - fs -> Just $ sequence_ fs - miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do @@ -574,11 +559,10 @@ getSubArchiveR tid ssh csh shn cID sfType = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False - let filename - | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType - | otherwise = toPathPiece cID + sfType' <- ap getMessageRender $ pure sfType + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' - source = do + let source = do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID @@ -593,7 +577,7 @@ getSubArchiveR tid ssh csh shn cID sfType = do when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating - serveSomeFiles (unpack filename <.> "zip") source + serveSomeFiles archiveName source getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubDelR = postSubDelR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 155774b6f..65e701eed 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -75,7 +75,7 @@ serveSomeFiles archiveName source = do [file] -> sendThisFile file _moreFiles -> do setContentDisposition' $ Just archiveName - respondSourceDB "application/zip" $ do + respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder @@ -92,7 +92,7 @@ serveZipArchive archiveName source = do [] -> notFound _moreFiles -> do setContentDisposition' $ Just archiveName - respondSourceDB "application/zip" $ do + respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 03a9d4d77..0ebbb4cdb 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -32,7 +32,6 @@ import qualified Data.Map as Map import qualified Data.Vector as Vector import qualified Data.HashMap.Strict as HashMap -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A @@ -43,8 +42,8 @@ instance Exception CsvParseError typeCsv, typeCsv' :: ContentType -typeCsv = "text/csv" -typeCsv' = BS.intercalate "; " [typeCsv, "charset=UTF-8", "header=present"] +typeCsv = simpleContentType typeCsv' +typeCsv' = "text/csv; charset=UTF-8; header=present" extensionCsv :: Extension extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 00d2ef698..4db9808a8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -25,6 +25,7 @@ import Handler.Utils.Zip import qualified Data.Conduit.List as C import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Data.Set (Set) import qualified Data.Set as Set @@ -337,25 +338,35 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName --- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user) + +-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user) studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? -> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) -studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do +{-# DEPRECATED studyFeaturesPrimaryFieldFor "Use studyFeaturesFieldFor" #-} +studyFeaturesPrimaryFieldFor = studyFeaturesFieldFor . Just $ Set.singleton FieldPrimary + +-- | Select one of the user's active study features, or from a given list of StudyFeatures (regardless of user) +studyFeaturesFieldFor :: Maybe (Set StudyFieldType) -- ^ Optionally restrict fields to only given types + -> Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? + -> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) +studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do -- we need a join, so we cannot just use optionsPersistCryptoId rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) - E.||. isPrimaryActiveUserStudyFeature feature + E.||. (isActiveUserStudyFeature feature E.&&. isCorrectType feature) return (feature E.^. StudyFeaturesId, degree, field) MsgRenderer mr <- getMsgRenderer - mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions + mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions mr) rawOptions where - isPrimaryActiveUserStudyFeature feature = case mbuid of - Nothing -> E.val False - (Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid - E.&&. feature E.^. StudyFeaturesValid E.==. E.val True - E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + isActiveUserStudyFeature feature = case mbuid of + Nothing -> E.false + Just uid -> feature E.^. StudyFeaturesUser E.==. E.val uid + E.&&. feature E.^. StudyFeaturesValid + isCorrectType feature = case mRestr of + Nothing -> E.true + Just restr -> feature E.^. StudyFeaturesType `E.in_` E.valList (Set.toList restr) procOptions :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId)) procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do @@ -375,7 +386,7 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do nullOption = Option { optionDisplay = emptyOpt , optionInternalValue = Nothing - , optionExternalValue = "NoPrimaryStudyField" + , optionExternalValue = "NoStudyField" } @@ -387,7 +398,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp [ ( UploadModeNone, pure NoUpload) , ( UploadModeAny , UploadAny - <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips) + <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _unpackZips)) <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction) ) , ( UploadModeSpecific @@ -458,6 +469,8 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout") + + submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev where @@ -648,12 +661,37 @@ zipFileField doUnpack permittedExtensions = Field{..} | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField") - zipExtensions = mimeExtensions "application/zip" + zipExtensions = mimeExtensions typeZip acceptRestricted = isJust permittedExtensions accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions -multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File)) +fileUploadForm :: Bool -- ^ Required? + -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` + -> UploadMode -> AForm Handler (Maybe (Source Handler File)) +fileUploadForm isReq mkFs = \case + NoUpload + -> pure Nothing + UploadAny{..} + -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt isReq) (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing + UploadSpecific{..} + -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) + where + specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File)) + specificFileForm spec@UploadSpecificFile{..} + = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing + + mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File) + mergeFileSources (catMaybes -> sources) = case sources of + [] -> Nothing + fs -> Just $ sequence_ fs + +multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField` + -> Field Handler (Source Handler (Either FileId File)) +multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton + +multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference + -> Field Handler (Source Handler (Either FileId File)) multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 345f8a4b1..bcda2d83c 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -279,8 +279,9 @@ submissionMultiArchive (Set.toList -> ids) = do execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) -> tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) - setContentDisposition' $ Just "submissions.zip" - (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do + archiveName <- ap getMessageRender $ pure MsgSubmissionArchiveName + setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip) + (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index c1fd25524..7bf382fb4 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -2,7 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Zip - ( ZipError(..) + ( typeZip, extensionZip + , ZipError(..) , ZipInfo(..) , produceZip , consumeZip @@ -27,6 +28,16 @@ import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime) import Data.List (dropWhileEnd) +import qualified Data.Map as Map + + +typeZip :: ContentType +typeZip = "application/zip" + +extensionZip :: Extension +extensionZip = fromMaybe "zip" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeZip ] + + instance Default ZipInfo where def = ZipInfo @@ -95,7 +106,7 @@ modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle } -- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File sourceFiles fInfo - | mimeType == "application/zip" = do + | ((==) `on` simpleContentType) mimeType typeZip = do $logInfoS "sourceFiles" "Unpacking ZIP" fileSource fInfo =$= void consumeZip | otherwise = do diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 41d4a52ce..8ad57e8a4 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -34,8 +34,11 @@ import Text.Shakespeare.Text (st) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Except (MonadError(..)) import Utils (exceptT, allM, whenIsJust, guardM) +import Utils.Lens (_NoUpload) import Utils.DB (getKeyBy) +import Control.Lens + import Numeric.Natural import qualified Net.IP as IP @@ -398,6 +401,50 @@ customMigrations = Map.fromListWith (>>) updateTransactionInfo _ = return () runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo ) + , ( AppliedMigrationKey [migrationVersion|16.0.0|] [version|17.0.0|] + , do + whenM (tableExists "allocation_course") $ do + vals <- [sqlQQ| SELECT "course", "instructions", "application_text", "application_files", "ratings_visible" FROM "allocation_course"; |] + + whenM (tableExists "course") $ do + [executeQQ| + ALTER TABLE "course" ADD COLUMN "applications_required" boolean not null default #{False}, ADD COLUMN "applications_instructions" varchar null, ADD COLUMN "applications_text" boolean not null default #{False}, ADD COLUMN "applications_files" jsonb not null default #{NoUpload}, ADD COLUMN "applications_ratings_visible" boolean not null default #{False}; + ALTER TABLE "course" ALTER COLUMN "applications_required" DROP DEFAULT, ALTER COLUMN "applications_text" DROP DEFAULT, ALTER COLUMN "applications_files" DROP DEFAULT, ALTER COLUMN "applications_ratings_visible" DROP DEFAULT; + |] + + forM_ vals $ \(cid :: CourseId, Single applicationsInstructions :: Single (Maybe Html), Single applicationsText :: Single Bool, Single applicationsFiles :: Single UploadMode, Single applicationsRatingsVisible :: Single Bool) -> do + let appRequired = applicationsText || isn't _NoUpload applicationsFiles + [executeQQ| + UPDATE "course" SET ("applications_required", "applications_instructions", "applications_text", "applications_files", "applications_ratings_visible") = (#{appRequired}, #{applicationsInstructions}, #{applicationsText}, #{applicationsFiles}, #{applicationsRatingsVisible}) WHERE "id" = #{cid}; + |] + + [executeQQ| + ALTER TABLE "allocation_course" DROP COLUMN "instructions", DROP COLUMN "application_text", DROP COLUMN "application_files", DROP COLUMN "ratings_visible"; + |] + + whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do + [executeQQ| + CREATe TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL); + ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file"); + ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id"); + ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id"); + |] + + let getFileEntries = rawQuery [st|SELECT "allocation_course_file"."id", "allocation_course"."course", "allocation_course_file"."file" FROM "allocation_course_file" INNER JOIN "allocation_course" ON "allocation_course"."id" = "allocation_course_file"."allocation_course"|] [] + moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: FileId)] = + [executeQQ| + INSERT INTO "course_app_instruction_file" ("course", "file") VALUES (#{cid}, #{fid}); + DELETE FROM "allocation_course_file" WHERE "id" = #{acfId}; + |] + moveFileEntry _ = return () + runConduit $ getFileEntries .| C.mapM_ moveFileEntry + tableDropEmpty "allocation_course_file" + + whenM (tableExists "allocation_application") $ + tableDropEmpty "allocation_application" + whenM (tableExists "allocation_application_file") $ + tableDropEmpty "allocation_application_file" + ) ] diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index e76588b51..c18083055 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -45,6 +45,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthCourseRegistered | AuthTutorialRegistered | AuthExamRegistered + | AuthExamResult | AuthParticipant | AuthTime | AuthAllocationTime diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 582f9f35c..a7f6ceeae 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -54,6 +54,9 @@ data Icon | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only | IconEmail + | IconRegisterTemplate + | IconApplyTrue + | IconApplyFalse deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text @@ -82,6 +85,9 @@ iconText = \case IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only IconEmail -> "envelope" + IconRegisterTemplate -> "file-alt" + IconApplyTrue -> "file-alt" + IconApplyFalse -> "trash" instance Universe Icon instance Finite Icon @@ -150,6 +156,10 @@ iconEnrol :: Bool -> Markup iconEnrol True = icon IconEnrolTrue iconEnrol False = icon IconEnrolFalse +iconApply :: Bool -> Markup +iconApply True = icon IconApplyTrue +iconApply False = icon IconApplyFalse + iconExamRegister :: Bool -> Markup iconExamRegister True = icon IconExamRegisterTrue iconExamRegister False = icon IconExamRegisterFalse diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c33ab3f81..4c015f185 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -123,6 +123,7 @@ makePrisms ''HandlerContents makePrisms ''ErrorResponse +makePrisms ''UploadMode makeLenses_ ''UploadMode makeLenses_ ''SubmissionMode diff --git a/templates/course.hamlet b/templates/course.hamlet index be6d7db32..713f61e13 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -79,13 +79,38 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
\ Achtung: \ Abmeldung nur bis #{dereg} erlaubt. + $maybe aInst <- courseApplicationsInstructions course +
+ $if courseApplicationsRequired course + _{MsgCourseApplicationInstructionsApplication} + $else + _{MsgCourseApplicationInstructionsRegistration} +
+
+ #{aInst} + $if hasApplicationTemplate +

+ + #{iconRegisterTemplate} # + $if courseApplicationsRequired course + _{MsgCourseApplicationTemplateApplication} + $else + _{MsgCourseApplicationTemplateRegistration} $if registrationOpen || isJust mRegAt

+ _{MsgCourseRegistration}
$if registrationOpen $# regForm is defined through templates/widgets/registerForm ^{regForm} + $if isJust mApplication && courseApplicationsRequired course +

+ _{MsgCourseApplicationDeleteToEdit} + $else + $if isJust mRegAt +

+ _{MsgCourseRegistrationDeleteToEdit} $maybe date <- mRegAt _{MsgRegisteredSince} #{date}

diff --git a/templates/course/login-to-register.hamlet b/templates/course/login-to-register.hamlet new file mode 100644 index 000000000..70f0e31e9 --- /dev/null +++ b/templates/course/login-to-register.hamlet @@ -0,0 +1,5 @@ +$newline never +$if courseApplicationsRequired course + _{MsgCourseLoginToApply} +$else + _{MsgCourseLoginToRegister} diff --git a/test/Database.hs b/test/Database.hs index 270e64a50..ab0d96b90 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -420,6 +420,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit jost now ffp void . insert $ DegreeCourse ffp sdBsc sdInf @@ -452,6 +457,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit fhamann now eip void . insert' $ DegreeCourse eip sdBsc sdInf @@ -470,6 +480,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit fhamann now ixd void . insert' $ DegreeCourse ixd sdBsc sdInf @@ -488,6 +503,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit fhamann now ux3 void . insert' $ DegreeCourse ux3 sdBsc sdInf @@ -506,6 +526,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf @@ -662,6 +687,11 @@ fillDb = do , courseDeregisterUntil = Nothing , courseRegisterSecret = Just "dbs" , courseMaterialFree = False + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False } insert_ $ CourseEdit gkleen now dbs void . insert' $ DegreeCourse dbs sdBsc sdInf