Merge branch 'master' into 441-polyfills-als-npm-dependencies-einbinden

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)
 
 

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 {
 

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() {

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

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 {
+  + .form-group, + .form-section-legend, + .form-section-notification {
-    margin-top: 7px;
+    margin-top: 11px;
   }
 
   + .form-section-title {

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

models/allocations

@@ -1,12 +1,10 @@
 Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
-    name                (CI Text)
+    name                AllocationName
-    shorthand           (CI Text)       -- practical shorthand
+    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)

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

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,
+          "dev": true
-          "optional": true
         },
         "aproba": {
           "version": "1.2.0",
@@ -6554,8 +6553,7 @@
         "code-point-at": {
           "version": "1.1.0",
           "bundled": true,
-          "dev": true,
+          "dev": true
-          "optional": true
         },
         "concat-map": {
           "version": "0.0.1",
@@ -6566,8 +6564,7 @@
         "console-control-strings": {
           "version": "1.1.0",
           "bundled": true,
-          "dev": true,
+          "dev": true
-          "optional": true
         },
         "core-util-is": {
           "version": "1.0.2",
@@ -6684,8 +6681,7 @@
         "inherits": {
           "version": "2.0.3",
           "bundled": true,
-          "dev": true,
+          "dev": true
-          "optional": 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,
+          "dev": true
-          "optional": 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,
+          "dev": true
-          "optional": 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,
+          "dev": true
-          "optional": true
         },
         "yallist": {
           "version": "3.0.3",
           "bundled": true,
-          "dev": true,
+          "dev": true
-          "optional": true
         }
       }
     },

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "5.0.2",
+  "version": "5.1.0",
   "description": "",
   "keywords": [],
   "author": "",

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

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
 

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

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 

src/CryptoID.hs

@@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
              , ''ExamPartId
              , ''AllocationId
              , ''CourseApplicationId
+             , ''CourseId
              ]
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

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
+import Web.PathPieces
-  toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
+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

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

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)

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
+instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
-  renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
+  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
+  referencedUser' <- case route of
-    AdminUserR cID -> decrypt cID
+    AdminUserR cID -> return $ Left cID
-    AdminUserDeleteR cID -> decrypt cID
+    AdminUserDeleteR cID -> return $ Left cID
-    AdminHijackUserR cID -> decrypt cID
+    AdminHijackUserR cID -> return $ Left cID
-    UserNotificationR cID -> decrypt cID
+    UserNotificationR cID -> return $ Left cID
-    UserPasswordR cID -> decrypt cID
+    UserPasswordR cID -> return $ Left cID
-    CourseR _ _ _ (CUserR cID) -> decrypt cID
+    CourseR _ _ _ (CUserR cID) -> return $ Left cID
     CApplicationR _ _ _ cID _ -> do
-      appId <- decrypt cID
+      appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
-      application <- $cachedHereBinary appId . lift $ get appId
+      CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
-      case application of
+      return $ Right courseApplicationUser
-        Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
+    AllocationR _ _ _ (AApplicationR cID) -> do
-        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
     _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)

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

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

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)
+                             <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
+                               _{MsgCourseApplicationFiles}
+                           $of _
+                             <span ##{theId} *{attrs}>
+                               _{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
+      }

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)

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|
+                       <div .allocation-course ##{toPathPiece cID}>
+                         ^{wdgt}
+                     |]
+  
+    $(widgetFile "allocation/show")

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

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
+    when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
-      | isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles
+      let filesLinkField = Field{..}
-        -> let filesLinkField = Field{..}
+            where
-                 where
+              fieldParse _ _ = return $ Right Nothing
-                   fieldParse _ _ = return $ Right Nothing
+              fieldEnctype = mempty
-                   fieldEnctype = mempty
+              fieldView theId _ attrs _ _
-                   fieldView theId _ attrs _ _
+                = [whamlet|
-                     = [whamlet|
+                    $newline never
-                         $newline never
+                      $case appFilesInfo
-                           $case appFilesInfo
+                        $of Just (True, appCID)
-                             $of Just (True, appCID)
+                          <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
-                               <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
+                            _{filesMsg}
-                                 _{filesMsg}
+                        $of _
-                             $of _
+                          <span ##{theId} *{attrs}>
-                               <span ##{theId} *{attrs}>
+                            _{MsgCourseApplicationNoFiles}
-                                 _{MsgCourseApplicationNoFiles}
+                  |]
-                       |]
+       in void $ wforced filesLinkField (fslI filesMsg) Nothing
-            in void $ wforced filesLinkField (fslI filesMsg) Nothing
+
-      | otherwise
+    when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
-        -> return ()
+      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
+        part <- getBy $ UniqueParticipant uid cid
-        audit $ TransactionCourseParticipantDeleted cid uid
+        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

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)

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

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

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

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)

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;|]
+    )
   ]
 
 

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 Count                   = Sum Integer
-type Points = Centi
+type Points                  = Centi
 
