feat(courses): rework couse registration
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
parent
a00698e99e
commit
79d4ae20ee
@ -7,6 +7,8 @@ BtnRegister: Anmelden
|
||||
BtnDeregister: Abmelden
|
||||
BtnCourseRegister: Zum Kurs anmelden
|
||||
BtnCourseDeregister: Vom Kurs abmelden
|
||||
BtnCourseApply: Zum Kurs bewerben
|
||||
BtnCourseRetractApplication: Bewerbung zum Kurs zurückziehen
|
||||
BtnExamRegister: Anmelden zur Prüfung
|
||||
BtnExamDeregister: Von der Prüfung abmelden
|
||||
BtnHijack: Sitzung übernehmen
|
||||
@ -89,13 +91,15 @@ CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
|
||||
CourseRegistration: Kursanmeldung
|
||||
CourseRegisterOk: Erfolgreich zum Kurs angemeldet
|
||||
CourseDeregisterOk: Erfolgreich vom Kurs abgemeldet
|
||||
CourseApplyOk: Erfolgreich zum Kurs beworben
|
||||
CourseRetractApplyOk: Bewerbung zum Kurs erfolgreich zurückgezogen
|
||||
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
|
||||
CourseStudyFeature: Assoziiertes Hauptfach
|
||||
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert
|
||||
CourseStudyFeatureNone: Kein assoziiertes Hauptfach
|
||||
CourseStudyFeature: Assoziiertes Studienfach
|
||||
CourseStudyFeatureTip: Dient ausschließlich der Information der Kursverwalter
|
||||
CourseStudyFeatureUpdated: Assoziiertes Studienfach geändert
|
||||
CourseStudyFeatureNone: Kein assoziiertes Studienfach
|
||||
CourseTutorial: Tutorium
|
||||
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecretWrong: Falsches Passwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
|
||||
@ -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
|
||||
CourseApplicationTemplate: Bewerbungsvorlagen
|
||||
CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
|
||||
CourseApplicationText: Text-Bewerbungen
|
||||
CourseApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
|
||||
CourseApplicationsText: Text-Bewerbungen
|
||||
CourseApplicationsTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
|
||||
CourseApplicationRatingsVisible: Feedback für Bewerbungen
|
||||
CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
|
||||
CourseApplicationRequired: Bewerbungsverfahren
|
||||
@ -166,6 +170,26 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
|
||||
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
|
||||
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
|
||||
|
||||
CourseApplicationText: Text-Bewerbung
|
||||
CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!
|
||||
CourseRegistrationText: Text zur Anmeldung
|
||||
CourseRegistrationFollowInstructions: Beachten Sie die Anweisungen zur Anmeldung!
|
||||
|
||||
CourseApplicationFile: Bewerbung
|
||||
CourseApplicationFiles: Bewerbungsdatei(en)
|
||||
CourseApplicationArchive: Zip-Archiv der Bewerbungsdatei(en)
|
||||
CourseRegistrationFile: Datei zur Anmeldung
|
||||
CourseRegistrationFiles: Datei(en) zur Anmeldung
|
||||
CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung
|
||||
CourseApplicationNoFiles: Keine Datei(en)
|
||||
|
||||
CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben.
|
||||
CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden.
|
||||
|
||||
CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in Uni2work anmelden
|
||||
CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
|
||||
|
||||
CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName}
|
||||
|
||||
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
|
||||
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
|
||||
@ -305,6 +329,7 @@ MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@Mat
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
||||
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
||||
UnauthorizedNot i@Text: (NICHT #{i})
|
||||
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
|
||||
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
|
||||
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
|
||||
@ -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.
|
||||
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
|
||||
UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
|
||||
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
|
||||
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
|
||||
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
|
||||
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
|
||||
@ -656,7 +683,7 @@ StudyFeatureAge: Fachsemester
|
||||
StudyFeatureDegree: Abschluss
|
||||
FieldPrimary: Hauptfach
|
||||
FieldSecondary: Nebenfach
|
||||
NoPrimaryStudyField: (kein Hauptfach registriert)
|
||||
NoStudyField: Kein Studienfach
|
||||
StudyFeatureType:
|
||||
StudyFeatureValid: Aktiv
|
||||
StudyFeatureUpdate: Abgeglichen
|
||||
@ -986,6 +1013,7 @@ AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind er
|
||||
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
|
||||
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
|
||||
AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer
|
||||
AuthTagExamResult: Nutzer hat Prüfungsergebnisse
|
||||
AuthTagParticipant: Nutzer ist mit Kurs assoziiert
|
||||
AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
|
||||
AuthTagCapacity: Kapazität ist ausreichend
|
||||
@ -1163,13 +1191,13 @@ HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
|
||||
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
|
||||
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden ohne assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Studienfach" "wurden ohne assoziierte Studienfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
|
||||
|
||||
ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Prüfung angemeldet
|
||||
ExamRegistrationNotRegisteredWithoutCourse n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} nicht zur Prüfung angemeldet, da #{pluralDE n "er" "sie"} nicht zum Kurs angemeldet #{pluralDE n "ist" "sind"}
|
||||
ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Prüfung, als auch #{pluralDE n "ohne assoziiertes Hauptfach" "ohne assoziierte Hauptfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Prüfung, als auch #{pluralDE n "ohne assoziiertes Studienfach" "ohne assoziierte Studienfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Prüfung angemeldet
|
||||
ExamRegistrationInviteDeadline: Einladung nur gültig bis
|
||||
ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
|
||||
@ -1334,9 +1362,9 @@ CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
|
||||
CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
|
||||
CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
|
||||
CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers
|
||||
CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
|
||||
CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt
|
||||
CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Hauptfach
|
||||
CsvColumnExamUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
|
||||
CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt
|
||||
CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach
|
||||
CsvColumnExamUserOccurrence: Prüfungstermin/-Raum, zu dem der Teilnehmer angemeldet ist
|
||||
CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb erreicht hat
|
||||
CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können
|
||||
@ -1356,14 +1384,14 @@ ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden
|
||||
ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
|
||||
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
|
||||
ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
|
||||
ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern
|
||||
ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
|
||||
ExamUserCsvSetResult: Ergebnis eintragen
|
||||
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
|
||||
|
||||
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
|
||||
|
||||
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
||||
|
||||
TableHeadingFilter: Filter
|
||||
|
||||
@ -74,12 +74,14 @@ CourseUserNoteEdit -- who edited a participants course note when
|
||||
CourseApplication
|
||||
course CourseId
|
||||
user UserId
|
||||
text Text Maybe -- free text entered by user
|
||||
ratingPoints ExamGrade Maybe
|
||||
ratingComment Text Maybe
|
||||
allocation AllocationId Maybe
|
||||
allocationPriority Natural Maybe
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
text Text Maybe -- free text entered by user
|
||||
ratingPoints ExamGrade Maybe
|
||||
ratingComment Text Maybe
|
||||
allocation AllocationId Maybe
|
||||
allocationPriority Natural Maybe
|
||||
time UTCTime default=now()
|
||||
CourseApplicationFile
|
||||
application CourseApplication
|
||||
application CourseApplicationId
|
||||
file FileId
|
||||
UniqueApplicationFile application file
|
||||
8
routes
8
routes
@ -86,8 +86,8 @@
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR GET POST !timeANDcapacityANDallocation-time !lecturerANDallocation-time
|
||||
/register-template CRegisterTemplateR GET
|
||||
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time
|
||||
/register-template CRegisterTemplateR GET !free
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDemptyANDallocation-time
|
||||
@ -153,7 +153,9 @@
|
||||
/users EUsersR GET POST
|
||||
/users/new EAddUserR GET POST
|
||||
/users/invite EInviteR GET POST
|
||||
/register ERegisterR POST !timeANDcourse-registered !timeANDexam-registered
|
||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
/files CAFilesR GET !self !lecturerANDtime
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
|
||||
@ -30,6 +30,24 @@ data Transaction
|
||||
{ transactionExam :: ExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionCourseParticipantEdit
|
||||
{ transactionCourse :: CourseId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionCourseParticipantDeleted
|
||||
{ transactionCourse :: CourseId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionCourseApplicationEdit
|
||||
{ transactionCourse :: CourseId
|
||||
, transactionUser :: UserId
|
||||
, transactionCourseApplication :: CourseApplicationId
|
||||
}
|
||||
| TransactionCourseApplicationDeleted
|
||||
{ transactionCourse :: CourseId
|
||||
, transactionUser :: UserId
|
||||
, transactionCourseApplication :: CourseApplicationId
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
|
||||
@ -29,6 +29,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
|
||||
import Data.Aeson.Encoding (text)
|
||||
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
|
||||
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
|
||||
@ -46,19 +48,23 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''ExamOccurrenceId
|
||||
, ''ExamPartId
|
||||
, ''AllocationId
|
||||
, ''CourseApplicationId
|
||||
]
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (CI FilePath)) where
|
||||
fromPathPiece (Text.unpack -> piece) = do
|
||||
piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
|
||||
return . CryptoID . CI.mk $ map CI.original piece'
|
||||
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where
|
||||
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "Submission" (CI FilePath)) where
|
||||
toJSON = String . toPathPiece
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where
|
||||
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "Submission" (CI FilePath)) where
|
||||
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where
|
||||
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "Submission" (CI FilePath)) where
|
||||
parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
|
||||
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
||||
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
|
||||
toMarkup = toMarkup . toPathPiece
|
||||
|
||||
@ -10,5 +10,11 @@ import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
|
||||
toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
|
||||
|
||||
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
|
||||
toMarkup = toMarkup . CID.ciphertext
|
||||
toMarkup = toMarkup . CID.ciphertext
|
||||
|
||||
@ -54,6 +54,7 @@ import Data.Conduit (($$))
|
||||
import Data.Conduit.List (sourceList)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), ExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
@ -179,6 +180,10 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
|
||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
||||
|
||||
pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
|
||||
pattern CApplicationR tid ssh csh appId ptn
|
||||
= CourseR tid ssh csh (CourseApplicationR appId ptn)
|
||||
|
||||
|
||||
pluralDE :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
@ -519,6 +524,11 @@ andAR _ _ reason@(Unauthorized _) = reason
|
||||
andAR _ Authorized other = other
|
||||
andAR _ AuthenticationRequired _ = AuthenticationRequired
|
||||
|
||||
notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
|
||||
notAR _ _ (Unauthorized _) = Authorized
|
||||
notAR _ _ AuthenticationRequired = AuthenticationRequired
|
||||
notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg
|
||||
|
||||
trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
|
||||
trueAR = const Authorized
|
||||
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
||||
@ -581,14 +591,13 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
@ -623,14 +632,13 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
|
||||
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
-- lecturer for any school will do
|
||||
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
@ -689,6 +697,22 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||
|
||||
case allocation of
|
||||
Nothing -> return ()
|
||||
Just Allocation{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
||||
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
||||
|
||||
return Authorized
|
||||
|
||||
|
||||
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
||||
@ -782,9 +806,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
| not registered
|
||||
, maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
|
||||
, maybe True (now <=) courseRegisterTo -> return Authorized
|
||||
(Just (Entity _ Course{courseDeregisterUntil}))
|
||||
(Just (Entity cid Course{courseDeregisterUntil}))
|
||||
| registered
|
||||
, maybe True (now <=) courseDeregisterUntil -> return Authorized
|
||||
-> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
|
||||
guard $ maybe True (now <=) courseDeregisterUntil
|
||||
forM_ mAuthId $ \uid -> do
|
||||
exams <- lift . E.select . E.from $ \exam -> do
|
||||
E.where_ . E.exists . E.from $ \examRegistration ->
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
return $ exam E.^. ExamDeregisterUntil
|
||||
forM_ exams $ \(E.Value deregUntil) ->
|
||||
guard $ NTop (Just now) >= NTop deregUntil
|
||||
return Authorized
|
||||
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
||||
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
@ -845,20 +880,19 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
|
||||
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
||||
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
||||
@ -866,26 +900,24 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. tutorial E.^. TutorialName E.==. E.val tutn
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthTutorialRegistered r
|
||||
tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
||||
@ -893,20 +925,47 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthExamRegistered r
|
||||
tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
|
||||
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` (examResult `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do
|
||||
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId
|
||||
E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
|
||||
E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId))
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
||||
guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` (examResult `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do
|
||||
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId
|
||||
E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
|
||||
E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId))
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthExamRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
@ -1005,10 +1064,9 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||
assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return E.countRows
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
|
||||
@ -1045,19 +1103,24 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
|
||||
guard submissionModeCorrector
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
|
||||
tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
|
||||
tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
|
||||
referencedUser <- case route of
|
||||
AdminUserR cID -> return cID
|
||||
AdminUserDeleteR cID -> return cID
|
||||
AdminHijackUserR cID -> return cID
|
||||
UserNotificationR cID -> return cID
|
||||
UserPasswordR cID -> return cID
|
||||
CourseR _ _ _ (CUserR cID) -> return cID
|
||||
AdminUserR cID -> decrypt cID
|
||||
AdminUserDeleteR cID -> decrypt cID
|
||||
AdminHijackUserR cID -> decrypt cID
|
||||
UserNotificationR cID -> decrypt cID
|
||||
UserPasswordR cID -> decrypt cID
|
||||
CourseR _ _ _ (CUserR cID) -> decrypt cID
|
||||
CApplicationR _ _ _ cID _ -> do
|
||||
appId <- decrypt cID
|
||||
application <- $cachedHereBinary appId . lift $ get appId
|
||||
case application of
|
||||
Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
|
||||
Just CourseApplication{..} -> return courseApplicationUser
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
||||
referencedUser' <- decrypt referencedUser
|
||||
case mAuthId of
|
||||
Just uid
|
||||
| uid == referencedUser' -> return Authorized
|
||||
| uid == referencedUser -> return Authorized
|
||||
Nothing -> return AuthenticationRequired
|
||||
_other -> unauthorizedI MsgUnauthorizedSelf
|
||||
tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
|
||||
@ -1160,10 +1223,7 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
|
||||
|
||||
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthLiteral PLVariable{..} = evalAuthTag plVar
|
||||
evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
|
||||
Unauthorized _ -> return Authorized
|
||||
AuthenticationRequired -> return AuthenticationRequired
|
||||
Authorized -> unauthorizedI plVar
|
||||
evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar
|
||||
|
||||
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
@ -2732,6 +2792,7 @@ routeNormalizers =
|
||||
, ncCourse
|
||||
, ncSheet
|
||||
, verifySubmission
|
||||
, verifyCourseApplication
|
||||
]
|
||||
where
|
||||
normalizeRender route = route <$ do
|
||||
@ -2778,6 +2839,14 @@ routeNormalizers =
|
||||
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseApplication = maybeOrig $ \route -> do
|
||||
CApplicationR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
|
||||
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
|
||||
|
||||
-- How to run database actions.
|
||||
|
||||
@ -15,6 +15,7 @@ import Handler.Course.Register as Handler.Course
|
||||
import Handler.Course.Show as Handler.Course
|
||||
import Handler.Course.User as Handler.Course
|
||||
import Handler.Course.Users as Handler.Course
|
||||
import Handler.Course.Application as Handler.Course
|
||||
|
||||
|
||||
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
37
src/Handler/Course/Application.hs
Normal file
37
src/Handler/Course/Application.hs
Normal 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
|
||||
@ -246,7 +246,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
|
||||
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template))
|
||||
<*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationTextTip) (cfAppText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
|
||||
<*> uploadModeForm (cfAppFiles <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
|
||||
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
|
||||
|
||||
@ -82,10 +82,13 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationInsertHook _ _ CourseParticipant{..} _ act = do
|
||||
res <- act
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
return res
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
@ -165,6 +168,7 @@ postCAddUserR tid ssh csh = do
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
|
||||
@ -1,66 +1,155 @@
|
||||
module Handler.Course.Register
|
||||
( ButtonCourseRegister(..)
|
||||
, CourseRegisterForm(..)
|
||||
, courseRegisterForm
|
||||
, getCRegisterR, postCRegisterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Database.Persist.Sql (transactionUndo)
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
-- Dedicated CourseRegistrationButton
|
||||
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
|
||||
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonCourseRegister
|
||||
instance Finite ButtonCourseRegister
|
||||
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
|
||||
instance Button UniWorX ButtonCourseRegister where
|
||||
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
|
||||
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
|
||||
btnClasses BtnCourseApply = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger]
|
||||
|
||||
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
|
||||
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
|
||||
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
|
||||
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
|
||||
btnLabel BtnCourseApply = [whamlet|#{iconApply True} _{MsgBtnCourseApply}|]
|
||||
btnLabel BtnCourseRetractApplication = [whamlet|#{iconApply False} _{MsgBtnCourseRetractApplication}|]
|
||||
|
||||
|
||||
data CourseRegisterForm = CourseRegisterForm
|
||||
{ crfStudyFeatures :: Maybe StudyFeaturesId
|
||||
, crfApplicationText :: Maybe Text
|
||||
, crfApplicationFiles :: Maybe (Source Handler File)
|
||||
}
|
||||
|
||||
courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
|
||||
-- ^ `CourseRegisterForm` for current user
|
||||
courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
|
||||
muid <- maybeAuthId
|
||||
(registration, application) <- runDB $ do
|
||||
registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
|
||||
application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
||||
return (registration, application)
|
||||
let btn | courseApplicationsRequired
|
||||
, is _Just application
|
||||
= BtnCourseRetractApplication
|
||||
| is _Just registration
|
||||
= BtnCourseDeregister
|
||||
| courseApplicationsRequired
|
||||
= BtnCourseApply
|
||||
| otherwise
|
||||
= BtnCourseRegister
|
||||
isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
|
||||
return . (, btn) . wFormToAForm $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
secretRes <- if
|
||||
| Just secret <- courseRegisterSecret
|
||||
, not isRegistered
|
||||
-> let guardSecret (FormSuccess secret')
|
||||
| secret == secret' = return $ FormSuccess ()
|
||||
| otherwise = formFailure [MsgCourseSecretWrong]
|
||||
guardSecret FormMissing = return FormMissing
|
||||
guardSecret (FormFailure errs) = return $ FormFailure errs
|
||||
in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing
|
||||
| otherwise
|
||||
-> return $ FormSuccess ()
|
||||
|
||||
fieldRes <- if
|
||||
| is _Nothing muid
|
||||
-> return $ FormSuccess Nothing
|
||||
| is _Just muid
|
||||
, isRegistered
|
||||
, Just mFeature <- courseApplicationField . entityVal <$> application
|
||||
<|> courseParticipantField . entityVal <$> registration
|
||||
-> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature
|
||||
| otherwise
|
||||
-> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
|
||||
appTextRes <- let fs | courseApplicationsRequired
|
||||
, is _Just courseApplicationsInstructions
|
||||
= fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
|
||||
| courseApplicationsRequired
|
||||
= fslI MsgCourseApplicationText
|
||||
| is _Just courseApplicationsInstructions
|
||||
= fslI MsgCourseRegistrationText & setTooltip MsgCourseRegistrationFollowInstructions
|
||||
| otherwise
|
||||
= fslI MsgCourseRegistrationText
|
||||
textField' = convertField unTextarea Textarea textareaField
|
||||
in if
|
||||
| not courseApplicationsText
|
||||
-> return $ FormSuccess Nothing
|
||||
| is _Just muid
|
||||
, isRegistered
|
||||
-> wforced (convertField Just (fromMaybe Text.empty) textField') fs (application >>= courseApplicationText . entityVal)
|
||||
| otherwise
|
||||
-> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
|
||||
|
||||
hasFiles <- for application $ \(Entity appId _)
|
||||
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
|
||||
appCID <- for application $ encrypt . entityKey
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
if
|
||||
| isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles
|
||||
-> let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
fieldEnctype = mempty
|
||||
fieldView theId _ attrs _ _
|
||||
= [whamlet|
|
||||
$newline never
|
||||
$case appFilesInfo
|
||||
$of Just (True, appCID)
|
||||
<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.
|
||||
-- After log in, the user sees a "get request not supported" error.
|
||||
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -76,21 +165,85 @@ getCRegisterR tid ssh csh = do
|
||||
|
||||
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid ssh csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, course, registration) <- runDB $ do
|
||||
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
registration <- getBy (UniqueParticipant aid cid)
|
||||
return (cid, course, entityVal <$> registration)
|
||||
let isRegistered = isJust registration
|
||||
((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course
|
||||
formResult regResult $ \(mbSfId,codeOk) -> if
|
||||
| isRegistered -> do
|
||||
runDB $ deleteBy $ UniqueParticipant aid cid
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
| codeOk -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False
|
||||
when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
||||
-- addMessage Info $ toHtml $ show regResult -- For debugging only
|
||||
uid <- requireAuthId
|
||||
course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
(courseRegisterForm', courseRegisterButton) <- courseRegisterForm course
|
||||
((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm'
|
||||
formResult regResult $ \CourseRegisterForm{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
mkApplication
|
||||
| courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
|
||||
= void <$> do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
appRes <- case appIds of
|
||||
[] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText Nothing Nothing Nothing Nothing cTime
|
||||
(prevId:ps) -> do
|
||||
forM_ ps $ \appId -> do
|
||||
deleteApplicationFiles appId
|
||||
delete appId
|
||||
audit $ TransactionCourseApplicationDeleted cid uid appId
|
||||
|
||||
deleteApplicationFiles prevId
|
||||
update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]
|
||||
|
||||
return $ Just prevId
|
||||
|
||||
whenIsJust appRes $
|
||||
audit . TransactionCourseApplicationEdit cid uid
|
||||
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
|
||||
runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
|
||||
return appRes
|
||||
| otherwise
|
||||
= return $ Just ()
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False
|
||||
|
||||
deleteApplications = do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
forM_ appIds $ \appId -> do
|
||||
deleteApplicationFiles appId
|
||||
delete appId
|
||||
audit $ TransactionCourseApplicationDeleted cid uid appId
|
||||
|
||||
deleteApplicationFiles appId = do
|
||||
fs <- selectList [ CourseApplicationFileApplication ==. appId ] []
|
||||
deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ]
|
||||
case courseRegisterButton of
|
||||
BtnCourseRegister -> runDB $ do
|
||||
regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration
|
||||
case regOk of
|
||||
Nothing -> transactionUndo
|
||||
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
BtnCourseDeregister -> runDB $ do
|
||||
deleteApplications
|
||||
deleteBy $ UniqueParticipant uid cid
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
|
||||
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
return examRegistration
|
||||
forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
|
||||
delete erId
|
||||
audit $ TransactionExamDeregister examRegistrationExam uid
|
||||
|
||||
examResults <- E.select . E.from $ \(examResult `E.InnerJoin` exam) -> do
|
||||
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
return examResult
|
||||
forM_ examResults $ \(Entity erId ExamResult{..}) -> do
|
||||
delete erId
|
||||
audit $ TransactionExamResultDeleted examResultExam uid
|
||||
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
BtnCourseApply -> runDB $ do
|
||||
regOk <- mkApplication
|
||||
case regOk of
|
||||
Nothing -> transactionUndo
|
||||
Just _ -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk
|
||||
BtnCourseRetractApplication -> runDB $ do
|
||||
deleteApplications
|
||||
addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
@ -12,7 +12,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -28,7 +28,7 @@ import qualified Data.Conduit.List as C
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation,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)]
|
||||
<- lift . E.select . E.from $
|
||||
\((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
|
||||
return ( E.countRows :: E.SqlExpr (E.Value Int))
|
||||
return (course,school E.^. SchoolName, numParticipants, participant)
|
||||
defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
|
||||
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
|
||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
||||
@ -73,19 +72,25 @@ getCShowR tid ssh csh = do
|
||||
return allocation
|
||||
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
|
||||
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
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
||||
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
||||
(regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course
|
||||
let regForm = wrapForm regWidget def
|
||||
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
|
||||
, formEncoding = regEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||
(regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm'
|
||||
return $ wrapForm' regButton regWidget def
|
||||
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
|
||||
, formEncoding = regEnctype
|
||||
, formSubmit = FormSubmit
|
||||
}
|
||||
| otherwise
|
||||
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
|
||||
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
|
||||
|
||||
let
|
||||
tutorialDBTable = DBTable{..}
|
||||
|
||||
@ -95,7 +95,7 @@ postCUserR tid ssh csh uCId = do
|
||||
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
|
||||
let currentField :: Maybe (Maybe StudyFeaturesId)
|
||||
currentField = courseParticipantField . entityVal <$> mRegistration
|
||||
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
||||
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
||||
|
||||
let registrationFieldFrag :: Text
|
||||
registrationFieldFrag = "registration-field"
|
||||
@ -111,6 +111,7 @@ postCUserR tid ssh csh uCId = do
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
addMessageI Success MsgCourseStudyFeatureUpdated
|
||||
redirect $ currentRoute :#: registrationFieldFrag
|
||||
|
||||
@ -140,17 +141,22 @@ postCUserR tid ssh csh uCId = do
|
||||
-> invalidArgs ["User not registered"]
|
||||
BtnCourseRegister -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let primaryField
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
|
||||
let field
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField False
|
||||
pId <- runDB $ do
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field False
|
||||
when (is _Just pId) $
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
return pId
|
||||
case pId of
|
||||
Just _ -> do
|
||||
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
redirect currentRoute
|
||||
Nothing -> invalidArgs ["User already registered"]
|
||||
_other -> fail "Invalid @regButton@"
|
||||
|
||||
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
||||
|
||||
|
||||
@ -251,10 +251,14 @@ postCUsersR tid ssh csh = do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(CourseUserDeregister,selectedUsers) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ CourseParticipantCourse ==. cid
|
||||
, CourseParticipantUser <-. Set.toList selectedUsers
|
||||
]
|
||||
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
|
||||
nrDel <- deleteWhereCount
|
||||
[ CourseParticipantCourse ==. cid
|
||||
, CourseParticipantUser ==. uid
|
||||
]
|
||||
unless (nrDel == 0) $
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
return $ Sum nrDel
|
||||
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
|
||||
|
||||
@ -149,6 +149,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
lift $ lift examRegister
|
||||
|
||||
return $ case courseParticipantField of
|
||||
|
||||
@ -90,12 +90,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
case (isRegistered, invDBExamRegistrationCourseRegister) of
|
||||
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant
|
||||
(False, True ) -> do
|
||||
fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $ \cpField ->
|
||||
whenIsJust mField $ \cpField -> do
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
|
||||
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
|
||||
|
||||
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
|
||||
act <* doAudit
|
||||
|
||||
@ -443,6 +443,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = False
|
||||
}
|
||||
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
, examRegistrationUser = examUserCsvActUser
|
||||
@ -461,8 +462,10 @@ postEUsersR tid ssh csh examn = do
|
||||
audit $ TransactionExamRegister eid examUserCsvActUser
|
||||
ExamUserCsvAssignOccurrenceData{..} ->
|
||||
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
|
||||
ExamUserCsvSetCourseFieldData{..} ->
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
||||
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
|
||||
audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
|
||||
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
|
||||
Nothing -> do
|
||||
deleteBy $ UniqueExamResult eid examUserCsvActUser
|
||||
@ -481,6 +484,10 @@ postEUsersR tid ssh csh examn = do
|
||||
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
|
||||
audit $ TransactionExamDeregister eid examRegistrationUser
|
||||
delete examUserCsvActRegistration
|
||||
result <- getBy $ UniqueExamResult eid examRegistrationUser
|
||||
forM_ result $ \(Entity erId _) -> do
|
||||
delete erId
|
||||
audit $ TransactionExamResultDeleted eid examRegistrationUser
|
||||
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
|
||||
noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
|
||||
whenIsJust noteId $ \nid -> do
|
||||
@ -631,7 +638,6 @@ postEUsersR tid ssh csh examn = do
|
||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
|
||||
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
||||
E.limit 2
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
|
||||
@ -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 cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
|
||||
<$> fileUploadForm
|
||||
<$> fileUploadForm (is _Just msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
|
||||
<*> wFormToAForm submittorsForm
|
||||
where
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload
|
||||
-> pure Nothing
|
||||
UploadAny{..}
|
||||
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
UploadSpecific{..}
|
||||
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
||||
|
||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
|
||||
specificFileForm spec@UploadSpecificFile{..}
|
||||
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
|
||||
|
||||
mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
|
||||
mergeFileSources (catMaybes -> sources) = case sources of
|
||||
[] -> Nothing
|
||||
fs -> Just $ sequence_ fs
|
||||
|
||||
miCell' :: Markup -> Either UserEmail UserId -> Widget
|
||||
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
|
||||
miCell' csrf (Right uid) = do
|
||||
|
||||
@ -25,6 +25,7 @@ import Handler.Utils.Zip
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
@ -334,25 +335,35 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
||||
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
||||
|
||||
-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
|
||||
|
||||
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
|
||||
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
||||
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
||||
studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
|
||||
{-# DEPRECATED studyFeaturesPrimaryFieldFor "Use studyFeaturesFieldFor" #-}
|
||||
studyFeaturesPrimaryFieldFor = studyFeaturesFieldFor . Just $ Set.singleton FieldPrimary
|
||||
|
||||
-- | Select one of the user's active study features, or from a given list of StudyFeatures (regardless of user)
|
||||
studyFeaturesFieldFor :: Maybe (Set StudyFieldType) -- ^ Optionally restrict fields to only given types
|
||||
-> Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
||||
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
||||
studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
|
||||
-- we need a join, so we cannot just use optionsPersistCryptoId
|
||||
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
|
||||
E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId
|
||||
E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
|
||||
E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
|
||||
E.||. isPrimaryActiveUserStudyFeature feature
|
||||
E.||. (isActiveUserStudyFeature feature E.&&. isCorrectType feature)
|
||||
return (feature E.^. StudyFeaturesId, degree, field)
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions
|
||||
mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions mr) rawOptions
|
||||
where
|
||||
isPrimaryActiveUserStudyFeature feature = case mbuid of
|
||||
Nothing -> E.val False
|
||||
(Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
|
||||
E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary
|
||||
isActiveUserStudyFeature feature = case mbuid of
|
||||
Nothing -> E.false
|
||||
Just uid -> feature E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.&&. feature E.^. StudyFeaturesValid
|
||||
isCorrectType feature = case mRestr of
|
||||
Nothing -> E.true
|
||||
Just restr -> feature E.^. StudyFeaturesType `E.in_` E.valList (Set.toList restr)
|
||||
|
||||
procOptions :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
|
||||
procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do
|
||||
@ -372,7 +383,7 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
|
||||
nullOption = Option
|
||||
{ optionDisplay = emptyOpt
|
||||
, optionInternalValue = Nothing
|
||||
, optionExternalValue = "NoPrimaryStudyField"
|
||||
, optionExternalValue = "NoStudyField"
|
||||
}
|
||||
|
||||
|
||||
@ -384,7 +395,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
|
||||
[ ( UploadModeNone, pure NoUpload)
|
||||
, ( UploadModeAny
|
||||
, UploadAny
|
||||
<$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
|
||||
<$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _unpackZips))
|
||||
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
)
|
||||
, ( UploadModeSpecific
|
||||
@ -455,6 +466,8 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
|
||||
|
||||
|
||||
|
||||
|
||||
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
|
||||
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
|
||||
where
|
||||
@ -650,6 +663,26 @@ zipFileField doUnpack permittedExtensions = Field{..}
|
||||
acceptRestricted = isJust 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`
|
||||
-> Field Handler (Source Handler (Either FileId File))
|
||||
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
|
||||
|
||||
@ -45,6 +45,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
| AuthExamRegistered
|
||||
| AuthExamResult
|
||||
| AuthParticipant
|
||||
| AuthTime
|
||||
| AuthAllocationTime
|
||||
|
||||
@ -55,6 +55,8 @@ data Icon
|
||||
| IconSFTMarking -- for SheetFileType only
|
||||
| IconEmail
|
||||
| IconRegisterTemplate
|
||||
| IconApplyTrue
|
||||
| IconApplyFalse
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
iconText :: Icon -> Text
|
||||
@ -84,6 +86,8 @@ iconText = \case
|
||||
IconSFTMarking -> "check-circle" -- for SheetFileType only
|
||||
IconEmail -> "envelope"
|
||||
IconRegisterTemplate -> "file-alt"
|
||||
IconApplyTrue -> "file-alt"
|
||||
IconApplyFalse -> "trash"
|
||||
|
||||
instance Universe Icon
|
||||
instance Finite Icon
|
||||
@ -152,6 +156,10 @@ iconEnrol :: Bool -> Markup
|
||||
iconEnrol True = icon IconEnrolTrue
|
||||
iconEnrol False = icon IconEnrolFalse
|
||||
|
||||
iconApply :: Bool -> Markup
|
||||
iconApply True = icon IconApplyTrue
|
||||
iconApply False = icon IconApplyFalse
|
||||
|
||||
iconExamRegister :: Bool -> Markup
|
||||
iconExamRegister True = icon IconExamRegisterTrue
|
||||
iconExamRegister False = icon IconExamRegisterFalse
|
||||
|
||||
@ -104,6 +104,13 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
$if registrationOpen
|
||||
$# regForm is defined through templates/widgets/registerForm
|
||||
^{regForm}
|
||||
$if isJust mApplication && courseApplicationsRequired course
|
||||
<p>
|
||||
_{MsgCourseApplicationDeleteToEdit}
|
||||
$else
|
||||
$if isJust mRegAt
|
||||
<p>
|
||||
_{MsgCourseRegistrationDeleteToEdit}
|
||||
$maybe date <- mRegAt
|
||||
_{MsgRegisteredSince} #{date}
|
||||
<dt .deflist__dt>
|
||||
|
||||
5
templates/course/login-to-register.hamlet
Normal file
5
templates/course/login-to-register.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseLoginToApply}
|
||||
$else
|
||||
_{MsgCourseLoginToRegister}
|
||||
Loading…
Reference in New Issue
Block a user