fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(courses): rework couse registration

Browse Source 
Support course applications

BREAKING CHANGE: auditing for course registrations and deregistrations, more
tightly couple exam results, exam registration, and course registration (delete
them together now)
This commit is contained in:
Gregor Kleen 2019-08-12 16:54:37 +02:00
parent a00698e99e
commit 79d4ae20ee
24 changed files with 567 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
messages/uniworx/de.msg
View File

@ -7,6 +7,8 @@ BtnRegister: Anmelden
BtnDeregister: Abmelden BtnDeregister: Abmelden
BtnCourseRegister: Zum Kurs anmelden BtnCourseRegister: Zum Kurs anmelden
BtnCourseDeregister: Vom Kurs abmelden BtnCourseDeregister: Vom Kurs abmelden
BtnCourseApply: Zum Kurs bewerben
BtnCourseRetractApplication: Bewerbung zum Kurs zurückziehen
BtnExamRegister: Anmelden zur Prüfung BtnExamRegister: Anmelden zur Prüfung
BtnExamDeregister: Von der Prüfung abmelden BtnExamDeregister: Von der Prüfung abmelden
BtnHijack: Sitzung übernehmen BtnHijack: Sitzung übernehmen
@ -89,13 +91,15 @@ CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegistration: Kursanmeldung CourseRegistration: Kursanmeldung
CourseRegisterOk: Erfolgreich zum Kurs angemeldet CourseRegisterOk: Erfolgreich zum Kurs angemeldet
CourseDeregisterOk: Erfolgreich vom Kurs abgemeldet 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 CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
CourseStudyFeature: Assoziiertes Hauptfach CourseStudyFeature: Assoziiertes Studienfach
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert CourseStudyFeatureTip: Dient ausschließlich der Information der Kursverwalter
CourseStudyFeatureNone: Kein assoziiertes Hauptfach CourseStudyFeatureUpdated: Assoziiertes Studienfach geändert
CourseStudyFeatureNone: Kein assoziiertes Studienfach
CourseTutorial: Tutorium CourseTutorial: Tutorium
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Passwort
CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert. 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. 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.
@ -154,8 +158,8 @@ CourseApplicationInstructions: Anweisungen zur Bewerbung/Anmeldung
CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
CourseApplicationTemplate: Bewerbungsvorlagen CourseApplicationTemplate: Bewerbungsvorlagen
CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
CourseApplicationText: Text-Bewerbungen CourseApplicationsText: Text-Bewerbungen
CourseApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen? CourseApplicationsTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
CourseApplicationRatingsVisible: Feedback für Bewerbungen CourseApplicationRatingsVisible: Feedback für Bewerbungen
CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden? CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
CourseApplicationRequired: Bewerbungsverfahren CourseApplicationRequired: Bewerbungsverfahren
@ -166,6 +170,26 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen 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 CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
@ -305,6 +329,7 @@ MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@Mat
Unauthorized: Sie haben hierfür keine explizite Berechtigung. Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedNot i@Text: (NICHT #{i})
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
@ -321,9 +346,11 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen. UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen. UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. 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. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
@ -656,7 +683,7 @@ StudyFeatureAge: Fachsemester
StudyFeatureDegree: Abschluss StudyFeatureDegree: Abschluss
FieldPrimary: Hauptfach FieldPrimary: Hauptfach
FieldSecondary: Nebenfach FieldSecondary: Nebenfach
NoPrimaryStudyField: (kein Hauptfach registriert) NoStudyField: Kein Studienfach
StudyFeatureType: StudyFeatureType:
StudyFeatureValid: Aktiv StudyFeatureValid: Aktiv
StudyFeatureUpdate: Abgeglichen StudyFeatureUpdate: Abgeglichen
@ -986,6 +1013,7 @@ AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind er
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer
AuthTagExamResult: Nutzer hat Prüfungsergebnisse
AuthTagParticipant: Nutzer ist mit Kurs assoziiert AuthTagParticipant: Nutzer ist mit Kurs assoziiert
AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
AuthTagCapacity: Kapazität ist ausreichend AuthTagCapacity: Kapazität ist ausreichend
@ -1163,13 +1191,13 @@ HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet 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 CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Prüfung angemeldet 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"} 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 ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Prüfung angemeldet
ExamRegistrationInviteDeadline: Einladung nur gültig bis ExamRegistrationInviteDeadline: Einladung nur gültig bis
ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
@ -1334,9 +1362,9 @@ CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers
CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat CsvColumnExamUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt
CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Hauptfach CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach
CsvColumnExamUserOccurrence: Prüfungstermin/-Raum, zu dem der Teilnehmer angemeldet ist CsvColumnExamUserOccurrence: Prüfungstermin/-Raum, zu dem der Teilnehmer angemeldet ist
CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb erreicht hat 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 CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können
@ -1356,14 +1384,14 @@ ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden
ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvSetResult: Ergebnis eintragen
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden 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 ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
TableHeadingFilter: Filter TableHeadingFilter: Filter

14
models/courses
View File

@ -74,12 +74,14 @@ CourseUserNoteEdit -- who edited a participants course note when
CourseApplication CourseApplication
course CourseId course CourseId
user UserId user UserId
text Text Maybe -- free text entered by user field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
ratingPoints ExamGrade Maybe text Text Maybe -- free text entered by user
ratingComment Text Maybe ratingPoints ExamGrade Maybe
allocation AllocationId Maybe ratingComment Text Maybe
allocationPriority Natural Maybe allocation AllocationId Maybe
allocationPriority Natural Maybe
time UTCTime default=now()
CourseApplicationFile CourseApplicationFile
application CourseApplication application CourseApplicationId
file FileId file FileId
UniqueApplicationFile application file UniqueApplicationFile application file

8
routes
View File

@ -86,8 +86,8 @@
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / 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 /register-template CRegisterTemplateR GET !free
/edit CEditR GET POST /edit CEditR GET POST
/lecturer-invite CLecInviteR GET POST /lecturer-invite CLecInviteR GET POST
/delete CDeleteR GET POST !lecturerANDemptyANDallocation-time /delete CDeleteR GET POST !lecturerANDemptyANDallocation-time
@ -153,7 +153,9 @@
/users EUsersR GET POST /users EUsersR GET POST
/users/new EAddUserR GET POST /users/new EAddUserR GET POST
/users/invite EInviteR 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 CorrectionsR GET POST !corrector !lecturer
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer

18
src/Audit/Types.hs
View File

@ -30,6 +30,24 @@ data Transaction
{ transactionExam :: ExamId { transactionExam :: ExamId
, transactionUser :: UserId , 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) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions deriveJSON defaultOptions

16
src/CryptoID.hs
View File

@ -29,6 +29,8 @@ import qualified Data.CaseInsensitive as CI
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText) import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
import Data.Aeson.Encoding (text) import Data.Aeson.Encoding (text)
import Text.Blaze (ToMarkup(..))
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
@ -46,19 +48,23 @@ decCryptoIDs [ ''SubmissionId
, ''ExamOccurrenceId , ''ExamOccurrenceId
, ''ExamPartId , ''ExamPartId
, ''AllocationId , ''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 fromPathPiece (Text.unpack -> piece) = do
piece' <- (stripPrefix `on` map CI.mk) "uwa" piece piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
return . CryptoID . CI.mk $ map CI.original piece' return . CryptoID . CI.mk $ map CI.original piece'
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext 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 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) 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 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 fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
toMarkup = toMarkup . toPathPiece

8
src/Data/CryptoID/Instances.hs
View File

@ -10,5 +10,11 @@ import Text.Blaze (ToMarkup(..))
import ClassyPrelude 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 instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
toMarkup = toMarkup . CID.ciphertext toMarkup = toMarkup . CID.ciphertext

145
src/Foundation.hs
View File

@ -54,6 +54,7 @@ import Data.Conduit (($$))
import Data.Conduit.List (sourceList) import Data.Conduit.List (sourceList)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Except (MonadError(..), ExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..)) 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 pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid ssh csh shn (SubmissionR 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) pluralDE :: (Eq a, Num a)
=> a -- ^ Count => a -- ^ Count
@ -519,6 +524,11 @@ andAR _ _ reason@(Unauthorized _) = reason
andAR _ Authorized other = other andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired 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, falseAR :: MsgRendererS UniWorX -> AuthResult
trueAR = const Authorized trueAR = const Authorized
falseAR = Unauthorized . ($ MsgUnauthorized) . render falseAR = Unauthorized . ($ MsgUnauthorized) . render
@ -581,14 +591,13 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
-- Courses: access only to school admins -- Courses: access only to school admins
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized return Authorized
-- other routes: access to any admin is granted here -- other routes: access to any admin is granted here
_other -> $cachedHereBinary mAuthId . exceptT return return $ do _other -> $cachedHereBinary mAuthId . exceptT return return $ do
@ -623,14 +632,13 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
return Authorized return Authorized
-- lecturer for any school will do -- lecturer for any school will do
_ -> $cachedHereBinary mAuthId . exceptT return return $ do _ -> $cachedHereBinary mAuthId . exceptT return return $ do
@ -689,6 +697,22 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
return Authorized return Authorized
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of 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 CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@ -782,9 +806,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
| not registered | not registered
, maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
, maybe True (now <=) courseRegisterTo -> return Authorized , maybe True (now <=) courseRegisterTo -> return Authorized
(Just (Entity _ Course{courseDeregisterUntil})) (Just (Entity cid Course{courseDeregisterUntil}))
| registered | 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 _other -> unauthorizedI MsgUnauthorizedCourseTime
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
@ -845,20 +880,19 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCourseRegistered r r -> $unsupportedAuthPredicate AuthCourseRegistered r
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
@ -866,26 +900,24 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. tutorial E.^. TutorialName E.==. E.val tutn E.&&. tutorial E.^. TutorialName E.==. E.val tutn
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTutorialRegistered r r -> $unsupportedAuthPredicate AuthTutorialRegistered r
tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
@ -893,20 +925,47 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. exam E.^. ExamName E.==. E.val examn E.&&. exam E.^. ExamName E.==. E.val examn
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
guardMExceptT (c > 0) (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 return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
@ -1005,10 +1064,9 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ 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) . $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.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return E.countRows
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthEmpty r r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
@ -1045,19 +1103,24 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
guard submissionModeCorrector guard submissionModeCorrector
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r 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 referencedUser <- case route of
AdminUserR cID -> return cID AdminUserR cID -> decrypt cID
AdminUserDeleteR cID -> return cID AdminUserDeleteR cID -> decrypt cID
AdminHijackUserR cID -> return cID AdminHijackUserR cID -> decrypt cID
UserNotificationR cID -> return cID UserNotificationR cID -> decrypt cID
UserPasswordR cID -> return cID UserPasswordR cID -> decrypt cID
CourseR _ _ _ (CUserR cID) -> return 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 _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
referencedUser' <- decrypt referencedUser
case mAuthId of case mAuthId of
Just uid Just uid
| uid == referencedUser' -> return Authorized | uid == referencedUser -> return Authorized
Nothing -> return AuthenticationRequired Nothing -> return AuthenticationRequired
_other -> unauthorizedI MsgUnauthorizedSelf _other -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
@ -1160,10 +1223,7 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
evalAuthLiteral PLVariable{..} = evalAuthTag plVar evalAuthLiteral PLVariable{..} = evalAuthTag plVar
evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar
Unauthorized _ -> return Authorized
AuthenticationRequired -> return AuthenticationRequired
Authorized -> unauthorizedI plVar
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr) orAR' = shortCircuitM (is _Authorized) (orAR mr)
@ -2732,6 +2792,7 @@ routeNormalizers =
, ncCourse , ncCourse
, ncSheet , ncSheet
, verifySubmission , verifySubmission
, verifyCourseApplication
] ]
where where
normalizeRender route = route <$ do normalizeRender route = route <$ do
@ -2778,6 +2839,14 @@ routeNormalizers =
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
tell . Any $ route /= newRoute tell . Any $ route /= newRoute
return 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. -- How to run database actions.

