diff --git a/CHANGELOG.md b/CHANGELOG.md index 8755e90b0..dadeb24b1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,19 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [5.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.2...v5.1.0) (2019-08-19) + + +### Features + +* **allocations:** add application form(s) ([ef625cd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ef625cd)) +* **allocations:** add registration form ([c5b18fc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c5b18fc)) +* **allocations:** implement application interface ([4dcc82a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4dcc82a)) +* **allocations:** link allocations from home ([c759364](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c759364)) +* **allocations:** set up routes ([c2df01c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2df01c)) + + + ### [5.0.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.1...v5.0.2) (2019-08-13) diff --git a/frontend/src/services/util-registry/util-registry.js b/frontend/src/services/util-registry/util-registry.js index d96d7a4b3..c6e866adf 100644 --- a/frontend/src/services/util-registry/util-registry.js +++ b/frontend/src/services/util-registry/util-registry.js @@ -1,4 +1,4 @@ -const DEBUG_MODE = /localhost/.test(window.location.href) && 0; +const DEBUG_MODE = /localhost/.test(window.location.href) ? 2 : 0; export class UtilRegistry { diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 5d24ee9c2..9c080e04f 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/frontend/src/utils/form/interactive-fieldset.js @@ -16,6 +16,7 @@ export class InteractiveFieldset { conditionalValue; target; childInputs; + negated; constructor(element) { if (!element) { @@ -43,11 +44,13 @@ export class InteractiveFieldset { } // param conditionalValue - if (!this._element.dataset.conditionalValue && !this._isCheckbox()) { + if (!('conditionalValue' in this._element.dataset) && !this._isCheckbox()) { throw new Error('Interactive Fieldset needs a conditional value!'); } this.conditionalValue = this._element.dataset.conditionalValue; + this.negated = 'conditionalNegated' in this._element.dataset; + this.target = this._element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR); if (!this.target || this._element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) { this.target = this._element; @@ -88,11 +91,19 @@ export class InteractiveFieldset { } _matchesConditionalValue() { + var matches; + if (this._isCheckbox()) { - return this.conditionalInput.checked === true; + matches = this.conditionalInput.checked === true; + } else { + matches = this.conditionalInput.value === this.conditionalValue; } - return this.conditionalInput.value === this.conditionalValue; + if (this.negated) { + return !matches; + } else { + return matches; + } } _isCheckbox() { diff --git a/frontend/src/utils/form/interactive-fieldset.md b/frontend/src/utils/form/interactive-fieldset.md index 323c26e55..f98fdb0f4 100644 --- a/frontend/src/utils/form/interactive-fieldset.md +++ b/frontend/src/utils/form/interactive-fieldset.md @@ -8,6 +8,8 @@ Shows/hides inputs based on value of particular input Selector for the input that this fieldset watches for changes - `data-conditional-value: string`\ The value the conditional input needs to be set to for this fieldset to be shown. Can be omitted if conditionalInput is a checkbox +- `data-conditional-negated`\ + If present, negates the match on `data-conditional-value` ## Example usage: ### example with text input diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index 643902d08..ae81b82d4 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -9,11 +9,9 @@ grid-gap: 5px; justify-content: flex-start; align-items: flex-start; - padding: 4px 0; - border-left: 2px solid transparent; - + .form-group { - margin-top: 7px; + + .form-group, + .form-section-legend, + .form-section-notification { + margin-top: 11px; } + .form-section-title { diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 547092e46..c4862d134 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -127,7 +127,7 @@ CourseShorthand: Kürzel CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein CourseSemester: Semester CourseSchool: Institut -CourseSchoolShort: Fach +CourseSchoolShort: Institut CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich @@ -170,6 +170,18 @@ CourseApplicationInstructionsRegistration: Anweisungen zur Anmeldung CourseApplicationTemplateApplication: Bewerbungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen +CourseApplication: Bewerbung + +CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben +CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden +CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben +CourseApplicationEdited csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich angepasst +CourseApplicationNotEdited csh@CourseShorthand: Bewerbung zu #{csh} hat sich nicht verändert +CourseApplicationRated: Bewertung erfolgreich angepasst +CourseApplicationRatingDeleted: Bewertung erfolgreich entfernt +CourseApplicationDeleted csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich zurückgezogen + +CourseApplicationTitle displayName@Text csh@CourseShorthand: Bewerbung für #{csh}: #{displayName} CourseApplicationText: Text-Bewerbung CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! @@ -183,6 +195,8 @@ CourseRegistrationFile: Datei zur Anmeldung CourseRegistrationFiles: Datei(en) zur Anmeldung CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung CourseApplicationNoFiles: Keine Datei(en) +CourseApplicationFilesNeedReupload: Bewerbungsdateien müssen neu hochgeladen werden, wann immer die Bewerbung angepasst wird +CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgeladen werden, wann immer die Anmeldung angepasst wird 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. @@ -332,7 +346,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}) +UnauthorizedNot r@Text: (NICHT #{r}) UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. @@ -345,13 +359,16 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. +UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. 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. +UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung 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. +UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. @@ -369,7 +386,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. -UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} +UnsupportedAuthPredicate authTagT@Text shownRoute@Text: „#{authTagT}“ wurde auf eine Route angewandt, die dies nicht unterstützt: „#{shownRoute}“ UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. @@ -434,6 +451,7 @@ TokensLastReset: Tokens zuletzt invalidiert TokensResetSuccess: Authorisierungs-Tokens invalidiert HomeOpenCourses: Kurse mit offener Registrierung +HomeOpenAllocations: Offene Zentralanmeldungen HomeUpcomingSheets: Anstehende Übungsblätter HomeUpcomingExams: Bevorstehende Prüfungen @@ -1014,8 +1032,10 @@ AuthTagLecturer: Nutzer ist Dozent AuthTagCorrector: Nutzer ist Korrektor AuthTagTutor: Nutzer ist Tutor AuthTagTime: Zeitliche Einschränkungen sind erfüllt +AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt AuthTagCourseRegistered: Nutzer ist Kursteilnehmer +AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer AuthTagExamResult: Nutzer hat Prüfungsergebnisse @@ -1445,3 +1465,46 @@ MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen + +AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation} +AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash} +AllocationDescription: Beschreibung +AllocationStaffRegisterFrom: Eintragung der Kurse ab +AllocationStaffRegister: Eintragung der Kurse +AllocationRegisterFrom: Bewerbung ab +AllocationRegister: Bewerbung +AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab +AllocationStaffAllocation: Bewertung der Bewerbungen +AllocationNoApplication: Keine Bewerbung +AllocationPriority: Priorität +AllocationPriorityTip: Kurse, denen Sie eine höhere Priorität zuteilen, werden bei der Platzvergabe präferiert. +AllocationPriorityRelative: Die absoluten Prioritäts-Werte sind bedeutungslos, es wird nur jeweils betrachtet ob ein Kurs höhere Priorität hat als ein anderer. +AllocationTotalCoursesNegative: Gewünschte Kursanzahl muss größer null sein +AllocationTotalCourses: Gewünschte Anzahl von Kursen +AllocationTotalCoursesTip: Sie werden im Laufe dieser Zentralanmeldung maximal so vielen Kursen zugeteilt, wie Sie hier angeben +AllocationRegistered: Teilnahme an der Zentralanmeldung erfolgreich registriert +AllocationRegistrationEdited: Einstellungen zur Teilnahme an der Zentralanmeldung erfolgreich angepasst +BtnAllocationRegister: Teilnahme registrieren +BtnAllocationRegistrationEdit: Teilnahme anpassen +AllocationParticipation: Teilnahme an der Zentralanmeldung +AllocationParticipationLoginFirst: Um an der Zentralanmeldung teilzunehmen, loggen Sie sich bitte zunächst ein. +AllocationCourses: Kurse +AllocationData: Organisatorisches +AllocationCoursePriority i@Natural: #{i}. Wahl +AllocationCourseNoApplication: Keine Bewerbung +BtnAllocationApply: Bewerben +BtnAllocationApplicationEdit: Bewerbung ersetzen +BtnAllocationApplicationRetract: Bewerbung zurückziehen +BtnAllocationApplicationRate: Bewerbung bewerten +ApplicationPriority: Priorität +ApplicationVeto: Veto +ApplicationVetoTip: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt +ApplicationRatingPoints: Bewertung +ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zugeteilt +ApplicationRatingComment: Kommentar +ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers +ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter + +AllocationSchoolShort: Institut +Allocation: Zentralanmeldung +AllocationRegisterTo: Anmeldungen bis \ No newline at end of file diff --git a/models/allocations b/models/allocations index f7522696f..0fac2cfee 100644 --- a/models/allocations +++ b/models/allocations @@ -1,12 +1,10 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students - name (CI Text) - shorthand (CI Text) -- practical shorthand + name AllocationName + shorthand AllocationShorthand -- practical shorthand term TermId school SchoolId -- school that manages this central allocation, not necessarily school of courses description Html Maybe -- description for prospective students staffDescription Html Maybe -- description seen by prospective lecturers only - linkExternal Text Maybe -- arbitrary user-defined url for external course page - capacity Int Maybe -- number of allowed enrolements, if restricte staffRegisterFrom UTCTime Maybe -- lectureres may register courses staffRegisterTo UTCTime Maybe -- course registration stops -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards @@ -17,7 +15,6 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis registerFrom UTCTime Maybe -- student applications allowed from a given day onwwards or prohibited registerTo UTCTime Maybe -- student applications may be prohibited from a given date onwards -- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister - registerSecret Text Maybe -- student application maybe protected by a simple common passphrase -- overrides registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited registerByStaffTo UTCTime Maybe @@ -26,6 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis -- overrideVisible not needed, since courses are always visible TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester + deriving Show AllocationCourse allocation AllocationId @@ -41,7 +39,6 @@ AllocationUser AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId - allocation AllocationId Maybe course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) diff --git a/models/courses b/models/courses index bcbdf4979..dd1099e55 100644 --- a/models/courses +++ b/models/courses @@ -76,11 +76,13 @@ CourseApplication user UserId field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades text Text Maybe -- free text entered by user + ratingVeto Bool default=false ratingPoints ExamGrade Maybe ratingComment Text Maybe allocation AllocationId Maybe allocationPriority Natural Maybe time UTCTime default=now() + ratingTime UTCTime Maybe CourseApplicationFile application CourseApplicationId file FileId diff --git a/package-lock.json b/package-lock.json index 9242d03a1..183967506 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.0.2", + "version": "5.1.0", "lockfileVersion": 1, "requires": true, "dependencies": { @@ -6510,8 +6510,7 @@ "ansi-regex": { "version": "2.1.1", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "aproba": { "version": "1.2.0", @@ -6554,8 +6553,7 @@ "code-point-at": { "version": "1.1.0", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "concat-map": { "version": "0.0.1", @@ -6566,8 +6564,7 @@ "console-control-strings": { "version": "1.1.0", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "core-util-is": { "version": "1.0.2", @@ -6684,8 +6681,7 @@ "inherits": { "version": "2.0.3", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "ini": { "version": "1.3.5", @@ -6697,7 +6693,6 @@ "version": "1.0.0", "bundled": true, "dev": true, - "optional": true, "requires": { "number-is-nan": "^1.0.0" } @@ -6727,7 +6722,6 @@ "version": "2.3.5", "bundled": true, "dev": true, - "optional": true, "requires": { "safe-buffer": "^5.1.2", "yallist": "^3.0.0" @@ -6746,7 +6740,6 @@ "version": "0.5.1", "bundled": true, "dev": true, - "optional": true, "requires": { "minimist": "0.0.8" } @@ -6827,8 +6820,7 @@ "number-is-nan": { "version": "1.0.1", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "object-assign": { "version": "4.1.1", @@ -6840,7 +6832,6 @@ "version": "1.4.0", "bundled": true, "dev": true, - "optional": true, "requires": { "wrappy": "1" } @@ -6926,8 +6917,7 @@ "safe-buffer": { "version": "5.1.2", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "safer-buffer": { "version": "2.1.2", @@ -6963,7 +6953,6 @@ "version": "1.0.2", "bundled": true, "dev": true, - "optional": true, "requires": { "code-point-at": "^1.0.0", "is-fullwidth-code-point": "^1.0.0", @@ -6983,7 +6972,6 @@ "version": "3.0.1", "bundled": true, "dev": true, - "optional": true, "requires": { "ansi-regex": "^2.0.0" } @@ -7027,14 +7015,12 @@ "wrappy": { "version": "1.0.2", "bundled": true, - "dev": true, - "optional": true + "dev": true }, "yallist": { "version": "3.0.3", "bundled": true, - "dev": true, - "optional": true + "dev": true } } }, diff --git a/package.json b/package.json index 77975c256..2994bd8f8 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.0.2", + "version": "5.1.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 53e8c4d5e..1d62936ac 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 5.0.2 +version: 5.1.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage diff --git a/routes b/routes index 54f0fc5c5..cec9b58f7 100644 --- a/routes +++ b/routes @@ -80,6 +80,12 @@ /school SchoolListR GET !development /school/#SchoolId SchoolShowR GET !development +/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: + / AShowR GET !free + /register ARegisterR POST !time + /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered + /application/#CryptoFileNameCourseApplication AApplicationR GET POST !timeANDself !lecturerANDstaff-time !selfANDread + -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free @@ -154,6 +160,7 @@ /users/new EAddUserR GET POST /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result + /apps CApplicationsR GET POST /apps/#CryptoFileNameCourseApplication CourseApplicationR: /files CAFilesR GET !self !lecturerANDtime diff --git a/src/Application.hs b/src/Application.hs index 7291fda1c..597a316fd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -112,6 +112,7 @@ import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health import Handler.Exam +import Handler.Allocation -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs new file mode 100644 index 000000000..66228a69e --- /dev/null +++ b/src/Crypto/Hash/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Crypto.Hash.Instances + () where + +import ClassyPrelude + +import Crypto.Hash + +import Database.Persist +import Database.Persist.Sql + +import Data.ByteArray (convert) + + +instance HashAlgorithm hash => PersistField (Digest hash) where + toPersistValue = PersistByteString . convert + fromPersistValue (PersistByteString bs) = maybe (Left "Could not convert Digest from ByteString") Right $ digestFromByteString bs + fromPersistValue _ = Left "Digest values must be converted from PersistByteString" + +instance HashAlgorithm hash => PersistFieldSql (Digest hash) where + sqlType _ = SqlBlob diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 915ad5de0..9263ca308 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId , ''ExamPartId , ''AllocationId , ''CourseApplicationId + , ''CourseId ] -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index 3e842dd6a..bc66cb874 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -13,8 +13,24 @@ 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 +import Web.PathPieces +import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..)) + instance ToMarkup s => ToMarkup (CID.CryptoID c s) where toMarkup = toMarkup . CID.ciphertext + +instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where + toMarkup = toMarkup . CI.foldedCase . CID.ciphertext + +instance {-# OVERLAPS #-} ToJSON s => ToJSON (CID.CryptoID c (CI s)) where + toJSON = toJSON . CI.foldedCase . CID.ciphertext + +instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (CI s)) where + toJSONKey = case toJSONKey of + ToJSONKeyText toT toE -> ToJSONKeyText (toT . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext) + ToJSONKeyValue toV toE -> ToJSONKeyValue (toV . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext) + +instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where + toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext + fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece diff --git a/src/Data/Void/Instances.hs b/src/Data/Void/Instances.hs new file mode 100644 index 000000000..a59e0cd39 --- /dev/null +++ b/src/Data/Void/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Void.Instances + ( + ) where + +import ClassyPrelude.Yesod +import Data.Void + +instance ToContent Void where + toContent = absurd +instance ToTypedContent Void where + toTypedContent = absurd diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 5a032a6de..201091a2d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -15,10 +15,13 @@ module Database.Esqueleto.Utils , orderByOrd, orderByEnum , lower, ciEq , selectExists + , SqlHashable + , sha256 + , maybe ) where -import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust) +import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe) import Data.Universe import qualified Data.Set as Set import qualified Data.List as List @@ -27,6 +30,11 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E import Database.Esqueleto.Utils.TH +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +import Crypto.Hash (Digest, SHA256) + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -199,3 +207,28 @@ selectExists query = do case res of [E.Value b] -> return b _other -> error "SELECT EXISTS ... returned zero or more than one rows" + + +class SqlHashable a +instance SqlHashable Text +instance SqlHashable ByteString +instance SqlHashable Lazy.Text +instance SqlHashable Lazy.ByteString + + +sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest SHA256)) +sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text)) + + +maybe :: (PersistField a, PersistField b) + => E.SqlExpr (E.Value b) + -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) + -> E.SqlExpr (E.Value (Maybe a)) + -> E.SqlExpr (E.Value b) +maybe onNothing onJust val = E.case_ + [ E.when_ + (E.not_ $ E.isNothing val) + E.then_ + (onJust $ E.veryUnsafeCoerceSqlExprValue val) + ] + (E.else_ onNothing) diff --git a/src/Foundation.hs b/src/Foundation.hs index 5200a114b..9efb01b35 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -152,6 +152,7 @@ deriving instance Generic MaterialR deriving instance Generic TutorialR deriving instance Generic ExamR deriving instance Generic CourseApplicationR +deriving instance Generic AllocationR deriving instance Generic (Route UniWorX) -- | Convenient Type Synonyms: @@ -261,6 +262,8 @@ instance RenderMessage UniWorX Int64 where renderMessage f ls = renderMessage f ls . tshow instance RenderMessage UniWorX Integer where renderMessage f ls = renderMessage f ls . tshow +instance RenderMessage UniWorX Natural where + renderMessage f ls = renderMessage f ls . tshow instance HasResolution a => RenderMessage UniWorX (Fixed a) where renderMessage f ls = renderMessage f ls . showFixed True @@ -281,8 +284,12 @@ instance RenderMessage UniWorX MsgLanguage where where mr = renderMessage foundation ls -instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where - renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) +instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where + renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces + where + mr :: forall msg. RenderMessage UniWorX msg => msg -> Text + mr = renderMessage f ls + (pieces, _) = renderRoute route embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel @@ -371,6 +378,8 @@ instance ToMessage Int64 where toMessage = tshow instance ToMessage Integer where toMessage = tshow +instance ToMessage Natural where + toMessage = tshow instance HasResolution a => ToMessage (Fixed a) where toMessage = toMessage . showFixed True @@ -600,6 +609,17 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized + -- Allocations: access only to school admins + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do + E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool + E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized -- other routes: access to any admin is granted here _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -641,6 +661,34 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) return Authorized + AllocationR tid ssh ash (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID + isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId) + E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId + guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) + return Authorized + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedAllocationLecturer) + return Authorized -- lecturer for any school will do _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -712,8 +760,6 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of 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 @@ -823,8 +869,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized _other -> unauthorizedI MsgUnauthorizedCourseTime + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do + -- Checks `registerFrom` and `registerTo`, override as further routes become available + now <- liftIO getCurrentTime + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + guard $ NTop allocationRegisterFrom <= NTop (Just now) + guard $ NTop (Just now) <= NTop allocationRegisterTo + return Authorized + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- decrypt cID + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime @@ -832,6 +886,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r +tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do + -- Checks `registerFrom` and `registerTo`, override as further routes become available + now <- liftIO getCurrentTime + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) + guard $ NTop (Just now) <= NTop allocationStaffAllocationTo + return Authorized + + r -> $unsupportedAuthPredicate AuthStaffTime r tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime @@ -969,12 +1033,19 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r +tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do + uid <- hoistMaybe mAuthId + aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash + void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid + return Authorized + r -> $unsupportedAuthPredicate AuthAllocationRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do [E.Value ok] <- lift . E.select . return . E.exists $ E.from f whenExceptT ok Authorized - participant <- decrypt cID + participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID -- participant is currently registered $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse @@ -1030,6 +1101,13 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is applicant for this course + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of @@ -1105,20 +1183,25 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do - referencedUser <- case route of - 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 + referencedUser' <- case route of + AdminUserR cID -> return $ Left cID + AdminUserDeleteR cID -> return $ Left cID + AdminHijackUserR cID -> return $ Left cID + UserNotificationR cID -> return $ Left cID + UserPasswordR cID -> return $ Left cID + CourseR _ _ _ (CUserR cID) -> return $ Left cID CApplicationR _ _ _ cID _ -> do - appId <- decrypt cID - application <- $cachedHereBinary appId . lift $ get appId - case application of - Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf - Just CourseApplication{..} -> return courseApplicationUser + appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId + return $ Right courseApplicationUser + AllocationR _ _ _ (AApplicationR cID) -> do + appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId + return $ Right courseApplicationUser _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route + referencedUser <- case referencedUser' of + Right uid -> return uid + Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID case mAuthId of Just uid | uid == referencedUser -> return Authorized @@ -1133,7 +1216,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do UserPasswordR cID -> return cID CourseR _ _ _ (CUserR cID) -> return cID _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route - referencedUser' <- decrypt referencedUser + referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do User{..} <- MaybeT $ get referencedUser' guard $ userAuthentication == AuthLDAP @@ -1147,14 +1230,14 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d UserPasswordR cID -> return cID CourseR _ _ _ (CUserR cID) -> return cID _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route - referencedUser' <- decrypt referencedUser + referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do User{..} <- MaybeT $ get referencedUser' guard $ is _AuthPWHash userAuthentication return Authorized tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- decrypt cID + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId let isAuthenticated = isJust mAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated @@ -1658,6 +1741,12 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid) + breadcrumb (AllocationR tid ssh ash AShowR) = do + mr <- getMessageRender + Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR) + breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR) + breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 27fc5c809..ded5ebec7 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -21,7 +21,7 @@ import qualified Data.Map as Map import Database.Persist.Sql (fromSqlKey) import qualified Database.Esqueleto as E -import Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import Handler.Utils.Table.Cells import qualified Handler.Utils.TermCandidates as Candidates diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs new file mode 100644 index 000000000..286a87aa1 --- /dev/null +++ b/src/Handler/Allocation.hs @@ -0,0 +1,7 @@ +module Handler.Allocation + ( module Handler.Allocation + ) where + +import Handler.Allocation.Show as Handler.Allocation +import Handler.Allocation.Application as Handler.Allocation +import Handler.Allocation.Register as Handler.Allocation diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs new file mode 100644 index 000000000..cae507c55 --- /dev/null +++ b/src/Handler/Allocation/Application.hs @@ -0,0 +1,444 @@ +module Handler.Allocation.Application + ( AllocationApplicationButton(..) + , ApplicationFormView(..) + , ApplicationForm(..) + , ApplicationFormMode(..) + , ApplicationFormException(..) + , applicationForm + , postAApplyR + , getAApplicationR, postAApplicationR + ) where + +import Import hiding (hash) + +import Handler.Utils +import Utils.Lens + +import qualified Data.Text as Text +import qualified Data.Set as Set + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Conduit.List as C + +import Crypto.Hash (hash) + +import Control.Monad.Trans.State (execStateT) +import Control.Monad.State.Class (modify) + + +data AllocationApplicationButton = BtnAllocationApply + | BtnAllocationApplicationEdit + | BtnAllocationApplicationRetract + | BtnAllocationApplicationRate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe AllocationApplicationButton +instance Finite AllocationApplicationButton + +nullaryPathPiece ''AllocationApplicationButton $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''AllocationApplicationButton id +makePrisms ''AllocationApplicationButton + +instance Button UniWorX AllocationApplicationButton where + btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger] + btnClasses _ = [BCIsButton, BCPrimary] + + +data ApplicationFormView = ApplicationFormView + { afvPriority :: Maybe (FieldView UniWorX) + , afvForm :: [FieldView UniWorX] + , afvButtons :: ([AllocationApplicationButton], Widget) + } + +data ApplicationForm = ApplicationForm + { afPriority :: Maybe Natural + , afField :: Maybe StudyFeaturesId + , afText :: Maybe Text + , afFiles :: Maybe (Source Handler File) + , afRatingVeto :: Bool + , afRatingPoints :: Maybe ExamGrade + , afRatingComment :: Maybe Text + , afAction :: AllocationApplicationButton + } + +data ApplicationFormMode = ApplicationFormMode + { afmApplicant :: Bool -- ^ Show priority + , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown) + , afmLecturer :: Bool -- ^ Allow editing rating + } + + +data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application + deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance Exception ApplicationFormException + +applicationForm :: AllocationId + -> CourseId + -> UserId + -> ApplicationFormMode -- ^ Which parts of the shared form to display + -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) +applicationForm aId cid uid ApplicationFormMode{..} csrf = do + (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do + mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] + coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId] + course <- getJust cid + [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do + E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid + E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId) + E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) + return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority + return (mApplication, coursesNum, course, maxPrio) + MsgRenderer mr <- getMsgRenderer + + let + oldPrio :: Maybe Natural + oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal + + coursesNum' = succ maxPrio `max` coursesNum + + mkPrioOption :: Natural -> Option Natural + mkPrioOption i = Option + { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i + , optionInternalValue = i + , optionExternalValue = tshow i + } + + prioOptions :: OptionList Natural + prioOptions = OptionList + { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum'] + , olReadExternal = readMay + } + prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions + + (prioRes, prioView) <- case (afmApplicant, afmApplicantEdit, mApp) of + (True , True , Nothing) + -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) + (True , True , Just _ ) + -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio + (True , False, _ ) + -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio + (False, _ , Just _ ) + | is _Just oldPrio + -> pure (FormSuccess oldPrio, Nothing) + _other + -> throwM ApplicationFormNoApplication + + (fieldRes, fieldView') <- if + | afmApplicantEdit || afmLecturer + -> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp) + | otherwise + -> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal) + + let textField' = convertField (Text.strip . unTextarea) Textarea textareaField + textFs + | is _Just courseApplicationsInstructions + = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions + | otherwise + = fslI MsgCourseApplicationText + (textRes, textView) <- if + | not courseApplicationsText + -> pure (FormSuccess Nothing, Nothing) + | not afmApplicantEdit + -> over _2 Just <$> mforcedOpt textField' textFs (mApp >>= courseApplicationText . entityVal) + | otherwise + -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) + + hasFiles <- for mApp $ \(Entity appId _) + -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + appCID <- for mApp $ encrypt . entityKey + let appFilesInfo = (,) <$> hasFiles <*> appCID + + filesLinkView <- if + | fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) + -> let filesLinkField = Field{..} + where + fieldParse _ _ = return $ Right Nothing + fieldEnctype = mempty + fieldView theId _ attrs _ _ + = [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appCID) + + _{MsgCourseApplicationFiles} + $of _ + + _{MsgCourseApplicationNoFiles} + |] + in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) () + | otherwise + -> return Nothing + + filesWarningView <- if + | fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit + -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload + | otherwise + -> return Nothing + + (filesRes, filesView) <- + let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive + in if + | not afmApplicantEdit || is _NoUpload courseApplicationsFiles + -> return $ (FormSuccess Nothing, Nothing) + | otherwise + -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + + (vetoRes, vetoView) <- if + | afmLecturer + -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp) + | otherwise + -> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing) + + (pointsRes, pointsView) <- if + | afmLecturer + -> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal) + | otherwise + -> return (FormSuccess $ courseApplicationRatingPoints . entityVal =<< mApp, Nothing) + + (commentRes, commentView) <- if + | afmLecturer + -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal) + | otherwise + -> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing) + + let + buttons = catMaybes + [ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate + , guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationEdit + , guardOn ( afmApplicantEdit && is _Nothing mApp ) BtnAllocationApply + , guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationRetract + ] + (actionRes, buttonsView) <- buttonForm' buttons csrf + + return ( ApplicationForm + <$> prioRes + <*> fieldRes + <*> textRes + <*> filesRes + <*> vetoRes + <*> pointsRes + <*> commentRes + <*> actionRes + , ApplicationFormView + { afvPriority = prioView + , afvForm = catMaybes $ + [ Just fieldView' + , textView + , filesLinkView + , filesWarningView + ] ++ maybe [] (map Just) filesView ++ + [ vetoView + , pointsView + , commentView + ] + , afvButtons = (buttons, buttonsView) + } + ) + + + + +editApplicationR :: AllocationId + -> UserId + -> CourseId + -> Maybe CourseApplicationId + -> ApplicationFormMode + -> (AllocationApplicationButton -> Bool) + -> SomeRoute UniWorX + -> Handler (ApplicationFormView, Enctype) +editApplicationR aId uid cid mAppId afMode allowAction postAction = do + Course{..} <- runDB $ get404 cid + + ((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode + + formResult appRes $ \ApplicationForm{..} -> do + if + | BtnAllocationApply <- afAction + , allowAction afAction + -> runDB $ do + haveOld <- exists [ CourseApplicationCourse ==. cid + , CourseApplicationUser ==. uid + , CourseApplicationAllocation ==. Just aId + ] + when haveOld $ + invalidArgsI [MsgCourseApplicationExists] + + now <- liftIO getCurrentTime + let rated = afRatingVeto || is _Just afRatingPoints + + appId <- insert CourseApplication + { courseApplicationCourse = cid + , courseApplicationUser = uid + , courseApplicationField = afField + , courseApplicationText = afText + , courseApplicationRatingVeto = afRatingVeto + , courseApplicationRatingPoints = afRatingPoints + , courseApplicationRatingComment = afRatingComment + , courseApplicationAllocation = Just aId + , courseApplicationAllocationPriority = afPriority + , courseApplicationTime = now + , courseApplicationRatingTime = guardOn rated now + } + let + sinkFile' file = do + fId <- insert file + insert_ $ CourseApplicationFile appId fId + forM_ afFiles $ \afFiles' -> + runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + audit $ TransactionCourseApplicationEdit cid uid appId + addMessageI Success $ MsgCourseApplicationCreated courseShorthand + | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction + , allowAction afAction + , Just appId <- mAppId + -> runDB $ do + now <- liftIO getCurrentTime + + changes <- if + | afmApplicantEdit afMode -> do + oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] [] + changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' -> + let sinkFile' file = do + oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do + E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId + E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file) + E.&&. E.maybe + (E.val . is _Nothing $ fileContent file) + (\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file) + (file' E.^. FileContent) + E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles) + return $ file' E.^. FileId + if + | [E.Value oldFileId] <- oldFiles' + -> modify $ Set.delete oldFileId + | otherwise + -> do + fId <- lift $ insert file + lift . insert_ $ CourseApplicationFile appId fId + modify $ Set.insert fId + in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] + return changes + | otherwise + -> return Set.empty + + oldApp <- get404 appId + let newApp = oldApp + { courseApplicationField = afField + , courseApplicationText = afText + , courseApplicationRatingVeto = afRatingVeto + , courseApplicationRatingPoints = afRatingPoints + , courseApplicationRatingComment = afRatingComment + , courseApplicationAllocation = Just aId + , courseApplicationAllocationPriority = afPriority + } + + newRating = any (\f -> f oldApp newApp) + [ (/=) `on` courseApplicationRatingVeto + , (/=) `on` courseApplicationRatingPoints + , (/=) `on` courseApplicationRatingComment + ] + hasRating = any ($ newApp) + [ courseApplicationRatingVeto + , is _Just . courseApplicationRatingPoints + ] + + appChanged = any (\f -> f oldApp newApp) + [ (/=) `on` courseApplicationField + , (/=) `on` courseApplicationText + , \_ _ -> not $ Set.null changes + ] + + newApp' = newApp + & bool id (set _courseApplicationRatingTime Nothing) appChanged + & bool id (set _courseApplicationRatingTime $ Just now) (newRating && hasRating) + & bool id (set _courseApplicationTime now) appChanged + replace appId newApp' + audit $ TransactionCourseApplicationEdit cid uid appId + + uncurry addMessageI =<< case (afmLecturer afMode, newRating, hasRating, appChanged) of + (_, False, _, True) -> return (Success, MsgCourseApplicationEdited courseShorthand) + (_, False, _, False) -> return (Info, MsgCourseApplicationNotEdited courseShorthand) + (True, True, True, _) -> return (Success, MsgCourseApplicationRated) + (True, True, False, _) -> return (Success, MsgCourseApplicationRatingDeleted) + (False, True, _, _) -> permissionDenied "rating changed without lecturer rights" + | is _BtnAllocationApplicationRetract afAction + , allowAction afAction + , Just appId <- mAppId + -> runDB $ do + deleteCascade appId + audit $ TransactionCourseApplicationDeleted cid uid appId + addMessageI Success $ MsgCourseApplicationDeleted courseShorthand + | otherwise + -> invalidArgsI [MsgCourseApplicationInvalidAction] + + redirect postAction + + return (appView, appEnc) + + +postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void +postAApplyR tid ssh ash cID = do + uid <- requireAuthId + cid <- decrypt cID + (aId, Course{..}) <- runDB $ do + aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash + course <- get404 cid + return (aId, course) + + afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + + let afMode = ApplicationFormMode + { afmApplicant = True + , afmApplicantEdit = True + , afmLecturer + } + + void . editApplicationR aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID + + invalidArgs ["Application form required"] + + +getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html +getAApplicationR = postAApplicationR +postAApplicationR tid ssh ash cID = do + uid <- requireAuthId + appId <- decrypt cID + (Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do + alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash + app <- get404 appId + Just course <- getEntity $ courseApplicationCourse app + Just appUser <- get $ courseApplicationUser app + isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] + return (alloc, course, app, isAdmin, appUser) + + afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID + courseCID <- encrypt cid :: Handler CryptoUUIDCourse + + let afMode = ApplicationFormMode + { afmApplicant = uid == courseApplicationUser || isAdmin + , afmApplicantEdit + , afmLecturer + } + + (ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if + | uid == courseApplicationUser + -> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID + | otherwise + -> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID + + let title = MsgCourseApplicationTitle userDisplayName courseShorthand + + siteLayoutMsg title $ do + setTitleI title + + wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings + { formMethod = POST + , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID + , formEncoding = appEnc + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Nothing :: Maybe Text + } diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs new file mode 100644 index 000000000..9c2256695 --- /dev/null +++ b/src/Handler/Allocation/Register.hs @@ -0,0 +1,62 @@ +module Handler.Allocation.Register + ( AllocationRegisterForm(..) + , AllocationRegisterButton(..) + , allocationRegisterForm + , allocationUserToForm + , postARegisterR + ) where + +import Import + +import Utils.Lens + +import Handler.Utils.Form + +{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-} + + +data AllocationRegisterForm = AllocationRegisterForm + { arfTotalCourses :: Natural + } + +allocationRegisterForm :: Maybe AllocationRegisterForm -> AForm Handler AllocationRegisterForm +allocationRegisterForm template + = AllocationRegisterForm + <$> areq (posIntFieldI MsgAllocationTotalCoursesNegative) (fslI MsgAllocationTotalCourses & setTooltip MsgAllocationTotalCoursesTip) (arfTotalCourses <$> template <|> Just 1) + +allocationUserToForm :: AllocationUser -> AllocationRegisterForm +allocationUserToForm AllocationUser{..} = AllocationRegisterForm + { arfTotalCourses = allocationUserTotalCourses + } + +data AllocationRegisterButton = BtnAllocationRegister | BtnAllocationRegistrationEdit + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe AllocationRegisterButton +instance Finite AllocationRegisterButton + +nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''AllocationRegisterButton id + +instance Button UniWorX AllocationRegisterButton where + btnClasses _ = [BCIsButton, BCPrimary] + +postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void +postARegisterR tid ssh ash = do + uid <- requireAuthId + + ((registerRes, _), _) <- runFormPost . renderAForm FormStandard $ allocationRegisterForm Nothing + formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do + aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash + isRegistered <- existsBy $ UniqueAllocationUser aId uid + void $ upsert AllocationUser + { allocationUserAllocation = aId + , allocationUserUser = uid + , allocationUserTotalCourses = arfTotalCourses + } + [ AllocationUserTotalCourses =. arfTotalCourses + ] + if + | isRegistered -> addMessageI Success MsgAllocationRegistrationEdited + | otherwise -> addMessageI Success MsgAllocationRegistered + + redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text) diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs new file mode 100644 index 000000000..53149712a --- /dev/null +++ b/src/Handler/Allocation/Show.hs @@ -0,0 +1,96 @@ +module Handler.Allocation.Show + ( getAShowR + ) where + +import Import +import Handler.Utils +import Utils.Lens + +import Handler.Allocation.Register +import Handler.Allocation.Application + +import qualified Database.Esqueleto as E + + +getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAShowR tid ssh ash = do + muid <- maybeAuthId + + let + resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course) + resultCourse = _1 + resultCourseApplication :: Simple Field2 a (Maybe (Entity CourseApplication)) => Traversal' a (Entity CourseApplication) + resultCourseApplication = _2 . _Just + resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool + resultHasTemplate = _3 . _Value + + (Entity aId Allocation{..}, courses, registration) <- runDB $ do + alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash + + courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do + E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId) + E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid + E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + E.orderBy [E.asc $ course E.^. CourseName] + let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> + E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId + return (course, courseApplication, hasTemplate) + + registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId + + return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration) + + MsgRenderer mr <- getMsgRenderer + let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName + shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand + + staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) -> + hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR + mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR + (registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration + let + registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration + registerForm' = wrapForm' registerBtn registerForm FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR + , formEncoding = registerEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Nothing :: Maybe Text + } + + siteLayoutMsg title $ do + setTitleI shortTitle + + let courseWidgets = flip map courses $ \cEntry -> do + let Entity cid Course{..} = cEntry ^. resultCourse + hasApplicationTemplate = cEntry ^. resultHasTemplate + mApp = cEntry ^? resultCourseApplication + cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse + mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID + isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer + subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId + let mApplyFormView' = view _1 <$> mApplyFormView + overrideVisible = not mayApply && is _Just mApp + case mApplyFormView of + Just (_, appFormEnctype) + -> wrapForm $(widgetFile "allocation/show/course") FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute + , formEncoding = appFormEnctype + , formAttrs = [ ("class", "allocation-course") + ] + , formSubmit = FormNoSubmit + , formAnchor = Just cID + } + Nothing + -> let wdgt = $(widgetFile "allocation/show/course") + in [whamlet| +
+ ^{wdgt} + |] + + $(widgetFile "allocation/show") diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index 17fa5127b..7bdbb62ba 100644 --- a/src/Handler/Course/Application.hs +++ b/src/Handler/Course/Application.hs @@ -1,5 +1,6 @@ module Handler.Course.Application ( getCAFilesR + , getCApplicationsR, postCApplicationsR ) where import Import @@ -35,3 +36,7 @@ getCAFilesR tid ssh csh cID = do return file serveSomeFiles archiveName $ fsSource .| C.map entityVal + +getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCApplicationsR = postCApplicationsR +postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index dbaaac8df..7729d82f8 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -114,26 +114,26 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired - if - | isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles - -> let filesLinkField = Field{..} - where - fieldParse _ _ = return $ Right Nothing - fieldEnctype = mempty - fieldView theId _ attrs _ _ - = [whamlet| - $newline never - $case appFilesInfo - $of Just (True, appCID) - - _{filesMsg} - $of _ - - _{MsgCourseApplicationNoFiles} - |] - in void $ wforced filesLinkField (fslI filesMsg) Nothing - | otherwise - -> return () + when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $ + let filesLinkField = Field{..} + where + fieldParse _ _ = return $ Right Nothing + fieldEnctype = mempty + fieldView theId _ attrs _ _ + = [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appCID) + + _{filesMsg} + $of _ + + _{MsgCourseApplicationNoFiles} + |] + in void $ wforced filesLinkField (fslI filesMsg) Nothing + + when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $ + wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive @@ -177,7 +177,7 @@ postCRegisterR tid ssh csh = do = 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 + [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing (prevId:ps) -> do forM_ ps $ \appId -> do deleteApplicationFiles appId @@ -218,8 +218,14 @@ postCRegisterR tid ssh csh = do Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk BtnCourseDeregister -> runDB $ do deleteApplications - deleteBy $ UniqueParticipant uid cid - audit $ TransactionCourseParticipantDeleted cid uid + part <- getBy $ UniqueParticipant uid cid + forM_ part $ \(Entity partId CourseParticipant{..}) -> do + delete $ partId + audit $ TransactionCourseParticipantDeleted cid uid + + when courseParticipantAllocated $ do + now <- liftIO getCurrentTime + insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 0eca71463..9bc1b8f53 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -79,6 +79,10 @@ getCShowR tid ssh csh = do mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration + cID <- encrypt cid :: Handler CryptoUUIDCourse + mAllocation' <- for mAllocation $ \Allocation{..} -> (,) + <$> pure allocationName + <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID) regForm <- if | is _Just mbAid -> do (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index b4d16ff10..51e9975a5 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -20,9 +20,65 @@ getHomeR = do setTitleI MsgHomeHeading fromMaybe mempty upcomingExamsWidget maybe mempty homeUpcomingSheets muid + homeOpenAllocations homeOpenCourses +homeOpenAllocations :: Widget +homeOpenAllocations = do + cTime <- liftIO getCurrentTime + let tableData :: E.SqlExpr (Entity Allocation) + -> E.SqlQuery (E.SqlExpr (Entity Allocation)) + tableData allocation = do + E.where_ $ E.maybe E.false (\rf -> rf E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom) + E.&&. E.maybe E.true (\rt -> rt E.>=. E.val cTime) (allocation E.^. AllocationRegisterTo) + return allocation + + colonnade :: Colonnade Sortable (DBRow (Entity Allocation)) (DBCell (HandlerT UniWorX IO) ()) + colonnade = mconcat + [ -- dbRow + sortable (Just "term") (i18nCell MsgTerm) + $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> + anchorCell (TermCourseListR allocationTerm) [whamlet|#{allocationTerm}|] + , sortable (Just "schoolshort") (i18nCell MsgAllocationSchoolShort) + $ \DBRow{ dbrOutput=(Entity _ Allocation{..}) } -> + anchorCell (TermSchoolCourseListR allocationTerm allocationSchool) [whamlet|_{unSchoolKey allocationSchool}|] + , sortable (Just "allocation") (i18nCell MsgAllocation) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> do + anchorCell (AllocationR allocationTerm allocationSchool allocationShorthand AShowR) allocationName + , sortable (Just "deadline") (i18nCell MsgAllocationRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> + cell $ traverse (formatTime SelFormatDateTime) allocationRegisterTo >>= maybe mempty toWidget + ] + validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "allocation"] + allocationTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable + { dbtSQLQuery = tableData + , dbtRowKey = (E.^. AllocationId) + , dbtColonnade = colonnade + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "term" + , SortColumn $ \allocation -> allocation E.^. AllocationTerm + ) + , ( "schoolshort" + , SortColumn $ \allocation -> allocation E.^. AllocationSchool + ) + , ( "allocation" + , SortColumn $ \allocation -> allocation E.^. AllocationShorthand + ) + , ( "deadline" + , SortColumn $ \allocation -> allocation E.^. AllocationRegisterTo + ) + ] + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtStyle = def + , dbtParams = def + , dbtIdent = "open-allocations" :: Text + , dbtCsvEncode = noCsvEncode + , dbtCsvDecode = Nothing + } + $(widgetFile "home/openAllocations") + + homeOpenCourses :: Widget homeOpenCourses = do cTime <- liftIO getCurrentTime @@ -34,6 +90,13 @@ homeOpenCourses = do E.&&. ( E.isNothing (course E.^. CourseRegisterTo) E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime) ) + E.&&. E.not_ (E.exists . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterFrom) + E.||. E.maybe E.false (\rt -> rt E.<. E.val cTime) (allocation E.^. AllocationRegisterTo) + E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterByCourse) + ) return course colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) @@ -53,7 +116,8 @@ homeOpenCourses = do , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable + validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "course"] + courseTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = (E.^. CourseId) , dbtColonnade = colonnade diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 4a5cccef9..f1bf685b8 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -726,7 +726,7 @@ correctorForm shid = wFormToAForm $ do -- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message -- addMessageI Warning MsgCorrectorsDefaulted when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification - wformMessage =<< messageI Warning MsgCorrectorsDefaulted + wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted let diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 2f06cd252..a7de88025 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -12,7 +12,7 @@ import Import -- import Text.Blaze (ToMarkup(..)) import qualified Database.Esqueleto as E -import Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter) import Utils.Lens import Handler.Utils diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7ec441d58..3b5894373 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -112,6 +112,8 @@ import Database.Persist.Types.Instances as Import () import Data.UUID.Instances as Import () import System.FilePath.Instances as Import () import Net.IP.Instances as Import () +import Data.Void.Instances as Import () +import Crypto.Hash.Instances as Import () import Control.Monad.Trans.RWS (RWST) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 8ad57e8a4..3d2bf8a69 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -127,7 +127,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do initialMigration :: Migration -- ^ Manual migrations to go to InitialVersion below: initialMigration = do - migrateEnableExtension "citext" + mapM_ migrateEnableExtension ["citext", "pgcrypto"] migrateDBVersioning getMissingMigrations :: forall m m'. @@ -445,6 +445,15 @@ customMigrations = Map.fromListWith (>>) whenM (tableExists "allocation_application_file") $ tableDropEmpty "allocation_application_file" ) + , ( AppliedMigrationKey [migrationVersion|17.0.0|] [version|18.0.0|] + , do + whenM (tableExists "allocation") $ do + [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS capacity;|] + [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS link_external;|] + [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS register_secret;|] + whenM (tableExists "allocation_deregister") $ do + [executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|] + ) ] diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 2d8e8b1d0..53ff47cce 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -13,26 +13,28 @@ import Import.NoModel import qualified Yesod.Auth.Util.PasswordStore as PWStore -type Count = Sum Integer -type Points = Centi +type Count = Sum Integer +type Points = Centi -type Email = Text +type Email = Text -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type UserIdent = CI Text -type TutorialName = CI Text -type ExamName = CI Text -type ExamPartName = CI Text -type ExamOccurrenceName = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type SheetName = CI Text +type MaterialName = CI Text +type UserEmail = CI Email +type UserIdent = CI Text +type TutorialName = CI Text +type ExamName = CI Text +type ExamPartName = CI Text +type ExamOccurrenceName = CI Text +type AllocationName = CI Text +type AllocationShorthand = CI Text -type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString -type InstanceId = UUID -type ClusterId = UUID -type TokenId = UUID -type TermCandidateIncidence = UUID +type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString +type InstanceId = UUID +type ClusterId = UUID +type TokenId = UUID +type TermCandidateIncidence = UUID diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index c18083055..fe1739fd0 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -42,12 +42,14 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthLecturer | AuthCorrector | AuthTutor + | AuthAllocationRegistered | AuthCourseRegistered | AuthTutorialRegistered | AuthExamRegistered | AuthExamResult | AuthParticipant | AuthTime + | AuthStaffTime | AuthAllocationTime | AuthMaterials | AuthOwner diff --git a/src/Utils.hs b/src/Utils.hs index 795787841..91a53cdb9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,6 @@ module Utils ( module Utils + , List.nub, List.nubBy ) where import ClassyPrelude.Yesod hiding (foldlM, Proxy) @@ -39,7 +40,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map --- import qualified Data.List as List +import qualified Data.List as List import Control.Lens import Control.Lens as Utils (none) @@ -104,16 +105,17 @@ guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () -data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route +data UnsupportedAuthPredicate tag route = UnsupportedAuthPredicate tag route deriving (Eq, Ord, Typeable, Show) -instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) +instance (Show tag, Typeable tag, Show route, Typeable route) => Exception (UnsupportedAuthPredicate tag route) unsupportedAuthPredicate :: ExpQ unsupportedAuthPredicate = do logFunc <- logErrorS [e| \tag route -> do - $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|] - unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) + tRoute <- toTextUrl route + $(return logFunc) "AccessControl" $ "!" <> toPathPiece tag <> " used on route that doesn't support it: " <> tRoute + unauthorizedI (UnsupportedAuthPredicate tag route) |] -- | allows conditional attributes in hamlet via *{..} syntax @@ -376,6 +378,9 @@ partitionWith f (x:xs) = case f x of nonEmpty' :: Alternative f => [a] -> f (NonEmpty a) nonEmpty' = maybe empty pure . nonEmpty +nubOn :: Eq b => (a -> b) -> [a] -> [a] +nubOn = List.nubBy . ((==) `on`) + ---------- -- Sets -- ---------- diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 3907253cb..326cef129 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -48,6 +48,10 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r => Key record -> ReaderT backend m Bool existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record +exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m) + => [Filter record] -> ReaderT backend m Bool +exists = fmap (not . null) . flip selectKeysList [LimitTo 1] + updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend ) => Unique record -> [Update record] -> ReaderT backend m () updateBy uniq updates = do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c54ed44b3..8a4f951ac 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -720,6 +720,18 @@ renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => F (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) renderWForm formLayout = renderAForm formLayout . wFormToAForm +renderFieldViews :: ( RenderMessage site AFormMessage + , RenderMessage site FormMessage + ) + => FormLayout -> [FieldView site] -> WidgetT site IO () +renderFieldViews layout + = join + . fmap (view _1) + . generateFormPost + . lmap (const mempty) + . renderWForm layout + . (FormSuccess () <$) + . lift . tell -- | special id to identify form section headers, see 'aformSection' and 'formSection' -- currently only treated by form generation through 'renderAForm' @@ -796,15 +808,26 @@ wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) -formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification` +formMessage Message{..} = do return (FormSuccess (), FieldView { fvLabel = mempty , fvTooltip = Nothing , fvId = idFormMessageNoinput , fvErrors = Nothing , fvRequired = False - , fvInput = [whamlet|
#{messageContent}|] + , fvInput = [whamlet| + $newline never +
+
+ #{messageContent} + |] }) + where + defaultIcon = case messageStatus of + Success -> "check-circle" + Info -> "info-circle" + Warning -> "exclamation-circle" + Error -> "exclamation-triangle" --------------------- -- Form evaluation -- @@ -997,6 +1020,29 @@ mforced Field{..} FieldSettings{..} val = do } ) +mforcedOpt :: MonadHandler m + => Field m a + -> FieldSettings (HandlerSite m) + -> Maybe a + -> MForm m (FormResult (Maybe a), FieldView (HandlerSite m)) +mforcedOpt Field{..} FieldSettings{..} mVal = do + tell fieldEnctype + name <- maybe newFormIdent return fsName + theId <- lift $ maybe newIdent return fsId + mr <- getMessageRender + let fsAttrs' = fsAttrs <> [("disabled", "")] + return ( FormSuccess mVal + , FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml <$> fmap mr fsTooltip + , fvId = theId + , fvInput = fieldView theId name fsAttrs' (maybe (Left "") Right mVal) False + , fvErrors = Nothing + , fvRequired = False + } + ) + + aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> a -> AForm m a aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a7f6ceeae..30f62a959 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -47,6 +47,7 @@ data Icon | IconCommentFalse | IconLink | IconFileDownload + | IconFileUpload | IconFileZip | IconFileCSV | IconSFTQuestion -- for SheetFileType only @@ -57,6 +58,7 @@ data Icon | IconRegisterTemplate | IconApplyTrue | IconApplyFalse + | IconNoCorrectors deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text @@ -78,6 +80,7 @@ iconText = \case IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free IconLink -> "link" IconFileDownload -> "file-download" + IconFileUpload -> "file-upload" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" IconSFTQuestion -> "question-circle" -- for SheetFileType only, should all be round (similar) @@ -88,6 +91,7 @@ iconText = \case IconRegisterTemplate -> "file-alt" IconApplyTrue -> "file-alt" IconApplyFalse -> "trash" + IconNoCorrectors -> "user-slash" instance Universe Icon instance Finite Icon diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 4c015f185..2ddabae17 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -154,6 +154,10 @@ makePrisms ''AuthenticationMode makeLenses_ ''CourseUserNote +makeLenses_ ''CourseApplication + +makeLenses_ ''Allocation + -- makeClassy_ ''Load diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index d72d065bf..908848873 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -6,6 +6,7 @@ module Utils.Message , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) + , messageIconI , messageI, messageIHamlet, messageFile, messageWidget ) where @@ -140,6 +141,11 @@ messageI messageStatus msg = do let messageIcon = Nothing return Message{..} +messageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m Message +messageIconI messageStatus (Just -> messageIcon) msg = do + messageContent <- toHtml . ($ msg) <$> getMessageRender + return Message{..} + addMessageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet new file mode 100644 index 000000000..d2406a677 --- /dev/null +++ b/templates/allocation/show.hamlet @@ -0,0 +1,67 @@ +$newline never +
+ $#

+ $# _{MsgAllocationData} +
+ $maybe desc <- allocationDescription +
+ _{MsgAllocationDescription} +
+ #{desc} + $maybe fromT <- allocationStaffRegisterFrom +
+ $maybe _ <- allocationStaffRegisterTo + _{MsgAllocationStaffRegister} + $nothing + _{MsgAllocationStaffRegisterFrom} +
+ ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffRegisterTo} + $maybe fromT <- allocationRegisterFrom +
+ $maybe _ <- allocationRegisterTo + _{MsgAllocationRegister} + $nothing + _{MsgAllocationRegisterFrom} +
+ ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterTo} + $if staffInformation + $maybe fromT <- allocationStaffAllocationFrom +
+ $maybe _ <- allocationStaffAllocationTo + _{MsgAllocationStaffAllocation} + $nothing + _{MsgAllocationStaffAllocationFrom} +
+ ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo} + +$if is _Just muid + $if mayRegister || is _Just registration +
+

+ _{MsgAllocationParticipation} + $if mayRegister + ^{registerForm'} + $else + $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration +
+
+ _{MsgAllocationTotalCourses} +
+ #{allocationUserTotalCourses} +$else +
+

+ _{MsgAllocationParticipation} +

+ _{MsgAllocationParticipationLoginFirst} + +$if not (null courseWidgets) +

+

+ _{MsgAllocationCourses} +
+

_{MsgAllocationPriorityTip} +

_{MsgAllocationPriorityRelative} +

+ $forall courseWgt <- courseWidgets + ^{courseWgt} diff --git a/templates/allocation/show.lucius b/templates/allocation/show.lucius new file mode 100644 index 000000000..7e2e4f406 --- /dev/null +++ b/templates/allocation/show.lucius @@ -0,0 +1,85 @@ +.allocation__label { + color: var(--color-fontsec); + font-style: italic; +} + +.allocation__courses { + margin-top: 20px; +} + +.allocation-course { + display: grid; + grid-template-columns: 140px 1fr; + grid-template-areas: + '. name ' + 'prio-label prio ' + 'instr-label instr ' + 'form-label form '; + + grid-gap: 5px 7px; + padding: 12px 10px; + + &:last-child { + padding: 12px 10px 0 10px; + } + + & + .allocation-course { + border-top: 1px solid var(--color-grey); + } + + + .allocation-course__priority { + grid-area: prio; + } + .allocation-course__priority-label { + grid-area: prio-label; + justify-self: end; + align-self: center; + text-align: right; + } + + .allocation-course__name { + grid-area: name; + + align-self: center; + + font-size: 1.2rem; + } + + .allocation-course__instructions { + grid-area: instr; + } + .allocation-course__instructions-label { + grid-area: instr-label; + justify-self: end; + text-align: right; + } + + .allocation-course__application { + grid-area: form; + } + .allocation-course__application-label { + grid-area: form-label; + justify-self: end; + text-align: right; + padding-top: 6px; + } +} + +@media (max-width: 426px) { + .allocation-course { + grid-template-columns: 1fr; + grid-template-areas: + 'name ' + 'prio-label ' + 'prio ' + 'instr-label' + 'instr ' + 'form-label ' + 'form '; + } + + .allocation-course__application-label { + padding-top: 0; + } +} diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet new file mode 100644 index 000000000..53992eed4 --- /dev/null +++ b/templates/allocation/show/course.hamlet @@ -0,0 +1,27 @@ +$if is _Just muid +
+ _{MsgAllocationPriority} +
+ $maybe prioView <- mApplyFormView' >>= afvPriority + ^{fvInput prioView} + $nothing + _{MsgAllocationNoApplication} + + #{courseName} +$if hasApplicationTemplate || is _Just courseApplicationsInstructions +
+ _{MsgCourseApplicationInstructionsApplication} +
+ $maybe aInst <- courseApplicationsInstructions +

+ #{aInst} + $if hasApplicationTemplate +

+ + #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} +$maybe ApplicationFormView{ ..} <- mApplyFormView' +

+ _{MsgCourseApplication} +
+ ^{renderFieldViews FormStandard afvForm} + ^{snd afvButtons} diff --git a/templates/course.hamlet b/templates/course.hamlet index 713f61e13..1372fd58d 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -64,9 +64,11 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) #{participants} $maybe capacity <- courseCapacity course \ von #{capacity} - $maybe Allocation{allocationName} <- mAllocation + $maybe (name, url) <- mAllocation'
_{MsgCourseAllocation} -
#{allocationName} +
+ + #{name} $nothing $maybe regFrom <- mRegFrom
Anmeldezeitraum diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b1db5eea7..f929425ec 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -180,11 +180,15 @@ h4 { } p { - margin: 10px 0; - } + margin: 0.5rem 0; - p:last-child { - margin: 10px 0 0; + &:last-child { + margin: 0.5rem 0 0; + } + + &:first-of-type { + margin: 0; + } } } @@ -546,6 +550,7 @@ section { &:last-child { border-bottom: none; + padding-bottom: 0px; } } @@ -564,33 +569,64 @@ section { border-radius: 3px; padding: 10px 20px 20px; margin: 40px 0; - color: var(--color-dark); box-shadow: 0 0 4px 2px inset currentColor; - padding-left: 20%; + padding-left: 100px; min-height: 100px; + max-width: 700px; + font-weight: 600; + vertical-align: center; + display: grid; + grid-column: 2; &::before { - content: 'i'; + font-family: "Font Awesome 5 Free"; + font-weight: 900; position: absolute; display: flex; left: 0; top: 0; height: 100%; - width: 20%; - font-size: 100px; + width: 100px; + font-size: 50px; align-items: center; justify-content: center; } + + .notification__content { + grid-column: 1; + align-self: center; + } } -.form-group__input > .notification { - margin: 0; +.form-section-notification { + display: grid; + grid-template-columns: 1fr 3fr; + grid-gap: 5px; + + .notification { + margin: 0; + } + + + .form-group, + .form-section-legend, + .form-section-notification { + margin-top: 11px; + } + + + .form-section-title { + margin-top: 40px; + } } @media (max-width: 768px) { + .form-section-notification { + grid-template-columns: 1fr; + margin-top: 17px; + } .notification { + grid-column: 1; + max-width: none; + padding-left: 40px; &::before { @@ -602,16 +638,20 @@ section { } } -.notification-danger { - color: #c51919 ; - - &::before { - content: '!'; - } +.notification-error { + color: var(--color-error) ; } -.notification__content { - color: var(--color-font); +.notification-warning { + color: var(--color-warning) ; +} + +.notification-info { + color: var(--color-lightblack) ; +} + +.notification-success { + color: var(--color-warning) ; } diff --git a/templates/home/openAllocations.hamlet b/templates/home/openAllocations.hamlet new file mode 100644 index 000000000..16c84d41a --- /dev/null +++ b/templates/home/openAllocations.hamlet @@ -0,0 +1,4 @@ +$newline never +
+

_{MsgHomeOpenAllocations} + ^{allocationTable} diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index d32d6a27c..d2c436d00 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,15 @@ $newline never
+
19.08.2019 +
+