-type Email              = Text
+type Email                   = Text
 
-type SchoolName         = CI Text
+type SchoolName              = CI Text
-type SchoolShorthand    = CI Text
+type SchoolShorthand         = CI Text
-type CourseName         = CI Text
+type CourseName              = CI Text
-type CourseShorthand    = CI Text
+type CourseShorthand         = CI Text
-type SheetName          = CI Text
+type SheetName               = CI Text
-type MaterialName       = CI Text
+type MaterialName            = CI Text
-type UserEmail          = CI Email
+type UserEmail               = CI Email
-type UserIdent          = CI Text
+type UserIdent               = CI Text
-type TutorialName       = CI Text
+type TutorialName            = CI Text
-type ExamName           = CI Text
+type ExamName                = CI Text
-type ExamPartName       = CI Text
+type ExamPartName            = CI Text
-type ExamOccurrenceName = CI Text
+type ExamOccurrenceName      = CI Text
+type AllocationName          = CI Text
+type AllocationShorthand     = CI Text
 
-type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type PWHashAlgorithm         = ByteString -> PWStore.Salt -> Int -> ByteString
-type InstanceId      = UUID
+type InstanceId              = UUID
-type ClusterId       = UUID
+type ClusterId               = UUID
-type TokenId         = UUID
+type TokenId                 = UUID
-type TermCandidateIncidence = UUID
+type TermCandidateIncidence  = UUID

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

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}|]
+        tRoute <- toTextUrl route
-        unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) 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 --
 ----------

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

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|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
+    , fvInput    = [whamlet|
+                     $newline never
+                     <div .notification .notification-#{toPathPiece messageStatus} .fa-#{maybe defaultIcon iconText messageIcon}>
+                       <div .notification__content>
+                         #{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

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

src/Utils/Lens.hs

@@ -154,6 +154,10 @@ makePrisms ''AuthenticationMode
 
 makeLenses_ ''CourseUserNote
 
+makeLenses_ ''CourseApplication
+  
+makeLenses_ ''Allocation
+
 
 -- makeClassy_ ''Load
 

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

templates/allocation/show.hamlet

@@ -0,0 +1,67 @@
+$newline never
+<section>
+  $# <h2>
+  $#   _{MsgAllocationData}
+  <dl .deflist>
+    $maybe desc <- allocationDescription
+      <dt .deflist__dt>
+        _{MsgAllocationDescription}
+      <dd .deflist__dd>
+        #{desc}
+    $maybe fromT <- allocationStaffRegisterFrom
+      <dt .deflist__dt>
+        $maybe _ <- allocationStaffRegisterTo
+          _{MsgAllocationStaffRegister}
+        $nothing
+          _{MsgAllocationStaffRegisterFrom}
+      <dd .deflist__dd>
+        ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffRegisterTo}
+    $maybe fromT <- allocationRegisterFrom
+      <dt .deflist__dt>
+        $maybe _ <- allocationRegisterTo
+          _{MsgAllocationRegister}
+        $nothing
+          _{MsgAllocationRegisterFrom}
+      <dd .deflist__dd>
+        ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterTo}
+    $if staffInformation
+      $maybe fromT <- allocationStaffAllocationFrom
+        <dt .deflist__dt>
+          $maybe _ <- allocationStaffAllocationTo
+            _{MsgAllocationStaffAllocation}
+          $nothing
+            _{MsgAllocationStaffAllocationFrom}
+        <dd .deflist__dd>
+          ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
+
+$if is _Just muid
+  $if mayRegister || is _Just registration
+    <section id=allocation-participation>
+      <h2>
+        _{MsgAllocationParticipation}
+      $if mayRegister
+        ^{registerForm'}
+      $else
+        $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration
+          <dl .deflist>
+            <dt .deflist__dt>
+              _{MsgAllocationTotalCourses}
+            <dd .deflist__dd>
+              #{allocationUserTotalCourses}
+$else
+  <section id=allocation-participation>
+    <h2>
+      _{MsgAllocationParticipation}
+    <p>
+      _{MsgAllocationParticipationLoginFirst}
+
+$if not (null courseWidgets)
+  <section .allocation>
+    <h2>
+      _{MsgAllocationCourses}
+    <div .allocation__explanation .allocation__label>
+      <p>_{MsgAllocationPriorityTip}
+      <p>_{MsgAllocationPriorityRelative}
+    <div .allocation__courses>
+      $forall courseWgt <- courseWidgets
+        ^{courseWgt}

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;
+  }
+}