1
src/Handler/Course.hs
View File

@ -15,6 +15,7 @@ import Handler.Course.Register as Handler.Course
import Handler.Course.Show as Handler.Course import Handler.Course.Show as Handler.Course
import Handler.Course.User as Handler.Course import Handler.Course.User as Handler.Course
import Handler.Course.Users as Handler.Course import Handler.Course.Users as Handler.Course
import Handler.Course.Application as Handler.Course
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

37
src/Handler/Course/Application.hs Normal file
View File

@ -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

2
src/Handler/Course/Edit.hs
View File

@ -246,7 +246,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> 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) <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
<*> apopt checkBoxField (fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationTextTip) (cfAppText <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
<*> uploadModeForm (cfAppFiles <$> template) <*> uploadModeForm (cfAppFiles <$> template)
<*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity

10
src/Handler/Course/ParticipantInvite.hs
View File

@ -82,10 +82,13 @@ participantInvitationConfig = InvitationConfig{..}
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False 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{..}) _ = invitationSuccessMsg (Entity _ Course{..}) _ =
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
@ -165,6 +168,7 @@ postCAddUserR tid ssh csh = do
, courseParticipantAllocated = False , courseParticipantAllocated = False
, .. , ..
} }
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
return $ case courseParticipantField of return $ case courseParticipantField of
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }

267
src/Handler/Course/Register.hs
View File

@ -1,66 +1,155 @@
module Handler.Course.Register module Handler.Course.Register
( ButtonCourseRegister(..) ( ButtonCourseRegister(..)
, CourseRegisterForm(..)
, courseRegisterForm , courseRegisterForm
, getCRegisterR, postCRegisterR , getCRegisterR, postCRegisterR
) where ) where
import Import import Import
import Utils.Form import Utils.Lens
import Handler.Utils import Handler.Utils
import Data.Function ((&)) 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 -- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegister instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1 nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where instance Button UniWorX ButtonCourseRegister where
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
btnClasses BtnCourseApply = [BCIsButton, BCPrimary]
btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger]
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] 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)
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
_{filesMsg}
$of _
<span ##{theId} *{attrs}>
_{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. -- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error. -- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -76,21 +165,85 @@ getCRegisterR tid ssh csh = do
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do postCRegisterR tid ssh csh = do
aid <- requireAuthId uid <- requireAuthId
(cid, course, registration) <- runDB $ do course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course
registration <- getBy (UniqueParticipant aid cid) ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm'
return (cid, course, entityVal <$> registration) formResult regResult $ \CourseRegisterForm{..} -> do
let isRegistered = isJust registration cTime <- liftIO getCurrentTime
((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course let
formResult regResult $ \(mbSfId,codeOk) -> if mkApplication
| isRegistered -> do | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
runDB $ deleteBy $ UniqueParticipant aid cid = void <$> do
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
| codeOk -> do appRes <- case appIds of
actTime <- liftIO getCurrentTime [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText Nothing Nothing Nothing Nothing cTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False (prevId:ps) -> do
when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk forM_ ps $ \appId -> do
| otherwise -> addMessageI Warning MsgCourseSecretWrong deleteApplicationFiles appId
-- addMessage Info $ toHtml $ show regResult -- For debugging only 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 redirect $ CourseR tid ssh csh CShowR

27
src/Handler/Course/Show.hs
View File

@ -12,7 +12,7 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.Function ((&)) import Utils.Lens
import qualified Data.Map as Map import qualified Data.Map as Map
@ -28,7 +28,7 @@ import qualified Data.Conduit.List as C
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate) <- 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)] [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -43,7 +43,6 @@ getCShowR tid ssh csh = do
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
return ( E.countRows :: E.SqlExpr (E.Value Int)) return ( E.countRows :: E.SqlExpr (E.Value Int))
return (course,school E.^. SchoolName, numParticipants, participant) 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 staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
@ -73,19 +72,25 @@ getCShowR tid ssh csh = do
return allocation return allocation
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate) 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 mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
(regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course regForm <- if
let regForm = wrapForm regWidget def | is _Just mbAid -> do
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
, formEncoding = regEnctype (regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm'
, formSubmit = FormNoSubmit return $ wrapForm' regButton regWidget def
} { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True , formEncoding = regEnctype
, formSubmit = FormSubmit
}
| otherwise
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
let let
tutorialDBTable = DBTable{..} tutorialDBTable = DBTable{..}

14
src/Handler/Course/User.hs
View File

@ -95,7 +95,7 @@ postCUserR tid ssh csh uCId = do
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf -> ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
let currentField :: Maybe (Maybe StudyFeaturesId) let currentField :: Maybe (Maybe StudyFeaturesId)
currentField = courseParticipantField . entityVal <$> mRegistration 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 let registrationFieldFrag :: Text
registrationFieldFrag = "registration-field" registrationFieldFrag = "registration-field"
@ -111,6 +111,7 @@ postCUserR tid ssh csh uCId = do
formResult regFieldRes $ \courseParticipantField' -> do formResult regFieldRes $ \courseParticipantField' -> do
runDB $ do runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ] update pId [ CourseParticipantField =. courseParticipantField' ]
audit $ TransactionCourseParticipantEdit cid uid
addMessageI Success MsgCourseStudyFeatureUpdated addMessageI Success MsgCourseStudyFeatureUpdated
redirect $ currentRoute :#: registrationFieldFrag redirect $ currentRoute :#: registrationFieldFrag
@ -140,17 +141,22 @@ postCUserR tid ssh csh uCId = do
-> invalidArgs ["User not registered"] -> invalidArgs ["User not registered"]
BtnCourseRegister -> do BtnCourseRegister -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let primaryField let field
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
= Just featId = Just featId
| otherwise | otherwise
= Nothing = 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 case pId of
Just _ -> do Just _ -> do
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute redirect currentRoute
Nothing -> invalidArgs ["User already registered"] Nothing -> invalidArgs ["User already registered"]
_other -> fail "Invalid @regButton@"
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

12
src/Handler/Course/Users.hs
View File

@ -251,10 +251,14 @@ postCUsersR tid ssh csh = do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
(CourseUserDeregister,selectedUsers) -> do (CourseUserDeregister,selectedUsers) -> do
nrDel <- runDB $ deleteWhereCount Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
[ CourseParticipantCourse ==. cid nrDel <- deleteWhereCount
, CourseParticipantUser <-. Set.toList selectedUsers [ CourseParticipantCourse ==. cid
] , CourseParticipantUser ==. uid
]
unless (nrDel == 0) $
audit $ TransactionCourseParticipantDeleted cid uid
return $ Sum nrDel
addMessageI Success $ MsgCourseUsersDeregistered nrDel addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]

1
src/Handler/Exam/AddUser.hs
View File

@ -149,6 +149,7 @@ postEAddUserR tid ssh csh examn = do
, courseParticipantAllocated = False , courseParticipantAllocated = False
, .. , ..
} }
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift $ lift examRegister lift $ lift examRegister
return $ case courseParticipantField of return $ case courseParticipantField of