templates/allocation/show/course.hamlet

@@ -0,0 +1,27 @@
+$if is _Just muid
+  <div .allocation-course__priority-label .allocation__label>
+    _{MsgAllocationPriority}
+  <div .allocation-course__priority>
+    $maybe prioView <- mApplyFormView' >>= afvPriority
+      ^{fvInput prioView}
+    $nothing
+      _{MsgAllocationNoApplication}
+<a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
+  #{courseName}
+$if hasApplicationTemplate || is _Just courseApplicationsInstructions
+  <div .allocation-course__instructions-label .allocation__label>
+    _{MsgCourseApplicationInstructionsApplication}
+  <div .allocation-course__instructions>
+    $maybe aInst <- courseApplicationsInstructions
+      <p>
+        #{aInst}
+    $if hasApplicationTemplate
+      <p>
+        <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
+          #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
+$maybe ApplicationFormView{ ..} <- mApplyFormView'
+  <div .allocation-course__application-label .allocation__label :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+    _{MsgCourseApplication}
+  <div .allocation-course__application :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+    ^{renderFieldViews FormStandard afvForm}
+    ^{snd afvButtons}

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'
     <dt .deflist__dt>_{MsgCourseAllocation}
-    <dd .deflist__dd>#{allocationName}
+    <dd .deflist__dd>
+      <a href=#{url}>
+        #{name}
   $nothing
     $maybe regFrom <- mRegFrom
       <dt .deflist__dt>Anmeldezeitraum

templates/default-layout.lucius

@@ -180,11 +180,15 @@ h4 {
   }
 
   p {
-    margin: 10px 0;
+    margin: 0.5rem 0;
-  }
 
-  p:last-child {
+    &:last-child {
-    margin: 10px 0 0;
+      margin: 0.5rem 0 0;
+    }
+
+    &:first-of-type {
+      margin: 0;
+    }
   }
 }
 
@@ -546,6 +550,7 @@ section {
 
     &:last-child {
         border-bottom: none;
+        padding-bottom: 0px;
     }
 }
 
@@ -564,32 +569,63 @@ 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%;
+    width: 100px;
-    font-size: 100px;
+    font-size: 50px;
     align-items: center;
     justify-content: center;
   }
+
+  .notification__content {
+    grid-column: 1;
+    align-self: center;
+  }
 }
 