5
src/Handler/Exam/RegistrationInvite.hs
View File

@ -90,12 +90,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
case (isRegistered, invDBExamRegistrationCourseRegister) of case (isRegistered, invDBExamRegistrationCourseRegister) of
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant (False, False) -> permissionDeniedI MsgUnauthorizedParticipant
(False, True ) -> do (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 return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $ \cpField -> whenIsJust mField $ \cpField -> do
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
act <* doAudit act <* doAudit

10
src/Handler/Exam/Users.hs
View File

@ -443,6 +443,7 @@ postEUsersR tid ssh csh examn = do
, courseParticipantField = examUserCsvActCourseField , courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = False , courseParticipantAllocated = False
} }
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration insert_ ExamRegistration
{ examRegistrationExam = eid { examRegistrationExam = eid
, examRegistrationUser = examUserCsvActUser , examRegistrationUser = examUserCsvActUser
@ -461,8 +462,10 @@ postEUsersR tid ssh csh examn = do
audit $ TransactionExamRegister eid examUserCsvActUser audit $ TransactionExamRegister eid examUserCsvActUser
ExamUserCsvAssignOccurrenceData{..} -> ExamUserCsvAssignOccurrenceData{..} ->
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
ExamUserCsvSetCourseFieldData{..} -> ExamUserCsvSetCourseFieldData{..} -> do
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> do Nothing -> do
deleteBy $ UniqueExamResult eid examUserCsvActUser deleteBy $ UniqueExamResult eid examUserCsvActUser
@ -481,6 +484,10 @@ postEUsersR tid ssh csh examn = do
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
audit $ TransactionExamDeregister eid examRegistrationUser audit $ TransactionExamDeregister eid examRegistrationUser
delete examUserCsvActRegistration delete examUserCsvActRegistration
result <- getBy $ UniqueExamResult eid examRegistrationUser
forM_ result $ \(Entity erId _) -> do
delete erId
audit $ TransactionExamResultDeleted eid examRegistrationUser
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
whenIsJust noteId $ \nid -> do whenIsJust noteId $ \nid -> do
@ -631,7 +638,6 @@ postEUsersR tid ssh csh examn = do
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
] ]
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid 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.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
E.limit 2 E.limit 2
return $ studyFeatures E.^. StudyFeaturesId return $ studyFeatures E.^. StudyFeaturesId

19
src/Handler/Submission.hs
View File

@ -126,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 :: 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 $ (,) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
<$> fileUploadForm <$> fileUploadForm (is _Just msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
<*> wFormToAForm submittorsForm <*> wFormToAForm submittorsForm
where 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' :: Markup -> Either UserEmail UserId -> Widget
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
miCell' csrf (Right uid) = do miCell' csrf (Right uid) = do

55
src/Handler/Utils/Form.hs
View File

@ -25,6 +25,7 @@ import Handler.Utils.Zip
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -334,25 +335,35 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName 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)? studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) -> [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 -- we need a join, so we cannot just use optionsPersistCryptoId
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do 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.^. StudyFeaturesField E.==. field E.^. StudyTermsId
E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) 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) return (feature E.^. StudyFeaturesId, degree, field)
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions mr) rawOptions
where where
isPrimaryActiveUserStudyFeature feature = case mbuid of isActiveUserStudyFeature feature = case mbuid of
Nothing -> E.val False Nothing -> E.false
(Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid Just uid -> feature E.^. StudyFeaturesUser E.==. E.val uid
E.&&. feature E.^. StudyFeaturesValid E.==. E.val True E.&&. feature E.^. StudyFeaturesValid
E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary 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 :: (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 procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do
@ -372,7 +383,7 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
nullOption = Option nullOption = Option
{ optionDisplay = emptyOpt { optionDisplay = emptyOpt
, optionInternalValue = Nothing , optionInternalValue = Nothing
, optionExternalValue = "NoPrimaryStudyField" , optionExternalValue = "NoStudyField"
} }
@ -384,7 +395,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
[ ( UploadModeNone, pure NoUpload) [ ( UploadModeNone, pure NoUpload)
, ( UploadModeAny , ( UploadModeAny
, UploadAny , 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) <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
) )
, ( UploadModeSpecific , ( UploadModeSpecific
@ -455,6 +466,8 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout") miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
where where
@ -650,6 +663,26 @@ zipFileField doUnpack permittedExtensions = Field{..}
acceptRestricted = isJust permittedExtensions acceptRestricted = isJust permittedExtensions
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
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` multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (Source Handler (Either FileId File)) -> Field Handler (Source Handler (Either FileId File))
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton

1
src/Model/Types/Security.hs
View File

@ -45,6 +45,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthCourseRegistered | AuthCourseRegistered
| AuthTutorialRegistered | AuthTutorialRegistered
| AuthExamRegistered | AuthExamRegistered
| AuthExamResult
| AuthParticipant | AuthParticipant
| AuthTime | AuthTime
| AuthAllocationTime | AuthAllocationTime

8
src/Utils/Icon.hs
View File

@ -55,6 +55,8 @@ data Icon
| IconSFTMarking -- for SheetFileType only | IconSFTMarking -- for SheetFileType only
| IconEmail | IconEmail
| IconRegisterTemplate | IconRegisterTemplate
| IconApplyTrue
| IconApplyFalse
deriving (Eq, Ord, Enum, Bounded, Show, Read) deriving (Eq, Ord, Enum, Bounded, Show, Read)
iconText :: Icon -> Text iconText :: Icon -> Text
@ -84,6 +86,8 @@ iconText = \case
IconSFTMarking -> "check-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only
IconEmail -> "envelope" IconEmail -> "envelope"
IconRegisterTemplate -> "file-alt" IconRegisterTemplate -> "file-alt"
IconApplyTrue -> "file-alt"
IconApplyFalse -> "trash"
instance Universe Icon instance Universe Icon
instance Finite Icon instance Finite Icon
@ -152,6 +156,10 @@ iconEnrol :: Bool -> Markup
iconEnrol True = icon IconEnrolTrue iconEnrol True = icon IconEnrolTrue
iconEnrol False = icon IconEnrolFalse iconEnrol False = icon IconEnrolFalse
iconApply :: Bool -> Markup
iconApply True = icon IconApplyTrue
iconApply False = icon IconApplyFalse
iconExamRegister :: Bool -> Markup iconExamRegister :: Bool -> Markup
iconExamRegister True = icon IconExamRegisterTrue iconExamRegister True = icon IconExamRegisterTrue
iconExamRegister False = icon IconExamRegisterFalse iconExamRegister False = icon IconExamRegisterFalse

7
templates/course.hamlet
View File

@ -104,6 +104,13 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
$if registrationOpen $if registrationOpen
$# regForm is defined through templates/widgets/registerForm $# regForm is defined through templates/widgets/registerForm
^{regForm} ^{regForm}
$if isJust mApplication && courseApplicationsRequired course
<p>
_{MsgCourseApplicationDeleteToEdit}
$else
$if isJust mRegAt
<p>
_{MsgCourseRegistrationDeleteToEdit}
$maybe date <- mRegAt $maybe date <- mRegAt
_{MsgRegisteredSince} #{date} _{MsgRegisteredSince} #{date}
<dt .deflist__dt> <dt .deflist__dt>

5
templates/course/login-to-register.hamlet Normal file
View File

@ -0,0 +1,5 @@
$newline never
$if courseApplicationsRequired course
_{MsgCourseLoginToApply}
$else
_{MsgCourseLoginToRegister}