-.form-group__input > .notification {
+.form-section-notification {
-  margin: 0;
+  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;
 
@@ -602,16 +638,20 @@ section {
   }
 }
 
-.notification-danger {
+.notification-error {
-  color: #c51919 ;
+  color: var(--color-error) ;
-
-  &::before {
-    content: '!';
-  }
 }
 
-.notification__content {
+.notification-warning {
-  color: var(--color-font);
+  color: var(--color-warning) ;
+}
+
+.notification-info {
+  color: var(--color-lightblack) ;
+}
+
+.notification-success {
+  color: var(--color-warning) ;
 }
 
 

templates/home/openAllocations.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<section>
+  <h2>_{MsgHomeOpenAllocations}
+  ^{allocationTable}

templates/i18n/changelog/de.hamlet

@@ -1,5 +1,15 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>19.08.2019
+  <dd .deflist__dd>
+    <ul>
+      <li>Bewerbungen für Zentralanmeldungen
+  
+  <dt .deflist__dt>12.08.2019
+  <dd .deflist__dd>
+    <ul>
+      <li>Kurse zu Zentralanmeldungen eintragen
+  
   <dt .deflist__dt>23.07.2019
   <dd .deflist__dd>
     <ul>

templates/i18n/info-lecturer/de.hamlet

@@ -12,8 +12,6 @@ $newline text
       <p>
         Veranstalter können eigene Veranstaltungen zu verschiedenen Zentralanmeldungen hinzufügen.
         Dies findet man unter dem Menupunkt "Kurs editieren"
-      <p>
-        Die Zentralanmeldungen selbst sind momentan aber noch nicht sichtbar; dies folgt in Kürze.
       <p>
         Weitere Details finden sich weiter unter auf dieser Seite in einem
         <a href="#allocations">
@@ -32,16 +30,6 @@ $newline text
           eigenem Abschnitt
         \ detailliert.
 
-
-    <dt .deflist__dt>Benachrichtigungen
-    <dd .deflist__dd>
-      Benachrichtigungen werden momentan oft mit großer Verzögerung versandt.
-      Die Ursache ist derzeit noch unbekannt, da das Problem noch nicht genauer untersucht werden konnte.
-
-    $#
-    $# MOVE ITEM TO SECTION "VERANSTALTUNGEN", once it is implemented:
-    $#
-
 <section>
   <h2>Veranstaltungen
 
@@ -365,16 +353,21 @@ $newline text
       Veranstaltungen können einen beliebigen Namen tragen.
       Die behelfsmäßigen Kürzel wie [SB], [ZP], usw sind nicht mehr notwendig!
 
-    <dt .deflist__dt> Kurseinstellung
+    <dt .deflist__dt> Kurseinstellungen
     <dd .deflist__dd>
-      Die Kurseinstellungen werden ggf. von den notwendigen Einstellungen
+      <p>
-      der jeweiligen Zentralanmeldung überschrieben, d.h. Veranstalter
+        Die Kurseinstellungen werden ggf. von den notwendigen Einstellungen
-      können hier keine Fehler mehr machen.
+        der jeweiligen Zentralanmeldung überschrieben, d.h. Veranstalter
+        können hier keine Fehler mehr machen.
+      <p>
+        Insbesondere wird auch der eingestellte Anmeldungszeitraum ignoriert und
+        die direkte Anmeldung von Studierenden zum Kurs (auch durch die
+        Kursverwalter) unterbunden, bis die zentrale Platzvergabe erfolgt ist.
 
     <dt .deflist__dt> Individuelle Bewerbungen
     <dd .deflist__dd>
       Studierende können nun pro Kurs eine individuelle Bewerbung abgeben,
-      welche nur den jeweiligen Kursverwaltern zugestelt wird.
+      welche nur den jeweiligen Kursverwaltern zugestellt wird.
 
 
     <dt .deflist__dt> Feedback zu Bewerbungen

templates/widgets/aform/aform.hamlet

@@ -11,6 +11,9 @@ $case formLayout
       $if fvId view == idFormSectionNoinput
         <h3 .form-section-title>
           ^{fvLabel view}
+      $elseif fvId view == idFormMessageNoinput
+        <div .form-section-notification>
+          ^{fvInput view}
       $else
         <div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
           $if not (Blaze.null $ fvLabel view)

test/Database.hs

@@ -703,3 +703,25 @@ fillDb = do
   void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
   void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
   void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
+
+
+  funAlloc <- insert' Allocation
+    { allocationName = "Funktionale Zentralanmeldung"
+    , allocationShorthand = "fun"
+    , allocationTerm = TermKey summer2018
+    , allocationSchool = ifi
+    , allocationDescription = Nothing
+    , allocationStaffDescription = Nothing
+    , allocationStaffRegisterFrom = Just now
+    , allocationStaffRegisterTo = Nothing
+    , allocationStaffAllocationFrom = Nothing
+    , allocationStaffAllocationTo = Nothing
+    , allocationRegisterFrom = Nothing
+    , allocationRegisterTo = Nothing
+    , allocationRegisterByStaffFrom = Nothing
+    , allocationRegisterByStaffTo = Nothing
+    , allocationRegisterByCourse = Nothing
+    , allocationOverrideDeregister = Just now
+    }
+  insert_ $ AllocationCourse funAlloc pmo 100
+  insert_ $ AllocationCourse funAlloc ffp 2

test/FoundationSpec.hs

@@ -52,6 +52,10 @@ instance Arbitrary CourseApplicationR where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary AllocationR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary (Route UniWorX) where
   arbitrary = genericArbitrary
   shrink = genericShrink