Upload instructions

ChangeLog.md

@@ -1,3 +1,9 @@
+  * Version 20.04.2019
+  
+    Versand von Benachrichtigungen an Kursteilnehmer
+    
+    Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account
+
   * Version 27.03.2019
 
     Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen

config/settings.yml

@@ -27,6 +27,8 @@ notification-rate-limit: 3600
 notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
+jwt-expiration: 604800
+jwt-encoding: HS256
 maximum-content-length: 52428800
 
 log-settings:

haddock.sh

@@ -1,3 +1,14 @@
 #!/usr/bin/env bash
 
-exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
+move-back() {
+    mv -v .stack-work .stack-work-doc
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
+}
+
+if [[ -d .stack-work-doc ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
+    mv -v .stack-work-doc .stack-work
+    trap move-back EXIT
+fi
+
+stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

hlint.sh

@@ -1,3 +1,3 @@
 #!/usr/bin/env bash
 
-exec -- ./test.sh uniworx:test:hlint
+exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint

messages/uniworx/de.msg

@@ -10,6 +10,11 @@ BtnSave: Speichern
 BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
 BtnCandidatesDeleteConflicts: Konflikte löschen
 BtnCandidatesDeleteAll: Alle Beobachtungen löschen
+BtnResetTokens: Authorisierungs-Tokens invalidieren
+BtnLecInvAccept: Annehmen
+BtnLecInvDecline: Ablehnen
+BtnCorrInvAccept: Annehmen
+BtnCorrInvDecline: Ablehnen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -114,6 +119,7 @@ CourseUserNoteSaved: Notizänderungen gespeichert
 CourseUserNoteDeleted: Teilnehmernotiz gelöscht
 CourseUserDeregister: Abmelden
 CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
+CourseUserSendMail: Mitteilung verschicken
 
 CourseLecturers: Kursverwalter
 CourseLecturer: Dozent
@@ -206,6 +212,13 @@ CorrectorAssignTitle: Korrektor zuweisen
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{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.
+UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
+UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
+UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
+UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
@@ -234,6 +247,7 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au
 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.
+UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer.
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@@ -241,7 +255,7 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic
 TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
 
 AddCorrector: Zusätzlicher Korrektor
-CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
+CorrectorExists: Nutzer ist bereits als Korrektor eingetragen
 SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
@@ -275,6 +289,9 @@ ImpressumHeading: Impressum
 DataProtHeading: Datenschutzerklärung
 SystemMessageHeading: Uni2work Statusmeldung
 SystemMessageListHeading: Uni2work Statusmeldungen
+NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}
+TokensLastReset: Tokens zuletzt invalidiert
+TokensResetSuccess: Authorisierungs-Tokens invalidiert
 
 HomeOpenCourses: Kurse mit offener Registrierung
 HomeUpcomingSheets: Anstehende Übungsblätter
@@ -291,7 +308,8 @@ Plugin: Plugin
 Ident: Identifikation
 LastLogin: Letzter Login
 Settings: Individuelle Benutzereinstellungen
-SettingsUpdate: Einstellungen wurden gespeichert.
+SettingsUpdate: Einstellungen erfolgreich gespeichert
+NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert
 Never: Nie
 
 PreviouslyUploadedInfo: Bereits hochgeladene Dateien:
@@ -438,9 +456,10 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken
 
-SheetNoSubmissions: Keine Abgabe
+NoSubmissions: Keine Abgabe
-SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
+CorrectorSubmissions: Abgabe extern mit Pseudonym
-SheetUserSubmissions: Direkte Abgabe
+UserSubmissions: Direkte Abgabe
+BothSubmissions: Abgabe direkt & extern mit Pseudonym
 
 SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
 
@@ -515,6 +534,12 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
+CommCourseSubject: Kursmitteilung
+MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
+InvitationAcceptDecline: Einladung annehmen/ablehnen
+
+MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
@@ -669,9 +694,11 @@ MenuLogin: Login
 MenuLogout: Logout
 MenuCourseList: Kurse
 MenuCourseMembers: Kursteilnehmer
+MenuCourseCommunication: Kursmitteilung
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
+MenuUserNotifications: Benachrichtigungs-Einstellungen
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
@@ -706,6 +733,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
+AuthTagToken: Nutzer präsentiert Authorisierungs-Token
 AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
 AuthTagDeprecated: Seite ist nicht überholt
 AuthTagDevelopment: Seite ist nicht in Entwicklung
@@ -721,6 +749,7 @@ AuthTagOwner: Nutzer ist Besitzer
 AuthTagRated: Korrektur ist bewertet
 AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
+AuthTagSelf: Nutzer greift nur auf eigene Daten zu
 AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend
@@ -729,9 +758,38 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "
 DeleteConfirmation: Bestätigung
 DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
 
-DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
+DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
 
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
 NavigationFavourites: Favoriten
+
+CommSubject: Betreff
+CommBody: Nachricht
+CommRecipients: Empfänger
+CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
+CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
+CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
+
+CommCourseHeading: Kursmitteilung
+
+RecipientCustom: Weitere Empfänger
+
+RGCourseParticipants: Kursteilnehmer
+RGCourseLecturers: Kursverwalter
+RGCourseCorrectors: Korrektoren
+
+MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
+MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
+EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
+
+LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
+LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
+CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
+CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
+
+CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
+CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
+SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
+SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.

models/courses

@@ -35,6 +35,12 @@ Lecturer                       -- course ownership
     course       CourseId
     type         LecturerType  default='"lecturer"'
     UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
+LecturerInvitation json        -- preliminary course ownership for when a token to become `Lecturer` is sent to an email
+    email        (CI Text)
+    course       CourseId
+    type         LecturerType Maybe
+    UniqueLecturerInvitation email course
+    deriving Eq Ord Read Show Generic Typeable
 CourseParticipant                      -- course enrolement
     course       CourseId
     user         UserId

models/sheets

@@ -10,8 +10,7 @@ Sheet   -- exercise sheet for a given course
     activeTo        UTCTime          -- Submission is only permitted before
     hintFrom        UTCTime Maybe    -- Additional files are made available
     solutionFrom    UTCTime Maybe    -- Solution is made available
-    uploadMode      UploadMode       -- Take apart Zip-Archives or not?
+    submissionMode  SubmissionMode   -- Submission upload by students and/or through tutors?
-    submissionMode  SheetSubmissionMode default='UserSubmissions'  -- Submission upload by students or through tutors only?
     autoDistribute  Bool default=false  -- Should correctors be assigned submissions automagically?
     CourseSheet course name
     deriving Generic
@@ -36,6 +35,13 @@ SheetCorrector                -- grant corrector role to user for a sheet
     state           CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
     UniqueSheetCorrector user sheet
     deriving Show Eq Ord
+SheetCorrectorInvitation json
+    email           UserEmail
+    sheet           SheetId
+    load            Load
+    state           CorrectorState
+    UniqueSheetCorrectorInvitation email sheet
+    deriving Show Read Eq Ord Generic Typeable
 SheetFile                     -- a file that is part of an exercise sheet
     sheet           SheetId
     file            FileId

models/users

@@ -11,6 +11,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     ident          (CI Text)                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
+    tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null) 
     matrikelnummer Text Maybe               -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
     email          (CI Text)                -- Case-insensitive eMail address
     displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)

package.yaml

@@ -85,6 +85,7 @@ dependencies:
   - scientific
   - tz
   - system-locale
+  - th-lift
   - th-lift-instances
   - gitrev
   - Glob
@@ -117,6 +118,9 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - jose-jwt
+  - mono-traversable
+  - lens-aeson
 
 other-extensions:
   - GeneralizedNewtypeDeriving

routes

@@ -16,6 +16,7 @@
 --    !registered     -- participant for this course (no effect outside of courses)
 --    !participant    -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
 --    !owner          -- part of the group of owners of this submission
+--    !self           -- route refers to the currently logged in user themselves
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
@@ -39,6 +40,7 @@
 /users/#CryptoUUIDUser        AdminUserR        GET POST
 /users/#CryptoUUIDUser/delete AdminUserDeleteR      POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
+/users/#CryptoUUIDUser/notifications UserNotificationR GET POST      !self
 /admin                        AdminR            GET
 /admin/features               AdminFeaturesR    GET POST
 /admin/test                   AdminTestR        GET POST
@@ -74,10 +76,12 @@
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
+  /lecturer-invite/#UserEmail CLecInviteR     GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
+  /communication              CCommR          GET POST
   /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials !corrector
@@ -100,6 +104,7 @@
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner !corrector
     /correctors                 SCorrR        GET POST
     /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
+    /corrector-invite/#UserEmail SCorrInviteR     GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 

src/Application.hs

@@ -101,7 +101,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
 makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
-makeFoundation appSettings@AppSettings{..} = do
+makeFoundation appSettings'@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
@@ -141,7 +141,7 @@ makeFoundation appSettings@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -153,13 +153,14 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
           (error "widgetMemcached forced in tempFoundation")
+          (error "JSONWebKeySet forced in tempFoundation")
         logFunc loc src lvl str = do
           f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
           f loc src lvl str
 
     flip runLoggingT logFunc $ do
       $logDebugS "InstanceID" $ UUID.toText appInstanceID
-      -- logDebugS "Configuration" $ tshow appSettings
+      -- logDebugS "Configuration" $ tshow appSettings'
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
@@ -177,8 +178,9 @@ makeFoundation appSettings@AppSettings{..} = do
       appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
+      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet
 
       handleJobs foundation
 
@@ -265,7 +267,7 @@ makeLogWare app = do
       logger <- readTVarIO . snd $ appLogger app
       logWare <- mkRequestLogger def
         { outputFormat = bool
-            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
             (Detailed True)
             logDetailed
         , destination = Logger $ loggerSet logger
@@ -287,8 +289,8 @@ makeLogWare app = do
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings
-    & setPort (appPort $ appSettings foundation)
+    & setPort (foundation ^. _appPort)
-    & setHost (appHost $ appSettings foundation)
+    & setHost (foundation ^. _appHost)
     & setOnException (\_req e ->
         when (defaultShouldDisplayException e) $ do
           logger <- readTVarIO . snd $ appLogger foundation
@@ -384,6 +386,6 @@ addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
 addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
-  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
+  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
   (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Auth/LDAP.hs

@@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
                   ]
 
 -- ldapConfig :: UniWorX -> LDAPConfig
--- ldapConfig _app@(appSettings -> settings) = LDAPConfig
+-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
 --   { usernameFilter = \u -> principalName <> "=" <> u
 --   , identifierModifier
 --   , ldapUri = appLDAPURI settings

src/CryptoID.hs

@@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..
 import Data.Aeson.Encoding (text)
 
 
+instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
+  type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
+  cryptoIDKey f = ask >>= f
+
+
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId
@@ -53,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
   parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
   fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
-
-
-newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
-  deriving (Show, Read, Eq)
-
-pattern NewSubmission :: SubmissionMode
-pattern NewSubmission = SubmissionMode Nothing
-pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
-pattern ExistingSubmission cID = SubmissionMode (Just cID)
-
-instance PathPiece SubmissionMode where
-    fromPathPiece "new" = Just $ SubmissionMode Nothing
-    fromPathPiece s     = SubmissionMode . Just <$> fromPathPiece s
-
-    toPathPiece (SubmissionMode Nothing)  = "new"
-    toPathPiece (SubmissionMode (Just x)) = toPathPiece x
-
-

src/Data/Aeson/Types/Instances.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Aeson.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson.Types (Parser, Value)
+import Control.Monad.Catch
+
+import Data.Binary (Binary)
+
+import Data.HashMap.Strict.Instances ()
+import Data.Vector.Instances ()
+
+
+instance MonadThrow Parser where
+  throwM = fail . show
+
+
+instance Binary Value

src/Data/HashMap/Strict/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashMap.Strict.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Binary (Binary(..))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+
+
+instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
+  put = put . HashMap.toList
+  get = HashMap.fromList <$> get

src/Data/HashSet/Instances.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashSet.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
+
+import Data.Binary (Binary(..))
+
+
+instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
+  get = HashSet.fromList <$> get
+  put = put . HashSet.toList

src/Data/NonNull/Instances.hs

@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.NonNull.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance ToJSON a => ToJSON (NonNull a) where
+  toJSON = toJSON . toNullable
+
+instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
+  parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable
+
+
+instance Hashable a => Hashable (NonNull a) where
+  hashWithSalt s = hashWithSalt s . toNullable
+
+
+instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
+  get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
+  put = Binary.put . toNullable

src/Data/Set/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Set.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+instance (Ord a, Hashable a) => Hashable (Set a) where
+  hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs

src/Data/Time/Clock/Instances.hs

@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Clock.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Time.Clock
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+deriving instance Generic UTCTime
+
+
+instance Binary Day where
+  get = ModifiedJulianDay <$> Binary.get
+  put = Binary.put . toModifiedJulianDay
+
+instance Binary DiffTime where
+  get = fromRational <$> Binary.get
+  put = Binary.put . toRational
+  
+instance Binary UTCTime

src/Data/Universe/TH.hs

@@ -0,0 +1,69 @@
+module Data.Universe.TH
+  ( finiteEnum
+  , deriveUniverse
+  , deriveFinite
+  ) where
+
+import Prelude
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+import Data.Universe
+import Data.Universe.Helpers (interleave)
+
+import Control.Monad (unless)
+
+import Data.List (elemIndex)
+
+
+finiteEnum :: Name -> DecsQ
+-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances
+finiteEnum tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+
+  let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
+      tUniverse = [e|universeF :: [$(datatype)]|]
+  
+  [d|
+    instance Bounded $(datatype) where
+      minBound = head $(tUniverse)
+      maxBound = last $(tUniverse)
+
+    instance Enum $(datatype) where
+      toEnum n
+        | n >= 0
+        , n < length $(tUniverse)
+        = $(tUniverse) !! n
+        | otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds"
+      fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse)
+
+      enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))]
+      enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))]
+    |]
+
+deriveUniverse, deriveFinite :: Name -> DecsQ
+deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
+deriveFinite tName = fmap concat . sequence $
+  [ deriveUniverse' [e|concat|] [e|universeF|] tName
+  , do
+      DatatypeInfo{..} <- reifyDatatype tName
+      [d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|]
+  ]
+
+deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
+deriveUniverse' interleaveExp universeExp tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+
+  let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
+      consUniverse ConstructorInfo{..} = do
+        unless (null constructorVars) $
+          fail "Constructors with variables no supported"
+
+        foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
+
+  pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
+    [ funD 'universe
+      [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
+      ]
+    ]

src/Data/Vector/Instances.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Vector.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance Binary a => Binary (Vector a) where
+  get = Vector.fromList <$> Binary.get
+  put = Binary.put . Vector.toList

src/Database/Persist/TH/Directory.hs

@@ -2,26 +2,35 @@ module Database.Persist.TH.Directory
   ( persistDirectoryWith
   ) where
 
-import ClassyPrelude hiding (mapM_, toList)
+import ClassyPrelude
 
 import Database.Persist.TH (parseReferences)
 import Database.Persist.Quasi (PersistSettings)
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax hiding (lift)
 
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import qualified System.IO as SIO
 
+import System.FilePath
 import qualified System.Directory.Tree as DirTree
 
-import Data.Foldable (Foldable(..), mapM_)
+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
+
+import Control.Lens
+  
 
 persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
 persistDirectoryWith settings dir = do
-  files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do
+  files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
-    h <- SIO.openFile fp SIO.ReadMode
+    fn <- MaybeT . return . fromNullable $ takeFileName fp
-    SIO.hSetEncoding h SIO.utf8_bom
+    guard . not $ head fn == '.'
-    Text.hGetContents h
+    guard . not $ head fn == '#' && last fn == '#'
-  mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files
+
+    lift $ do
+      h <- SIO.openFile fp SIO.ReadMode
+      SIO.hSetEncoding h SIO.utf8_bom
+      Text.hGetContents h
+  mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
   
-  parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files
+  parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files

src/Database/Persist/Types/Instances.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Database.Persist.Types
+
+instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
+  s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal

src/Foundation.hs

@@ -43,6 +43,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
+import qualified Data.HashSet as HashSet
 
 import Data.List (nubBy)
 
@@ -55,12 +56,12 @@ import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
 
-import Control.Monad.Except (MonadError(..), runExceptT)
+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
 import Control.Monad.Writer.Class (MonadWriter(..))
-import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
+import Control.Monad.Memo.Class (MonadMemo(..), for4)
 import qualified Control.Monad.Catch as C
 
 import Handler.Utils.StudyFeatures
@@ -77,6 +78,7 @@ import qualified Yesod.Auth.Message as Auth
 import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Jose.Jwk as Jose
 
 import qualified Database.Memcached.Binary.IO as Memcached
 import Data.Bits (Bits(zeroBits))
@@ -96,6 +98,8 @@ instance DisplayAble TermId where
 instance DisplayAble SchoolId where
   display = CI.original . unSchoolKey
 
+type SMTPPool = Pool SMTPConnection
+
 -- infixl 9 :$:
 -- pattern a :$: b = a b
 
@@ -104,7 +108,7 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings        :: AppSettings
+    { appSettings'       :: AppSettings
     , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool        :: ConnectionPool -- ^ Database connection pool.
     , appSmtpPool        :: Maybe SMTPPool
@@ -119,9 +123,16 @@ data UniWorX = UniWorX
     , appCronThread      :: TMVar (ReleaseKey, ThreadId)
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
+    , appJSONWebKeySet   :: Jose.JwkSet
     }
 
-type SMTPPool = Pool SMTPConnection
+makeLenses_ ''UniWorX
+instance HasInstanceID UniWorX InstanceId where
+  instanceID = _appInstanceID
+instance HasJSONWebKeySet UniWorX Jose.JwkSet where
+  jsonWebKeySet = _appJSONWebKeySet
+instance HasAppSettings UniWorX where
+  appSettings = _appSettings'
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -137,8 +148,10 @@ type SMTPPool = Pool SMTPConnection
 -- type Widget    = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+deriving instance Generic (Route UniWorX)
+
 -- | Convenient Type Synonyms:
-type DB a = YesodDB UniWorX a
+type DB = YesodDB UniWorX
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
 type MailM a = MailT (HandlerT UniWorX IO) a
@@ -173,8 +186,9 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- Convenience Type for Messages
+-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
-type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers
+type IntMaybe  = Maybe Int
+type TextList  = [Text]
 
 -- | Convenience function for i18n messages definitions
 maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text  -> Text
@@ -239,9 +253,13 @@ embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
-embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
 embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
 embedRenderMessage ''UniWorX ''LecturerType id
+embedRenderMessage ''UniWorX ''SubmissionModeDescr
+  $ let verbMap [_, _, "None"] = "NoSubmissions"
+        verbMap [_, _, v] = v <> "Submissions"
+        verbMap _ = error "Invalid number of verbs"
+     in verbMap . splitCamel
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -385,25 +403,30 @@ appLanguagesOpts = do
 
 
 -- Access Control
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
+
+
 data AccessPredicate
-  = APPure     (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
+  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
-  | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
+  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
-  | APDB       (Route UniWorX -> Bool -> DB AuthResult)
+  | APDB       (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult)
 
 class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
-  evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult
+  evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 
 instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
-  evalAccessPred aPred r w = liftHandlerT $ case aPred of
+  evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
-    (APPure    p) -> runReader (p r w) <$> getMsgRenderer
+    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
-    (APHandler p) -> p r w
+    (APHandler p) -> p aid r w
-    (APDB      p) -> runDB $ p r w
+    (APDB      p) -> runDB $ p aid r w
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
-  evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
+  evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
-    (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
+    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
-    (APHandler p) -> lift $ p r w
+    (APHandler p) -> lift $ p aid r w
-    (APDB      p) -> p r w
+    (APDB      p) -> p aid r w
 
 
 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@@ -424,16 +447,57 @@ trueAR = const Authorized
 falseAR = Unauthorized . ($ MsgUnauthorized) . render
 
 trueAP, falseAP :: AccessPredicate
-trueAP  = APPure . const . const $ trueAR <$> ask
+trueAP  = APPure . const . const . const $ trueAR <$> ask
-falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
+falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
+
+
+askTokenUnsafe :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadLogger m
+                  , MonadCatch m
+                  )
+               => ExceptT AuthResult m (BearerToken (UniWorX))
+-- | This performs /no/ meaningful validation of the `BearerToken`
+--
+-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
+askTokenUnsafe = $cachedHere $ do
+  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
+  catch (decodeToken jwt) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> do
+      $logWarnS "AuthToken" $ tshow other
+      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
+
+validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
+validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
+  where
+    validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
+    validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
+      guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+
+      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
+      guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
+      authorityVal <- do
+        dnf <- either throwM return $ routeAuthTags route
+        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
+      guardExceptT (is _Authorized authorityVal) authorityVal
+
+      whenIsJust tokenAddAuth $ \addDNF -> do
+        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
+        guardExceptT (is _Authorized additionalVal) additionalVal
+
+      return Authorized
 
 
 tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
-tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
+tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   -- Courses: access only to school admins
   CourseR tid ssh csh _ -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
       E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
       E.where_  $ userAdmin E.^. UserAdminUser E.==. E.val authId
@@ -445,13 +509,15 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
     return Authorized
   -- other routes: access to any admin is granted here
   _other -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
+  lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
+tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
-    myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
     uid <- decrypt cID
     otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
     otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
@@ -459,21 +525,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
     guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
     return Authorized
   r -> $unsupportedAuthPredicate AuthNoEscalation r
-tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
+tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute
-  allow <- appAllowDeprecated . appSettings <$> getYesod
+  allow <- view _appAllowDeprecated
   return $ bool (Unauthorized "Deprecated Route") Authorized allow
-tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
+tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
 #ifdef DEVELOPMENT
   return Authorized
 #else
   return $ Unauthorized "Route under development"
 #endif
-tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
+tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
-     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
        E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
        E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
@@ -485,11 +551,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
      return Authorized
   -- lecturer for any school will do
   _ -> exceptT return return $ do
-     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
      return Authorized
-tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
+tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
-  authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
     E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
     E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
@@ -516,7 +582,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
       return Authorized
-tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
+tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
   CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
@@ -542,8 +608,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
     mbc <- getBy $ TermSchoolCourseShort tid ssh csh
-    mAid <- lift maybeAuthId
+    registered <- case (mbc,mAuthId) of
-    registered <- case (mbc,mAid) of
       (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
       _ -> return False
     case mbc of
@@ -565,9 +630,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthTime r
-tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
+tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
       E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
       E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
@@ -578,7 +643,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthRegistered r
-tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
+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
@@ -640,14 +705,14 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     unauthorizedI MsgUnauthorizedParticipant
   r -> $unsupportedAuthPredicate AuthParticipant r
-tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
+tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
     Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCapacity r
-tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
+tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
     -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@@ -658,73 +723,81 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
       return E.countRows
     return Authorized
   r -> $unsupportedAuthPredicate AuthEmpty r
-tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
+tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
     Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     guard courseMaterialFree
     return Authorized
   r -> $unsupportedAuthPredicate AuthMaterials r
-tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
+tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
     return Authorized
   r -> $unsupportedAuthPredicate AuthOwner r
-tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
+tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
     sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     sub <- MaybeT $ get sid
     guard $ submissionRatingDone sub
     return Authorized
   r -> $unsupportedAuthPredicate AuthRated r
-tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
+tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
-    guard $ sheetSubmissionMode == UserSubmissions
+    guard $ is _Just submissionModeUser
     return Authorized
   r -> $unsupportedAuthPredicate AuthUserSubmissions r
-tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
+tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
-    guard $ sheetSubmissionMode == CorrectorSubmissions
+    guard submissionModeCorrector
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
-tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
+tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
+  referencedUser' <- decrypt referencedUser
+  case mAuthId of
+    Just uid
+      | uid == referencedUser' -> return Authorized
+    Nothing -> return AuthenticationRequired
+    _other  -> unauthorizedI MsgUnauthorizedSelf
+tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
     SystemMessage{..} <- MaybeT $ get smId
-    isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
+    let isAuthenticated = isJust mAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
   r -> $unsupportedAuthPredicate AuthAuthentication r
-tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
+tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
-tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
+tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
-newtype InvalidAuthTag = InvalidAuthTag Text
+defaultAuthDNF :: AuthDNF
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+defaultAuthDNF = PredDNF $ Set.fromList
-instance Exception InvalidAuthTag
+  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
+  , impureNonNull . Set.singleton $ PLVariable AuthToken
+  ]
 
-type DNF a = Set (NonNull (Set a))
+routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
-
-data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Universe SessionAuthTags
-instance Finite SessionAuthTags
-nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-
-routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
 -- ^ DNF up to entailment:
 --
 -- > (A_1 && A_2 && ...) OR' B OR' ...
 --
 -- > A OR' B := ((A |- B) ==> A) && (A || B)
-routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
+routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
   where
-    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
+    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
     partition' prev t
       | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
         = if
@@ -735,42 +808,63 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
       | otherwise
         = Left $ InvalidAuthTag t
 
-evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
-  = startEvalMemoT $ do
+  = do
-      mr <- lift getMsgRenderer
+      mr <- getMsgRenderer
       let
         authTagIsInactive = not . authTagIsActive
 
-        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
-        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
+        evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+          where
+            evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
+              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
+              evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
+
+        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
+        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
+        evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
+          Unauthorized _         -> return Authorized
+          AuthenticationRequired -> return AuthenticationRequired
+          Authorized             -> unauthorizedI plVar
 
         orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
         orAR' = shortCircuitM (is _Authorized) (orAR mr)
         andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-        evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
-        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
+        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
 
-      lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
+      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
 
-      result <- evalDNF $ filter (all authTagIsActive) authDNF
+      result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
 
-      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
+      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
-        whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
+        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
-          let pivots = filter authTagIsInactive conj
+          let pivots = filter (authTagIsInactive . plVar) conj
-          whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
-            lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
+            let pivots' = plVar <$> pivots
-            lift . tell $ Set.fromList pivots
+            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
+            tell $ Set.fromList pivots'
 
       return result
 
+evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+evalAccessFor mAuthId route isWrite = do
+  dnf <- either throwM return $ routeAuthTags route
+  fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
+
+evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
+evalAccessForDB = evalAccessFor
+
 evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
 evalAccess route isWrite = do
+  mAuthId <- liftHandlerT maybeAuthId
   tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
   dnf <- either throwM return $ routeAuthTags route
-  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
+  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
   result <$ tellSessionJson SessionInactiveAuthTags deactivated
 
 evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
@@ -796,17 +890,17 @@ instance Yesod UniWorX where
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
     approot = ApprootRequest $ \app req ->
-        case appRoot $ appSettings app of
+        case app ^. _appRoot of
             Nothing -> getApprootText guessApproot app req
             Just root -> root
 
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
-    makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
+    makeSessionBackend app = do
-      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
+      (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
-      return . Just $ clientSessionBackend appSessionKey getCachedDate
+      return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
 
-    maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength
+    maximumContentLength app _ = app ^. _appMaximumContentLength
 
     -- Yesod Middleware allows you to run code before and after each handler function.
     -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
@@ -865,7 +959,7 @@ instance Yesod UniWorX where
         encrypted :: ToJSON a => a -> Widget -> Widget
         encrypted plaintextJson plaintext = do
           canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-          shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
+          shouldEncrypt <- view _appEncryptErrors
           if
             | shouldEncrypt
             , not canDecrypt -> do
@@ -906,8 +1000,8 @@ instance Yesod UniWorX where
     isAuthorized = evalAccess
 
     addStaticContent ext _mime content = do
-      UniWorX{appWidgetMemcached, appSettings} <- getYesod
+      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
-      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
             touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
             add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
@@ -958,8 +1052,7 @@ siteLayout = siteLayout' . Just
 siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout' headingOverride widget = do
-  master <- getYesod
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
-  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
 
   isModal <- hasCustomHeader HeaderIsModal
 
@@ -1171,6 +1264,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
+  breadcrumb (CourseR tid ssh csh CCommR    ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
 
   breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
   breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit",    Just $ CSheetR tid ssh csh shn SShowR)
@@ -1414,6 +1508,16 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (AdminUserR cID) = [
+    MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuUserNotifications
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ UserNotificationR cID
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (InfoR) = [
     MenuItem
       { menuItemType  = PageActionPrime
@@ -1538,6 +1642,14 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuCourseCommunication
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType = PageActionSecondary
       , menuItemLabel = MsgMenuCourseEdit
@@ -1783,7 +1895,7 @@ pageActions (CorrectionsR) =
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
               isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -1792,10 +1904,9 @@ pageActions (CorrectionsR) =
               isLecturer = E.exists . E.from $ \lecturer -> E.where_
                     $ lecturer E.^. LecturerUser E.==. E.val uid
                 E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            E.where_ $ isCorrector' E.||. isLecturer
-                 E.&&. ( isCorrector' E.||. isLecturer )
+            return $ sheet E.^. SheetSubmissionMode
-            return E.countRows
+          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
-          return $ (sheetCount :: Int) /= 0
       }
   , MenuItem
       { menuItemType = PageActionPrime
@@ -1823,7 +1934,7 @@ pageActions (CorrectionsGradeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
               isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -1832,10 +1943,9 @@ pageActions (CorrectionsGradeR) =
               isLecturer = E.exists . E.from $ \lecturer -> E.where_
                     $ lecturer E.^. LecturerUser E.==. E.val uid
                 E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            E.where_ $ isCorrector' E.||. isLecturer
-                 E.&&. ( isCorrector' E.||. isLecturer )
+            return $ sheet E.^. SheetSubmissionMode
-            return E.countRows
+          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
-          return $ (sheetCount :: Int) /= 0
       }
   ]
 pageActions _ = []
@@ -2074,7 +2184,7 @@ instance YesodAuth UniWorX where
             _other -> return res
 
       $logDebugS "auth" $ tshow Creds{..}
-      UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
+      UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
       flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
         Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
@@ -2129,6 +2239,7 @@ instance YesodAuth UniWorX where
               , userDownloadFiles        = userDefaultDownloadFiles
               , userNotificationSettings = def
               , userMailLanguages        = def
+              , userTokensIssuedAfter    = Nothing
               , ..
               }
             userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
@@ -2193,7 +2304,7 @@ instance YesodAuth UniWorX where
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
-    authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
+    authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
@@ -2218,19 +2329,23 @@ unsafeHandler f h = do
 
 
 instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ appMailFrom . appSettings
+  defaultFromAddress = getsYesod $ view _appMailFrom
-  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
-  mailVerp = getsYesod $ appMailVerp . appSettings
+  mailVerp = getsYesod $ view _appMailVerp
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
     withResource pool act
   mailT ctx mail = defMailT ctx $ do
-    void setMailObjectId
+    void setMailObjectIdRandom
     setDateCurrent
-    replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
+    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
 
-    mail <* setMailSmtpData
+    (mRes, smtpData) <- listen mail
+    unless (view _MailSmtpDataSet smtpData)
+      setMailSmtpData
+
+    return mRes
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

src/Handler/Admin.hs

@@ -205,7 +205,7 @@ postAdminTestR = do
 
   -- The actual call to @massInput@ is comparatively simple:
 
-  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing
 
 
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
@@ -286,9 +286,6 @@ instance Button UniWorX ButtonAdminStudyTerms where
   btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
-sessionKeyNewStudyTerms :: Text
-sessionKeyNewStudyTerms = "key-new-study-terms"
-
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
@@ -304,7 +301,7 @@ postAdminFeaturesR = do
         unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
         let newKeys = map (StudyTermsKey' . fst) infAccepted
-        setSessionJson sessionKeyNewStudyTerms newKeys
+        setSessionJson SessionNewStudyTerms newKeys
         if  | null infAccepted
               -> addMessageI Info      MsgNoCandidatesInferred
             | otherwise
@@ -322,7 +319,7 @@ postAdminFeaturesR = do
         Candidates.conflicts
       _other -> runDB Candidates.conflicts
 
-    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
       , ((), candidateTable)) <- runDB $ (,,)

src/Handler/Corrections.hs

@@ -80,9 +80,6 @@ courseIs cid  (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO
 sheetIs :: Key Sheet -> CorrectionTableWhere
 sheetIs shid  ((_course `E.InnerJoin`  sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
 
-submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
-submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-
 
 -- Columns
 colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@@ -350,7 +347,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
       , dbParamsFormAttrs = []
       , dbParamsFormSubmit = FormSubmit
       , dbParamsFormAdditional = \frag -> do
-          (actionRes, action) <- multiAction actions Nothing
+          (actionRes, action) <- multiActionM actions "" Nothing mempty
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = _1
@@ -702,7 +699,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
   ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
-       areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
+       areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
 
   case uploadRes of
     FormMissing -> return ()
@@ -733,7 +730,7 @@ getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
 getCorrectionsCreateR = postCorrectionsCreateR
 postCorrectionsCreateR = do
   uid <- requireAuthId
-  let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+  let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
         E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
         let
           isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -742,10 +739,9 @@ postCorrectionsCreateR = do
           isLecturer = E.exists . E.from $ \lecturer -> E.where_
                 $ lecturer E.^. LecturerUser E.==. E.val uid
             E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-        E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+        E.where_ $ isCorrector E.||. isLecturer
-             E.&&. ( isCorrector E.||. isLecturer )
         E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
-        return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
+        return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
       mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
       mkOptList opts = do
         opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts

src/Handler/Course.hs

@@ -9,6 +9,7 @@ import Utils.Form
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Course
+import Handler.Utils.Communication
 import Handler.Utils.Form.MassInput
 import Handler.Utils.Delete
 import Handler.Utils.Database
@@ -27,12 +28,15 @@ import Data.Monoid (Last(..))
 
 import Data.Maybe (fromJust)
 import qualified Data.Set as Set
+import Data.Map ((!))
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import Jobs.Queue
+
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
 
@@ -416,7 +420,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = courseToForm oldTemplate [] in
+            let newTemplate = courseToForm oldTemplate [] [] in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -445,13 +449,14 @@ postCEditR = pgCEditR
 
 pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 pgCEditR tid ssh csh = do
-  courseLecs <- runDB $ do
+  courseData <- runDB $ do
-      mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
-      mbLecs   <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
-      return $ (,) <$> mbCourse <*> mbLecs
+      mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType]
+      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
 
 
 getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -479,7 +484,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         , cfTerm     = tid
         } -> do -- create new course
           now <- liftIO getCurrentTime
-          insertOkay <- runDB $ do
+          insertOkay <- runDBJobs $ do
             insertOkay <- insertUnique Course
               { courseName            = cfName     res
               , courseDescription     = cfDesc     res
@@ -495,7 +500,11 @@ courseEditHandler miButtonAction mbCourseForm = do
               , courseDeregisterUntil = cfDeRegUntil res
               }
             whenIsJust insertOkay $ \cid -> do
-                forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                forM_ (cfLecturers res) $ \case
+                  Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                  Left (lEmail, mLTy) -> do
+                    insert_ $ LecturerInvitation lEmail cid mLTy
+                    queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
                 insert_ $ CourseEdit aid now cid
             return insertOkay
           case insertOkay of
@@ -513,7 +522,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         } -> do -- edit existing course
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
-          success <- runDB $ do
+          success <- runDBJobs $ do
             old <- get cid
             case old of
               Nothing -> addMessageI Error MsgInvalidInput $> False
@@ -536,7 +545,16 @@ courseEditHandler miButtonAction mbCourseForm = do
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     deleteWhere [LecturerCourse ==. cid]
-                    forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                    deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
+                    forM_ (cfLecturers res) $ \case
+                      Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                      Left (lEmail, mLTy) -> do
+                        insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
+                        case insertRes of
+                          Just _  ->
+                            queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
+                          Nothing -> 
+                            updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
@@ -564,11 +582,11 @@ data CourseForm = CourseForm
         , cfRegFrom    :: Maybe UTCTime
         , cfRegTo      :: Maybe UTCTime
         , cfDeRegUntil :: Maybe UTCTime
-        , cfLecturers  :: [(UserId, LecturerType)]
+        , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> [Lecturer] -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs = CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -582,7 +600,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm
     , cfRegFrom    = courseRegisterFrom
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
-    , cfLecturers  = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+    , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+                  ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
     }
 
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@@ -609,29 +628,30 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                 | otherwise ->  termsSetField [cfTerm cform]
           _allOtherCases -> return termsAllowedField
 
-    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
+    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
         miAdd _ _ nudge btn = Just $ \csrf -> do
           (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
           addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
           let addRes'' = case (,) <$> addRes <*> addRes' of
-                FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
+                FormSuccess (CI.mk -> email, mLid) ->
-                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
+                  let new = maybe (Left email) Right mLid
-                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
+                  in  FormSuccess $ \prev -> if
-                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
+                        | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
+                        | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                 FormFailure errs -> FormFailure errs
                 FormMissing -> FormMissing
-              addView'  = toWidget csrf >> fvInput addView >> fvInput btn
+              addView' = $(widgetFile "course/lecturerMassInput/add")
           return (addRes'', addView')
 
-        miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
+        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ lid defType nudge = \csrf -> do
+        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
           User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
-          let lrwView' = [whamlet|$newline never
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-                  #{csrf}
+          return (Just <$> lrwRes,lrwView')
-                  ^{nameEmailWidget userEmail userDisplayName userSurname} #
+        miCell _ (Left lEmail) defType nudge = \csrf -> do
-                  ^{fvInput lrwView}
+          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-                |]
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
           return (lrwRes,lrwView')
 
         miDelete :: ListLength   -- ^ Current shape
@@ -642,14 +662,34 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
         miAllowAdd _ _ _ = True
 
+        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+        miAddEmpty _ _ _ = Set.empty
 
-        lecturerForm :: AForm Handler [(UserId,LecturerType)]
+        miLayout :: ListLength
-        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
+                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                 -> Map ListPosition Widget -- ^ Cell widgets
+                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                 -> Widget
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
+
+        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
                 True
-                (Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
+                (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
                 mempty
+          where
+            liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
+            liftEither (Right lid  , Just lType) = Right (lid   , lType )
+            liftEither (Left lEmail, mLType    ) = Left  (lEmail, mLType)
+            liftEither _                         = error "liftEither: lecturerForm produced output it should not have been able to"
+
+            unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
+            unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
+            unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
     (newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
@@ -717,7 +757,7 @@ validateCourse CourseForm{..} = do
           ( NTop cfRegFrom <= NTop cfDeRegUntil
           , MsgCourseDeregistrationEndMustBeAfterStart
           )
-        , ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
           , MsgCourseUserMustBeLecturer
           )
         ] ]
@@ -821,7 +861,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
 
-data CourseUserAction = CourseUserDeregister
+data CourseUserAction = CourseUserSendMail | CourseUserDeregister
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe CourseUserAction
@@ -928,6 +968,9 @@ postCUsersR tid ssh csh = do
     table <- makeCourseUserTable cid colChoices psValidator
     return (ent, numParticipants, table)
   formResult participantRes $ \case
+    (CourseUserSendMail, selectedUsers) -> do
+        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
+        redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
     (CourseUserDeregister,selectedUsers) -> do
         nrDel <- runDB $ deleteWhereCount
           [ CourseParticipantCourse ==. cid
@@ -1039,3 +1082,103 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- If they are shared, adjust MsgCourseUserNoteTooltip
 getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"
+
+
+getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCCommR = postCCommR
+postCCommR tid ssh csh = do
+  jSender <- requireAuthId
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+
+  commR CommunicationRoute
+    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
+    , crUltDest    = SomeRoute $ CourseR tid ssh csh CCommR
+    , crJobs       = \Communication{..} -> do
+        let jSubject = cSubject
+            jMailContent = cBody
+            jCourse = cid
+            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
+        jMailObjectUUID <- liftIO getRandom
+        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
+          Left email -> return . Address Nothing $ CI.original email
+          Right rid  -> userAddress <$> getJust rid
+        forM_ allRecipients $ \jRecipientEmail ->
+          yield JobSendCourseCommunication{..}
+    , crRecipients = Map.fromList
+      [ ( RGCourseParticipants
+        , E.from $ \(user `E.InnerJoin` participant) -> do
+            E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
+            E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+            return user
+        )
+      , ( RGCourseLecturers
+        , E.from $ \(user `E.InnerJoin` lecturer) -> do
+            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+            return user
+        )
+      , ( RGCourseCorrectors
+        , E.from $ \user -> do
+            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
+              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
+              E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+            return user
+        )
+      ]
+    , crRecipientAuth = Just $ \uid -> do
+        cID <- encrypt uid
+        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
+    }
+
+ 
+data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonLecInvite
+instance Finite ButtonLecInvite
+
+nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonLecInvite id
+
+instance Button UniWorX ButtonLecInvite where
+  btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
+  btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
+
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
+getCLecInviteR = postCLecInviteR
+postCLecInviteR tid ssh csh email = do
+  uid <- requireAuthId
+  (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do
+    cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    iRes <- getBy404 $ UniqueLecturerInvitation email cid
+    return (cRes, iRes)
+
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do
+    (ltRes, ltView) <- case lecturerInvitationType of
+      Nothing -> mreq (selectField optionsFinite) "" Nothing
+      Just lType -> mforced (selectField optionsFinite) "" lType
+    (btnRes, btnWdgt) <- buttonForm mempty
+    return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
+
+  let btnWidget = wrapForm btnInnerWidget def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
+        , formSubmit = FormNoSubmit
+        }
+
+  formResult btnResult $ \case
+    (lType, BtnLecInvAccept) -> do
+      runDB $ do
+        delete liId
+        insert_ $ Lecturer uid cid lType
+      MsgRenderer mr <- getMsgRenderer
+      addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh
+      redirect $ CourseR tid ssh csh CShowR
+    (_, BtnLecInvDecline) -> do
+      runDB $
+        delete liId
+      addMessageI Info $ MsgLecturerInvitationDeclined csh
+      redirect HomeR
+
+  siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do
+    setTitleI . MsgCourseLecInviteHeading $ CI.original courseName
+    $(widgetFile "courseLecInvite")

src/Handler/Help.hs

@@ -25,7 +25,7 @@ data HelpForm = HelpForm
 helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
 helpForm mr mReferer mUid = HelpForm
     <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
-    <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
+    <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
     <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
     <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing)
   where
@@ -47,14 +47,14 @@ postHelpR = do
   isModal <- hasCustomHeader HeaderIsModal
   MsgRenderer mr <- getMsgRenderer
 
-  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
+  ((res,formWidget'),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
 
   formResultModal res HelpR $ \HelpForm{..} -> do
     now <- liftIO getCurrentTime
     hfReferer' <- traverse toTextUrl hfReferer
     queueJob' JobHelpRequest
-      { jSender      = hfUserId
+      { jHelpSender  = hfUserId
-      , jHelpSubject = hfSubject
+      , jSubject     = hfSubject
       , jHelpRequest = hfRequest
       , jRequestTime = now
       , jReferer     = hfReferer'
@@ -63,8 +63,9 @@ postHelpR = do
 
   defaultLayout $ do
     setTitleI MsgHelpTitle
-    wrapForm $(widgetFile "help") def
+    let formWidget = wrapForm formWidget' def
-      { formAction = Just $ SomeRoute HelpR
+          { formAction = Just $ SomeRoute HelpR
-      , formEncoding = formEnctype
+          , formEncoding = formEnctype
-      , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+          , formAttrs = [ ("data-ajax-submit", "") | isModal ]
-      }
+          }
+    $(widgetFile "help")

src/Handler/Profile.hs

@@ -42,11 +42,10 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
                                    & setTooltip MsgDownloadFilesTip
                                 ) (stgDownloadFiles <$> template)
         <*  aformSection MsgFormNotifications
-        <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
+        <*> notificationForm (stgNotificationSettings <$> template)
     return (result, widget) -- no validation required here
   where
     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
-    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 --
 -- Version with proper grouping:
 --
@@ -76,6 +75,31 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
 --       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
 --     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
+notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
+notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
+  where
+    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
+
+
+data ButtonResetTokens = BtnResetTokens
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonResetTokens
+instance Finite ButtonResetTokens
+
+nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1
+
+embedRenderMessage ''UniWorX ''ButtonResetTokens id
+instance Button UniWorX ButtonResetTokens where
+  btnClasses BtnResetTokens = [BCIsButton, BCDanger]
+
+data ProfileAnchor = ProfileSettings | ProfileResetTokens
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe ProfileAnchor
+instance Finite ProfileAnchor
+
+nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
+
+
 getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR
 postProfileR = do
@@ -89,38 +113,60 @@ postProfileR = do
         , stgDownloadFiles = userDownloadFiles
         , stgNotificationSettings = userNotificationSettings
         }
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
-  case res of
-    (FormSuccess SettingsForm{..}) -> do
-        runDB $ do
-          update uid  [ UserMaxFavourites  =. stgMaxFavourties
-                      , UserTheme          =. stgTheme
-                      , UserDateTimeFormat =. stgDateTime
-                      , UserDateFormat     =. stgDate
-                      , UserTimeFormat     =. stgTime
-                      , UserDownloadFiles  =. stgDownloadFiles
-                      , UserNotificationSettings =. stgNotificationSettings
-                      ]
-          when (stgMaxFavourties < userMaxFavourites) $ do
-            -- prune Favourites to user-defined size
-            oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
-                                      [ Desc CourseFavouriteTime
-                                      , OffsetBy stgMaxFavourties
-                                      ]
-            mapM_ delete oldFavs
-        addMessageI Info MsgSettingsUpdate
-        redirect ProfileR -- TODO: them change does not happen without redirect
 
-    (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
+  formResult res $ \SettingsForm{..} -> do
-    _ -> return ()
+    runDB $ do
+      update uid  [ UserMaxFavourites  =. stgMaxFavourties
+                  , UserTheme          =. stgTheme
+                  , UserDateTimeFormat =. stgDateTime
+                  , UserDateFormat     =. stgDate
+                  , UserTimeFormat     =. stgTime
+                  , UserDownloadFiles  =. stgDownloadFiles
+                  , UserNotificationSettings =. stgNotificationSettings
+                  ]
+      when (stgMaxFavourties < userMaxFavourites) $ do
+        -- prune Favourites to user-defined size
+        oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
+                                  [ Desc CourseFavouriteTime
+                                  , OffsetBy stgMaxFavourties
+                                  ]
+        mapM_ delete oldFavs
+    addMessageI Info MsgSettingsUpdate
+    redirect $ ProfileR :#: ProfileSettings
+
+  ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
+
+  formResult tokenRes $ \BtnResetTokens -> do
+    now <- liftIO getCurrentTime
+    runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
+    addMessageI Info MsgTokensResetSuccess
+    redirect $ ProfileR :#: ProfileResetTokens
+
+  tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
 
   siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
     setTitle . toHtml $ "Profil " <> userIdent
-    let settingsForm = wrapForm formWidget def
+    let settingsForm = 
-          { formAction = Just $ SomeRoute ProfileR
+          wrapForm formWidget FormSettings
-          , formEncoding = formEnctype
+            { formMethod = POST
-          }
+            , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
-    $(widgetFile "profile")
+            , formEncoding = formEnctype
+            , formAttrs = []
+            , formSubmit = FormSubmit
+            , formAnchor = Just ProfileSettings
+            }
+        tokenForm =
+          wrapForm tokenFormWidget FormSettings
+            { formMethod = POST
+            , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
+            , formEncoding = tokenEnctype
+            , formAttrs = []
+            , formSubmit = FormNoSubmit
+            , formAnchor = Just ProfileResetTokens
+            }
+        tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
+    $(widgetFile "profile/profile")
 
 
 getProfileDataR :: Handler Html
@@ -469,9 +515,9 @@ mkCorrectionsTable =
         , sortable (toNothing "cload")  (i18nCell MsgCorProportion) $
             correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
         , sortable (toNothing "assigned")  (i18nCell MsgCorProportion) $
-            int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
+            int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
         , sortable (toNothing "corrected")  (i18nCell MsgCorProportion) $
-            int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
+            int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
         ]
 
       validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
@@ -533,3 +579,27 @@ postAuthPredsR = do
   siteLayoutMsg MsgAuthPredsActive $ do
     setTitleI MsgAuthPredsActive
     $(widgetFile "authpreds")
+
+
+getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
+getUserNotificationR = postUserNotificationR
+postUserNotificationR cID = do
+  uid <- decrypt cID
+  User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
+
+  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  mJwt <- askJwt
+  isModal <- hasCustomHeader HeaderIsModal
+  let formWidget = wrapForm nsInnerWdgt def
+        { formAction = Just . SomeRoute $ UserNotificationR cID
+        , formEncoding = nsEnc
+        , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+        }
+
+  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
+    lift . runDB $ update uid [ UserNotificationSettings =. ns ]
+    tell . pure =<< messageI Success MsgNotificationSettingsUpdate
+
+  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
+    setTitleI $ MsgNotificationSettingsHeading userDisplayName
+    formWidget

src/Handler/Sheet.hs

@@ -1,6 +1,9 @@
 module Handler.Sheet where
 
 import Import
+
+import Jobs.Queue
+
 import System.FilePath (takeFileName)
 
 import Utils.Sheet
@@ -9,20 +12,19 @@ import Handler.Utils
 import Handler.Utils.Table.Cells
 import Handler.Utils.SheetType
 import Handler.Utils.Delete
+import Handler.Utils.Form.MassInput
 
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
 --
 -- import Colonnade hiding (fromMaybe, singleton, bool)
-import qualified Yesod.Colonnade as Yesod
-import Text.Blaze (text)
 --
 -- import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
 -- import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
 -- import qualified Database.Esqueleto.Internal.Sql as E
@@ -42,7 +44,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import Data.Map (Map, (!?))
+import Data.Map (Map, (!))
 
 import Data.Monoid (Any(..))
 
@@ -69,8 +71,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSubmissionMode :: SheetSubmissionMode
+      , sfSubmissionMode :: SubmissionMode
-      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe (Source Handler (Either FileId File))
@@ -110,8 +111,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
-      <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (Upload True))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
@@ -462,7 +462,6 @@ getSheetNewR tid ssh csh = do
             , sfActiveFrom   = addTime     sheetActiveFrom
             , sfActiveTo     = addTime     sheetActiveTo
             , sfSubmissionMode = sheetSubmissionMode
-            , sfUploadMode   = sheetUploadMode
             , sfSheetF       = Nothing
             , sfHintFrom     = addTime <$> sheetHintFrom
             , sfHintF        = Nothing
@@ -495,7 +494,6 @@ getSEditR tid ssh csh shn = do
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
         , sfSubmissionMode = sheetSubmissionMode
-        , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@@ -537,7 +535,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetActiveTo       = sfActiveTo
               , sheetHintFrom       = sfHintFrom
               , sheetSolutionFrom   = sfSolutionFrom
-              , sheetUploadMode     = sfUploadMode
               , sheetSubmissionMode = sfSubmissionMode
               , sheetAutoDistribute = fromMaybe False oldAutoDistribute
               }
@@ -614,7 +611,7 @@ data CorrectorForm = CorrectorForm
   , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
   }
 
-type Loads = Map UserId (CorrectorState, Load)
+type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
 
 defaultLoads :: SheetId -> DB Loads
 -- ^ Generate `Loads` in such a way that minimal editing is required
@@ -637,164 +634,152 @@ defaultLoads shid = do
     return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
   where
     toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
-    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
+    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
+correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector))
-correctorForm shid = do
+correctorForm shid = wFormToAForm $ do
-  cListIdent <- newFormIdent
+  Just currentRoute <- liftHandlerT getCurrentRoute
-  let
+  userId <- liftHandlerT requireAuthId
-    guardNonDeleted :: UserId -> Handler (Maybe UserId)
+  MsgRenderer mr <- getMsgRenderer
-    guardNonDeleted uid = do
+
-      CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
-      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
-      return $ bool Just (const Nothing) (isJust deleted) uid
-  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
   let
     currentLoads :: DB Loads
-    currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+    currentLoads = Map.union
-  (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
+      <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
-  loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
+      <*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] [])
-    | Map.null currentLoads'
+  (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
-    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
-    | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
 
-  deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
+  isWrite <- liftHandlerT $ isWriteRequest currentRoute
-
-  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
-      didDelete = any (flip Set.member deletions) formCIDs
-
-  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
-  (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
-  let
-    tutorField :: Field Handler [UserEmail]
-    tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
-      { fieldView = \theId name attrs _val isReq -> asWidgetT $ do
-          listIdent <- newIdent
-          userId <- handlerToWidget requireAuthId
-          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
-            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
-            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
-            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
-            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
-            return $ user E.^. UserEmail
-          [whamlet|
-            $newline never
-            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
-            <datalist id=#{listIdent}>
-              $forall E.Value prev <- previousCorrectors
-                <option value=#{prev}>
-          |]
-      }
-  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
-
-  loads <- case addTutRes of
-    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
-      mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
-      case mUid of
-        Nothing  -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
-        Just uid
-          | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
-          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
-    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
-    _ -> return loads''
-
-  let deletions' = deletions `Set.difference` Map.keysSet loads
-
-  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
-    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
-    return $ (user E.^. UserId, user E.^. UserDisplayName)
 
   let
-    constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
+    applyDefaultLoads = Map.null currentLoads' && not isWrite
-    constructFields (uid, uname, (state, Load{..})) = do
+    loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
-      CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
+    loads
-      let
+      | applyDefaultLoads = defaultLoads'
-        fs name = ""
+      | otherwise         = currentLoads'
-          { fsName = Just $ tshow ciphertext <> "-" <> name
-          }
-        rationalField = convertField toRational fromRational doubleField
 
-      (stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
+  when (not (Map.null loads) && applyDefaultLoads) $
-      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
+    addMessageI Warning MsgCorrectorsDefaulted
-      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+
-      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
+  countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
+
+  let
+    previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
+    previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
+      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+      E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+      return user
+
+    miAdd :: ListPosition
+          -> Natural
+          -> (Text -> Text)
+          -> FieldView UniWorX
+          -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+    miAdd _ _ nudge submitView = Just $ \csrf -> do
+      (addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
+      let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
+            | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
+            , not $ null existing
+              -> FormFailure [mr MsgCorrectorExists]
+            | otherwise
+              -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
+      return (addRes', $(widgetFile "sheetCorrectors/add"))
+
+    miCell :: ListPosition
+           -> Either UserEmail UserId
+           -> Maybe (CorrectorState, Load)
+           -> (Text -> Text)
+           -> Form (CorrectorState, Load)
+    miCell _ userIdent initRes nudge csrf = do
+      (stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
+      (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
+      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
       let
-        cfResult :: FormResult (CorrectorState, Load)
+        res :: FormResult (CorrectorState, Load)
-        cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
+        res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
         tutRes'
           | FormSuccess True <- byTutRes  = Just <$> countTutRes
           | otherwise                     = Nothing <$ byTutRes
-        cfUserId = uid
+      identWidget <- case userIdent of
-        cfUserName = uname
+        Left email -> return . toWidget $ mailtoHtml email
-      return CorrectorForm{..}
+        Right uid -> do
+          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
+          return $ nameEmailWidget userEmail userDisplayName userSurname
+      return (res, $(widgetFile "sheetCorrectors/cell"))
 
-  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
 
-  mr <- getMessageRender
+    miDelete :: ListLength
+             -> ListPosition
+             -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
+    miDelete = miDeleteList
 
-  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
+    miAllowAdd :: ListPosition
+               -> Natural
+               -> ListLength
+               -> Bool
+    miAllowAdd _ _ _ = True
 
-  let
+    miAddEmpty :: ListPosition
-    corrColonnade = mconcat
+               -> Natural
-      [ headed (Yesod.textCell $ mr MsgCorrector)     $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+               -> ListLength
-      , headed (Yesod.textCell $ mr MsgCorState)      $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
+               -> Set ListPosition
-      , headed (Yesod.textCell $ mr MsgCorByTut)      $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
+    miAddEmpty _ _ _ = Set.empty
-      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
-      , headed (Yesod.textCell $ mr MsgDeleteRow)     $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
-      ]
-    corrResults
-      | FormSuccess (Just es) <- addTutRes
-      , not $ null es = FormMissing
-      | didDelete = FormMissing
-      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
-                                                  | CorrectorForm{..} <- corrData
-                                                  ]
-    idField CorrectorForm{..} = do
-      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
-      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
 
-    delField uid = do
+    miButtonAction :: forall p.
-      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
+                      PathPiece p
-      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
+                   => p
+                   -> Maybe (SomeRoute UniWorX)
+    miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
 
-  return ( (,) <$> autoDistributeRes <*> corrResults
+    miLayout :: ListLength
-         , [ autoDistributeView
+             -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
-           , countTutView
+             -> Map ListPosition Widget
-           , FieldView
+             -> Map ListPosition (FieldView UniWorX)
-             { fvLabel = text $ mr MsgCorrectors
+             -> Map (Natural, ListPosition) Widget
-             , fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
+             -> Widget
-             , fvId = ""
+    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
-             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
-             , fvErrors = Nothing
-             , fvRequired = True
-             }
-           , addTutView
-             { fvInput = [whamlet|
-                           <div>
-                             ^{fvInput addTutView}
-                             <button type=submit formnovalidate data-formnorequired>Hinzufügen
-                         |]
-             }
-           ])
 
-  -- Eingabebox für Korrektor hinzufügen
+    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
-  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+    postProcess = Set.fromList . map postProcess' . Map.elems
+      where
+        sheetCorrectorSheet = shid
+        sheetCorrectorInvitationSheet = shid
+
+        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
+        postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
+        postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
+
+  fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
 
 getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 postSCorrR = getSCorrR
 getSCorrR tid ssh csh shn = do
+  uid <- requireAuthId
   Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
 
-  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
+    (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
+        <*> correctorForm shid
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-    FormSuccess (autoDistribute, res') -> runDB $ do
+    FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
       update shid [ SheetAutoDistribute =. autoDistribute ]
-      deleteWhere [SheetCorrectorSheet ==. shid]
+      deleteWhere [ SheetCorrectorSheet ==. shid ]
-      insertMany_ $ Set.toList res'
+      deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
+      forM_ sheetCorrectors $ \case
+        Right shCor -> insert_ shCor
+        Left shCorInv -> do
+          insertRes <- insertBy shCorInv
+          case insertRes of
+            Right _ ->
+              void . queueDBJob $ JobCorrectorInvitation uid shCorInv
+            Left (Entity old _) ->
+               replace old shCorInv
       addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 
@@ -805,3 +790,49 @@ getSCorrR tid ssh csh shn = do
       , formEncoding = formEnctype
       }
 
+
+data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonCorrInvite
+instance Finite ButtonCorrInvite
+
+nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonCorrInvite id
+
+instance Button UniWorX ButtonCorrInvite where
+  btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
+  btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
+
+getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
+getSCorrInviteR = postSCorrInviteR
+postSCorrInviteR tid ssh csh shn email = do
+  uid <- requireAuthId
+  (Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
+    (sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
+    iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
+    return (cRes, sRes, iRes)
+
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm
+
+  let btnWidget = wrapForm btnInnerWidget def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
+        , formSubmit = FormNoSubmit
+        }
+
+  formResult btnResult $ \case
+    BtnCorrInvAccept -> do
+      runDB $ do
+        delete ciId
+        insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
+      addMessageI Success $ MsgCorrectorInvitationAccepted shn
+      redirect $ CSheetR tid ssh csh shn SShowR
+    BtnCorrInvDecline -> do
+      runDB $
+        delete ciId
+      addMessageI Info $ MsgCorrectorInvitationDeclined shn
+      redirect HomeR
+
+  siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
+    setTitleI $ MsgSheetCorrInviteHeading shn
+    $(widgetFile "sheetCorrInvite")

src/Handler/Submission.hs

@@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI
 
 getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSubmissionNewR = postSubmissionNewR
-postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
+postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing
 
 
 getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
 getSubShowR = postSubShowR
-postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
+postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid
 
 getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSubmissionOwnR tid ssh csh shn = do
@@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do
   cID <- encrypt sid
   redirect $ CSubmissionR tid ssh csh shn cID SubShowR
 
-submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
+submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
-submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
+submissionHelper tid ssh csh shn mcid = do
   (Entity uid userData) <- requireAuth
   msmid     <- traverse decrypt mcid
   actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits)
-  ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
+  ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
   let formWidget = wrapForm formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype

src/Handler/SystemMessage.hs

@@ -217,7 +217,7 @@ postMessageListR = do
                 , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
                 , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
                 ]
-          (actionRes, action) <- multiAction actions (Just SMActivate)
+          (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = id

src/Handler/Utils.hs

@@ -4,6 +4,8 @@ module Handler.Utils
 
 import Import
 
+import Utils.Lens
+
 import qualified Data.Text as T
 -- import qualified Data.Set (Set)
 import qualified Data.Set as Set
@@ -40,7 +42,7 @@ downloadFiles = do
   case mauth of
     Just (Entity _ User{..}) -> return userDownloadFiles
     Nothing -> do
-      AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
       return userDefaultDownloadFiles
 
 tidFromText :: Text -> Maybe TermId
@@ -99,7 +101,7 @@ wrapMailto (original -> email) linkText
 
 -- | Just show an email address in a standard way, for convenience inside hamlet files.
 mailtoHtml :: UserEmail -> Html
-mailtoHtml email = wrapMailto email $ toHtml email
+mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
 
 -- | Generic i18n text for "edited at sometime by someone"
 editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget

src/Handler/Utils/Communication.hs

@@ -0,0 +1,187 @@
+module Handler.Utils.Communication
+  ( RecipientGroup(..)
+  , CommunicationRoute(..)
+  , Communication(..)
+  , commR
+  -- * Re-Exports
+  , Job(..)
+  ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Form.MassInput
+import Utils.Lens
+
+import Jobs.Queue
+import Control.Monad.Trans.Reader (mapReaderT)
+
+import qualified Database.Esqueleto as E
+import qualified Data.CaseInsensitive as CI
+import Data.Map ((!), (!?))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Data.Aeson.TH
+import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
+
+
+data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe RecipientGroup
+instance Finite RecipientGroup
+nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''RecipientGroup id
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''RecipientGroup
+
+
+data RecipientCategory
+  = RecipientGroup RecipientGroup
+  | RecipientCustom
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveFinite ''RecipientCategory
+finiteEnum ''RecipientCategory
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , unwrapUnaryRecords = True
+  , sumEncoding = UntaggedValue
+  } ''RecipientCategory
+
+instance ToJSONKey RecipientCategory where
+  toJSONKey = toJSONKeyText toPathPiece
+instance FromJSONKey RecipientCategory where
+  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece
+
+instance PathPiece RecipientCategory where
+  toPathPiece RecipientCustom    = "custom"
+  toPathPiece (RecipientGroup g) = toPathPiece g
+
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX RecipientCategory where
+  renderMessage foundation ls = \case
+    RecipientCustom  -> renderMessage' MsgRecipientCustom
+    RecipientGroup g -> renderMessage' g
+    where
+      renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      renderMessage' = renderMessage foundation ls
+
+
+data CommunicationRoute = CommunicationRoute
+  { crRecipients    :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
+  , crRecipientAuth :: Maybe (UserId -> DB AuthResult)
+  , crJobs          :: Communication -> Source (YesodDB UniWorX) Job
+  , crHeading       :: SomeMessage UniWorX
+  , crUltDest       :: SomeRoute UniWorX
+  }
+
+data Communication = Communication
+ { cRecipients :: Set (Either UserEmail UserId)
+ , cSubject :: Maybe Text
+ , cBody :: Html
+ }
+
+
+commR :: CommunicationRoute -> Handler Html
+commR CommunicationRoute{..} =  do
+  cUser <- maybeAuth
+  
+  MsgRenderer mr <- getMsgRenderer
+  mbCurrentRoute <- getCurrentRoute
+
+  (suggestedRecipients, chosenRecipients) <- runDB $ do
+    suggested <- for crRecipients $ \user -> E.select user
+
+    let
+      decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
+      decrypt' cID = do
+        uid <- decrypt cID
+        whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
+        getEntity uid
+
+    chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient
+
+    return (suggested, chosen')
+
+  let
+    lookupUser :: UserId -> User
+    lookupUser lId
+      = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients
+
+  let chosenRecipients' = Map.fromList $
+        [ ( (EnumPosition $ RecipientGroup g, pos)
+          , (Right recp, recp `elem` map entityKey chosenRecipients)
+          )
+        | (g, recps) <- Map.toList suggestedRecipients
+        , (pos, recp) <- zip [0..] $ map entityKey recps
+        ] ++
+        [ ( (EnumPosition   RecipientCustom, pos)
+          , (Right recp, True)
+          )
+        | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
+        ]
+      activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom
+
+  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
+      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
+        where
+          miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
+            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
+            let
+              addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
+            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
+          miAdd _ _ _ _ = Nothing
+          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
+            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
+            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
+          miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do 
+            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
+            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
+          miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
+          miAllowAdd _ _ _ = False
+          miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
+          miAddEmpty _ _ _ = Set.empty
+          miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
+          miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
+                   -> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
+                   -> Map (EnumPosition RecipientCategory, ListPosition) Widget
+                   -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
+                   -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
+                   -> Widget
+          miLayout liveliness state cellWdgts _delButtons addWdgts = do
+            checkedIdentBase <- newIdent
+            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state
+                checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
+                hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
+                categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
+            $(widgetFile "widgets/communication/recipientLayout")
+          miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
+          -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
+          miDelete _ _ = mzero
+          postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
+          postProcess = Set.fromList . map fst . filter snd . Map.elems
+
+  ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
+    <$> recipientAForm
+    <*> aopt textField (fslI MsgCommSubject) Nothing
+    <*> areq htmlField (fslI MsgCommBody)    Nothing
+  formResult commRes $ \comm -> do
+    runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
+    addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
+    redirect crUltDest
+
+
+  let formWdgt = wrapForm commWdgt def
+        { formMethod   = POST
+        , formAction   = SomeRoute <$> mbCurrentRoute
+        , formEncoding = commEncoding
+        }
+  siteLayoutMsg crHeading $ do
+    setTitleI crHeading
+    formWdgt

src/Handler/Utils/DateTime.hs

@@ -13,6 +13,8 @@ module Handler.Utils.DateTime
 
 import Import
 
+import Utils.Lens
+
 import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
@@ -83,7 +85,7 @@ getTimeLocale = getTimeLocale' <$> languages
 getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
 getDateTimeFormat sel = do
   mauth <- liftHandlerT maybeAuth
-  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
   let
     fmt
       | Just (Entity _ User{..}) <- mauth
@@ -182,4 +184,4 @@ weeksToAdd old new = loop 0 old
   where
     loop n t
       | t > new   = n
-      | otherwise = loop (succ n) (addOneWeek t)
+      | otherwise = loop (succ n) (addOneWeek t)

src/Handler/Utils/Form.hs

@@ -10,7 +10,7 @@ import Handler.Utils.Form.Types
 
 import Handler.Utils.DateTime
 
-import Import hiding (cons)
+import Import
 import qualified Data.Char as Char
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
@@ -33,12 +33,13 @@ import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
-import Control.Monad.Except (runExceptT)
+import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
 
 import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
+import Data.Either (partitionEithers)
 
 import Utils.Lens
 
@@ -47,6 +48,8 @@ import Data.Aeson.Text (encodeToLazyText)
 
 import Data.Proxy
 
+import qualified Text.Email.Validate as Email
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -137,7 +140,47 @@ linkButton lbl cls url = do
       ^{lbl}
   |]
 
+--------------------------
+-- Interactive fieldset --
+--------------------------
 
+multiAction :: forall action a.
+               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
+            => Map action (AForm (HandlerT UniWorX IO) a)
+            -> FieldSettings UniWorX
+            -> Maybe action
+            -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiAction acts fs@FieldSettings{..} defAction csrf = do
+  mr <- getMessageRender
+
+  let
+    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
+  (actionRes, actionView) <- mreq (selectField $ return options) fs defAction
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
+
+  let actionResults = view _1 <$> results
+      actionViews = Map.foldrWithKey accViews [] results
+
+      accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
+      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
+
+  return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
+
+multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+             => Map action (AForm (HandlerT UniWorX IO) a)
+             -> FieldSettings UniWorX
+             -> Maybe action
+             -> AForm Handler a
+multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
+
+multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+             => Map action (AForm (HandlerT UniWorX IO) a)
+             -> FieldSettings UniWorX
+             -> Maybe action
+             -> (Html -> MForm Handler (FormResult a, Widget))
+multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
+
+  
 ------------
 -- Fields --
 ------------
@@ -274,8 +317,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
 uploadModeField :: Field Handler UploadMode
 uploadModeField = selectField optionsFinite
 
-submissionModeField :: Field Handler SheetSubmissionMode
+submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
-submissionModeField = selectField optionsFinite
+submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
+  where
+    uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
+
+    actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
+    actions = Map.fromList
+      [ ( SubmissionModeNone
+        , pure $ SubmissionMode False Nothing
+        )
+      , ( SubmissionModeCorrector
+        , pure $ SubmissionMode True  Nothing
+        )
+      , ( SubmissionModeUser
+        , SubmissionMode False . Just <$> uploadModeForm
+        )
+      , ( SubmissionModeBoth
+        , SubmissionMode True  . Just <$> uploadModeForm
+        )
+      ]
 
 pseudonymWordField :: Field Handler PseudonymWord
 pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@@ -377,7 +438,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
 embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
 
 sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
-sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
   where
     selOptions = Map.fromList
       [ ( Points',     Points     <$> maxPointsReq )
@@ -395,7 +456,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem
 
 
 sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
-sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
   where
     selOptions = Map.fromList
       [ ( Normal', Normal <$> gradingReq )
@@ -414,8 +475,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
       NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
+sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
-  let
+  where
     selOptions = Map.fromList
       [ ( Arbitrary', Arbitrary
           <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
@@ -423,25 +484,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
       , ( RegisteredGroups', pure RegisteredGroups )
       , ( NoGroups', pure NoGroups )
       ]
-  (res, selView) <- multiAction selOptions (classify' <$> template)
-
-  fvId <- maybe newIdent return fsId
-  MsgRenderer mr <- getMsgRenderer
-
-  return (res,
-    [ FieldView
-      { fvLabel = toHtml $ mr fsLabel
-      , fvTooltip = toHtml . mr <$> fsTooltip
-      , fvId
-      , fvInput = selView
-      , fvErrors = case res of
-          FormFailure [e] -> Just $ toHtml e
-          _ -> Nothing
-      , fvRequired = True
-      }
-    ])
-
-  where
     classify' :: SheetGroup -> SheetGroup'
     classify' = \case
       Arbitrary _ -> Arbitrary'
@@ -621,49 +663,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
-multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => Map action (AForm (HandlerT UniWorX IO) a)
-            -> Maybe action
-            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-multiAction acts defAction = do
-  mr <- getMessageRender
-  let
-    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
-  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-  let mToWidget (_, []) = return Nothing
-      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
-  widgets <- mapM mToWidget results
-  let actionWidgets = Map.foldrWithKey accWidget [] widgets
-      accWidget _act Nothing = id
-      accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
-      actionResults = Map.map fst results
-  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
-
-multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => FieldSettings UniWorX
-            -> Map action (AForm (HandlerT UniWorX IO) a)
-            -> Maybe action
-            -> AForm (HandlerT UniWorX IO) a
-multiActionA FieldSettings{..} acts defAction = formToAForm $ do
-  (res, selView) <- multiAction acts defAction
-
-  fvId <- maybe newIdent return fsId
-  MsgRenderer mr <- getMsgRenderer
-
-  return (res,
-    [ FieldView
-      { fvLabel = toHtml $ mr fsLabel
-      , fvTooltip = toHtml . mr <$> fsTooltip
-      , fvId
-      , fvInput = selView
-      , fvErrors = case res of
-          FormFailure [e] -> Just $ toHtml e
-          _ -> Nothing
-      , fvRequired = True
-      }
-    ])
-
 formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
 formResultModal res finalDest handler = maybeT_ $ do
   messages <- case res of
@@ -677,3 +676,67 @@ formResultModal res finalDest handler = maybeT_ $ do
     | otherwise -> do
         forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
         redirect finalDest
+
+multiUserField :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  )
+               => Bool -- ^ Only resolve suggested users?
+               -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
+               -> Field m (Set (Either UserEmail UserId))
+multiUserField onlySuggested suggestions = Field{..}
+  where
+    lookupExpr
+      | onlySuggested = suggestions
+      | otherwise     = Just $ E.from return
+    
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq = do
+      val' <- case val of
+        Left t -> return t
+        Right vs -> Text.intercalate ", " . map CI.original <$> do
+          let (emails, uids) = partitionEithers $ Set.toList vs
+          rEmails <- case lookupExpr of
+            Nothing -> return []
+            Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
+              dbRes <- liftHandlerT . runDB . E.select $ do
+                user <- lookupExpr'
+                E.where_ $ user E.^. UserId E.==. E.val uid
+                return $ user E.^. UserEmail
+              case dbRes of
+                [E.Value email] -> return [email]
+                _other -> return []
+          return $ emails ++ rEmails
+
+      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
+      
+      [whamlet|
+        $newline never
+        <input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
+      |]
+
+      whenIsJust suggestions $ \suggestions' -> do
+        suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
+          user <- suggestions'
+          return $ user E.^. UserEmail
+        [whamlet|
+          $newline never
+          <datalist id=#{datalistId}>
+            $forall email <- suggestedEmails
+              <option value=#{email}>
+        |]
+    fieldParse (all Text.null -> True) _ = return $ Right Nothing 
+    fieldParse ts _ = runExceptT . fmap Just $ do
+      let ts' = concatMap (Text.splitOn ",") ts
+      emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
+      fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
+        Nothing -> return $ Left email
+        Just lookupExpr' -> do
+            dbRes <- liftHandlerT . runDB . E.select $ do
+              user <- lookupExpr'
+              E.where_ $ user E.^. UserEmail E.==. E.val email
+              return $ user E.^. UserId
+            case dbRes of
+              [] -> return $ Left email
+              [E.Value uid] -> return $ Right uid
+              _other -> fail "Ambiguous e-mail addr"

src/Handler/Utils/Form/MassInput.hs

@@ -1,19 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
+  , defaultMiLayout
   , massInput
+  , module Handler.Utils.Form.MassInput.Liveliness
+  , massInputA, massInputW
   , massInputList
-  , BoxDimension(..)
-  , IsBoxCoord(..), boxDimension
-  , Liveliness(..)
   , ListLength(..), ListPosition(..), miDeleteList
+  , EnumLiveliness(..), EnumPosition(..)
+  , MapLiveliness(..)
   ) where
 
 import Import
 import Utils.Form
 import Utils.Lens
 import Handler.Utils.Form (secretJsonField)
+import Handler.Utils.Form.MassInput.Liveliness
+import Handler.Utils.Form.MassInput.TH
 
 import Data.Aeson
 
@@ -24,35 +29,15 @@ import Text.Blaze (Markup)
 import qualified Data.Text as Text
 
 import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
+import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold
-import Data.List (genericLength, genericIndex, iterate)
 
-import Control.Monad.Trans.Maybe
 import Control.Monad.Reader.Class (MonadReader(local))
 
 
-data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
+$(mapM tupleBoxCoord [2..4])
-  
-class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
-  boxDimensions :: [BoxDimension x]
-  boxOrigin :: x
-
-boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
-boxDimension n
-  | n < genericLength dims = genericIndex dims n
-  | otherwise = error "boxDimension: insufficient dimensions"
-  where
-    dims = boxDimensions
-
--- zeroDimension :: IsBoxCoord x => Natural -> x -> x
--- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
-  
-class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
-  type BoxCoord a :: *
-  liveCoords :: Prism' (Set (BoxCoord a)) a
-  liveCoord :: BoxCoord a -> Prism' Bool a
-  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
 
 
 newtype ListLength = ListLength { unListLength :: Natural }
@@ -70,13 +55,13 @@ instance BoundedJoinSemiLattice ListLength where
   bottom = 0
 
 newtype ListPosition = ListPosition { unListPosition :: Natural }
-  deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
+  deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
   deriving (Eq, Ord, Generic, Typeable, Read, Show)
 
 makeWrapped ''ListPosition
 
 instance IsBoxCoord ListPosition where
-  boxDimensions = [BoxDimension id]
+  boxDimensions = [BoxDimension _Wrapped]
   boxOrigin = 0
 
 instance Liveliness ListLength where
@@ -94,7 +79,66 @@ instance Liveliness ListLength where
         = Nothing
         where
           max' = Set.lookupMax ns
-  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
+  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
+
+
+newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumLiveliness
+
+instance JoinSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
+instance MeetSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
+instance Lattice (EnumLiveliness enum)
+instance BoundedJoinSemiLattice (EnumLiveliness enum) where
+  bottom = EnumLiveliness IntSet.empty
+instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
+  top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
+instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
+
+
+newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
+  deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumPosition
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
+  boxDimensions = [BoxDimension _Wrapped]
+  boxOrigin = minBound
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
+  type BoxCoord (EnumLiveliness enum) = EnumPosition enum
+  liveCoords = iso fromSet toSet
+    where
+      toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
+      fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
+
+
+newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
+  deriving (Generic, Typeable)
+
+makeWrapped ''MapLiveliness
+
+deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
+deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
+deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
+
+instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
+  type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
+  liveCoords = prism'
+    (Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
+    (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
+
 
 
 miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
@@ -205,7 +249,17 @@ data MassInput handler liveliness cellData cellResult = MassInput
                -> Natural
                -> liveliness
                -> Bool -- ^ Decide whether an addition-operation should be permitted
+  , miAddEmpty :: BoxCoord liveliness
+               -> Natural
+               -> liveliness
+               -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
   , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
+  , miLayout :: liveliness
+             -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
+             -> Map (BoxCoord liveliness) Widget -- Cell Widgets
+             -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
+             -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
+             -> Widget
   }
 
 massInput :: forall handler cellData cellResult liveliness.
@@ -221,12 +275,12 @@ massInput :: forall handler cellData cellResult liveliness.
           -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
 massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let initialShape = fmap fst <$> initialResult
-  
+
   miName <- maybe newFormIdent return fsName
   fvId <- maybe newIdent return fsId
   miAction <- traverse toTextUrl $ miButtonAction fvId
   let addFormAction = maybe id (addAttr "formaction") miAction
-  
+
   let
     shapeName :: MassInputFieldName (BoxCoord liveliness)
     shapeName = MassInputShape{..}
@@ -243,10 +297,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
 
   let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
-      addForm = addForm' boxOrigin . zip [0..]
+      addForm = addForm' boxOrigin [] . zip [0..]
         where
-          addForm' _ [] = return Map.empty
+          addForm' _ _ [] = return Map.empty
-          addForm' miCoord ((dimIx, _) : remDims) = do
+          addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
             let nudgeAddWidgetName :: Text -> Text
                 nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
             (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
@@ -262,9 +316,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
             case remDims of
               [] -> return dimRes'
               ((_, BoxDimension dim) : _) -> do
-                let
+                let miCoords
-                  miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
+                      = Set.union (miAddEmpty miCoord dimIx sentLiveliness)
-                dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
+                      . Set.map (\c -> miCoord & dim .~ (c ^. dim))
+                      . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
+                      $ review liveCoords sentLiveliness
+                dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
                 return $ dimRes' `Map.union` fold dimRess
 
   addResults <- addForm boxDimensions
@@ -303,8 +360,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
 
   shape <- if
-    | Just s <- addShape -> return s 
+    | Just s <- addShape -> return s
-    | Just s <- delShape -> return s 
+    | Just s <- delShape -> return s
     | otherwise          -> return sentShape'
   liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
 
@@ -342,25 +399,16 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
         guard $ not shapeChanged
         for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
 
-  let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+  let miWidget
-      miWidget' _ [] = mempty
+        = miLayout
-      miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+          liveliness
-        let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+          (fmap (view _1 &&& view (_2 . _1)) cellResults)
-            cells
+          (fmap (view $ _2 . _2) cellResults)
-              | [] <- remDims = do
+          (fmap (view _2) delResults)
-                  coord <- coords
+          (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
-                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
-                  let deleteButton = snd <$> Map.lookup coord delResults
-                  return (coord, $(widgetFile "widgets/massinput/cell"))
-              | otherwise =
-                  [ (coord, miWidget' coord remDims) | coord <- coords ]
-            addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
-         in $(widgetFile "widgets/massinput/row")
-
-      miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
 
   MsgRenderer mr <- getMsgRenderer
-  
+
   let
     fvLabel = toHtml $ mr fsLabel
     fvTooltip = toHtml . mr <$> fsTooltip
@@ -368,6 +416,32 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvErrors = Nothing
     in return (result, FieldView{..})
 
+defaultMiLayout :: forall liveliness cellData cellResult.
+                   Liveliness liveliness
+                => liveliness
+                -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
+                -> Map (BoxCoord liveliness) Widget
+                -> Map (BoxCoord liveliness) (FieldView UniWorX)
+                -> Map (Natural, BoxCoord liveliness) Widget
+                -> Widget
+-- | Generic `miLayout` using recursively nested lists
+defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
+  where
+    miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+    miWidget' _ _ [] = mempty
+    miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
+      let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
+          cells
+            | [] <- remDims = do
+                coord <- coords
+                Just cellWdgt <- return $ Map.lookup coord cellResults 
+                let deleteButton = Map.lookup coord delResults
+                return (coord, $(widgetFile "widgets/massinput/cell"))
+            | otherwise =
+                [ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
+          addWidget = Map.lookup (dimIx, miCoord) addResults
+       in $(widgetFile "widgets/massinput/row")
+
 
 -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
 massInputList :: forall handler cellResult.
@@ -388,8 +462,39 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
                 over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
             , miDelete = miDeleteList
             , miAllowAdd = \_ _ _ -> True
+            , miAddEmpty = \_ _ _ -> Set.empty
             , miButtonAction
+            , miLayout = \lLength _ cellWdgts delButtons addWdgts
+              -> $(widgetFile "widgets/massinput/list/layout")
             }
   miSettings
   miRequired
   (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
+
+massInputA :: forall handler cellData cellResult liveliness.
+           ( MonadHandler handler, HandlerSite handler ~ UniWorX
+           , ToJSON cellData, FromJSON cellData
+           , Liveliness liveliness
+           , MonadLogger handler
+           )
+          => MassInput handler liveliness cellData cellResult
+          -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
+          -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
+massInputA  mi fs fvRequired initialResult = formToAForm $
+  over _2 pure <$> massInput mi fs fvRequired initialResult mempty
+
+massInputW :: forall handler cellData cellResult liveliness.
+           ( MonadHandler handler, HandlerSite handler ~ UniWorX
+           , ToJSON cellData, FromJSON cellData
+           , Liveliness liveliness
+           , MonadLogger handler
+           )
+          => MassInput handler liveliness cellData cellResult
+          -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
+          -> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
+massInputW mi fs fvRequired initialResult = mFormToWForm $
+  massInput mi fs fvRequired initialResult mempty

src/Handler/Utils/Form/MassInput/Liveliness.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Form.MassInput.Liveliness
+  ( BoxDimension(..)
+  , IsBoxCoord(..)
+  , boxDimension
+  , Liveliness(..)
+  ) where
+
+import ClassyPrelude
+
+import Web.PathPieces (PathPiece)
+import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+
+import Numeric.Natural
+
+import Utils.Lens
+
+import Algebra.Lattice
+
+import qualified Data.Set as Set
+import Data.List (genericLength, genericIndex)
+
+
+data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n)
+
+class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where
+  boxDimensions :: [BoxDimension x]
+  boxOrigin :: x
+
+boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
+boxDimension n
+  | n < genericLength dims = genericIndex dims n
+  | otherwise = error "boxDimension: insufficient dimensions"
+  where
+    dims = boxDimensions
+
+-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
+-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
+
+class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
+  type BoxCoord a :: *
+  liveCoords :: Prism' (Set (BoxCoord a)) a
+  liveCoord :: BoxCoord a -> Prism' Bool a
+  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
+
+

src/Handler/Utils/Form/MassInput/TH.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Handler.Utils.Form.MassInput.TH
+  ( tupleBoxCoord
+  ) where
+
+import Prelude
+import Handler.Utils.Form.MassInput.Liveliness
+
+import Language.Haskell.TH
+
+import Control.Lens
+
+import Data.List ((!!))
+
+import Control.Monad (replicateM)
+
+
+tupleBoxCoord :: Int -> DecQ
+tupleBoxCoord tupleDim = do
+  cs <- replicateM tupleDim $ newName "c"
+
+  let tupleType = foldl appT (tupleT tupleDim) $ map varT cs
+      tCxt = cxt
+        [ [t|IsBoxCoord $(varT c)|] | c <- cs ]
+      fieldLenses =
+        [ [e|_1|]
+        , [e|_2|]
+        , [e|_3|]
+        , [e|_4|]
+        ]
+
+  instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
+    [ funD 'boxDimensions
+      [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
+      ]
+    , funD 'boxOrigin
+      [ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
+      ]
+    ]

src/Handler/Utils/Mail.hs

@@ -1,12 +1,13 @@
 module Handler.Utils.Mail
   ( addRecipientsDB
+  , userAddress
   , userMailT
   , addFileDB
   ) where
 
 import Import
 
-import Utils.Lens hiding (snoc)
+import Utils.Lens
 
 import qualified Data.CaseInsensitive as CI
 
@@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS
       let addr = Address (Just userDisplayName) $ CI.original userEmail
       _mailTo %= flip snoc addr
 
+userAddress :: User -> Address
+userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
+
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , MonadBaseControl IO m
              , MonadLogger m
              ) => UserId -> MailT m a -> m a
 userMailT uid mAct = do
-  User
+  user@User
-    { userEmail
+    { userMailLanguages
-    , userDisplayName
-    , userMailLanguages
     , userDateTimeFormat
     , userDateFormat
     , userTimeFormat
     } <- liftHandlerT . runDB $ getJust uid
   let
-    addr = Address (Just userDisplayName) $ CI.original userEmail
     ctx = MailContext
       { mcLanguages = userMailLanguages
       , mcDateTimeFormat = \case
@@ -55,7 +56,7 @@ userMailT uid mAct = do
           SelFormatTime -> userTimeFormat
       }
   mailT ctx $ do
-    _mailTo .= pure addr
+    _mailTo .= pure (userAddress user)
     mAct
 
 addFileDB :: ( MonadMail m
@@ -69,4 +70,4 @@ addFileDB fId = do
     _partEncoding .= Base64
     _partFilename .= Just fileName
     _partContent .= LBS.fromStrict fileContent
-    setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
+    setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

src/Handler/Utils/Rating.hs

@@ -18,8 +18,6 @@ import Import
 
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
-import Control.Monad.Trans.Maybe
-
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Text.Encoding.Error (UnicodeException(..))

src/Handler/Utils/Sheet.hs

@@ -12,7 +12,7 @@ fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
                   , Typeable a, MonadHandler m, IsPersistBackend backend
                   , PersistQueryRead backend, PersistUniqueRead backend
                   )
-  =>  (E.SqlExpr (Entity Sheet) -> b)
+  =>  (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
       -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
 fetchSheetAux prj tid ssh csh shn =
     let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
@@ -27,19 +27,22 @@ fetchSheetAux prj tid ssh csh shn =
                 E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                 E.&&.  course E.^. CourseShorthand E.==. E.val csh
                 E.&&.  sheet  E.^. SheetName       E.==. E.val shn
-            return $ prj sheet
+            return $ prj sheet course
         case sheetList of
           [sheet] -> return sheet
           _other  -> notFound
 
 fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
-fetchSheet = fetchSheetAux id
+fetchSheet = fetchSheetAux const
+
+fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
+fetchSheetCourse = fetchSheetAux (,)
 
 fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
-fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
+fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn
 
 fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
-fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
+fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
 
 
 sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet

src/Handler/Utils/Tokens.hs

@@ -0,0 +1,27 @@
+module Handler.Utils.Tokens
+  ( maybeBearerToken, requireBearerToken
+  ) where
+
+import Import
+
+import Utils.Lens
+
+import Control.Monad.Trans.Maybe (runMaybeT)
+
+
+maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
+maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
+  where
+    cPred err = any ($ err)
+      [ is $ _HCError . _PermissionDenied
+      , is $ _HCError . _NotAuthenticated
+      ]
+
+requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
+requireBearerToken = liftHandlerT $ do
+  token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
+  mAuthId <- maybeAuthId
+  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+  isWrite <- isWriteRequest currentRoute
+  guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
+  return token

src/Import/NoFoundation.hs

@@ -3,12 +3,13 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Model.Rating           as Import
 import Model.Submission       as Import
+import Model.Tokens           as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
@@ -18,7 +19,11 @@ import Utils                  as Import
 import Utils.Frontend.Modal   as Import
 import Utils.Frontend.I18n    as Import
 import Yesod.Core.Json        as Import (provideJson)
-import Yesod.Core.Types.Instances as Import ()
+import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
+
+import Language.Haskell.TH.Instances as Import ()
+
+import Utils.Tokens           as Import
 
 
 import Data.Fixed             as Import
@@ -31,6 +36,7 @@ import Text.Lucius            as Import
 import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
+import Data.Universe.TH       as Import
 import Data.Pool              as Import (Pool)
 import Network.HaskellNet.SMTP as Import (SMTPConnection)
 
@@ -44,10 +50,16 @@ import GHC.Exts               as Import (IsList)
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
 import Data.List.NonEmpty.Instances as Import ()
+import Data.NonNull.Instances as Import ()
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.Instances  as Import ()
+import Data.Set.Instances     as Import ()
+import Data.HashMap.Strict.Instances as Import ()
+import Data.HashSet.Instances as Import ()
+import Data.Vector.Instances  as Import ()
+import Data.Time.Clock.Instances as Import ()
 
 import Data.Binary            as Import (Binary)
 
@@ -57,17 +69,23 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
 
 import Network.Mail.Mime.Instances as Import ()
 import Yesod.Core.Instances as Import ()
+import Data.Aeson.Types.Instances as Import ()
 
 import Ldap.Client.Pool as Import
 
 import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
+import Database.Persist.Types.Instances as Import ()
 
 import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
+import Text.Blaze.Instances as Import ()
+import Jose.Jwt.Instances as Import ()
+import Web.PathPieces.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -6,6 +6,7 @@ module Jobs
   ) where
 
 import Import
+import Utils.Lens
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
@@ -58,6 +59,9 @@ import Jobs.Handler.QueueNotification
 import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
+import Jobs.Handler.SendCourseCommunication
+import Jobs.Handler.LecturerInvitation
+import Jobs.Handler.CorrectorInvitation
 
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
@@ -77,7 +81,7 @@ handleJobs :: ( MonadResource m
 -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
 -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
 handleJobs foundation@UniWorX{..} = do
-  let num = appJobWorkers appSettings
+  let num = foundation ^. _appJobWorkers
 
   jobCrontab <- liftIO $ newTMVarIO HashMap.empty
   jobConfirm <- liftIO $ newTVarIO HashMap.empty
@@ -135,7 +139,7 @@ execCrontab = evalStateT go HashMap.empty
         runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
       refT <- liftIO getCurrentTime
-      settings <- getsYesod appSettings
+      settings <- getsYesod appSettings'
       currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
         crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
         case crontab' of
@@ -157,7 +161,7 @@ execCrontab = evalStateT go HashMap.empty
                     | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
                       -> do
                         now <- liftIO $ getCurrentTime
-                        instanceID <- getsYesod appInstanceID
+                        instanceID' <- getsYesod appInstanceID
                         State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
                         case jobCtl of
                           JobCtlQueue job -> do
@@ -166,7 +170,7 @@ execCrontab = evalStateT go HashMap.empty
                               CronLastExec
                                 { cronLastExecJob = toJSON job
                                 , cronLastExecTime = now
-                                , cronLastExecInstance = instanceID
+                                , cronLastExecInstance = instanceID'
                                 }
                               [ CronLastExecTime =. now ]
                             lift . lift $ queueDBJob job
@@ -285,21 +289,21 @@ jLocked jId act = do
   let
     lock = runDB . setSerializable $ do
       qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
-      instanceID <- getsYesod appInstanceID
+      instanceID' <- getsYesod $ view instanceID
-      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      threshold <- getsYesod $ view _appJobStaleThreshold
       now <- liftIO getCurrentTime
       hadStale <- maybeT (return False) $ do
         lockTime <- MaybeT $ return queuedJobLockTime
         lockInstance <- MaybeT $ return queuedJobLockInstance
         if
-          | lockInstance == instanceID
+          | lockInstance == instanceID'
           , diffUTCTime now lockTime >= threshold
             -> return True
           | otherwise
             -> throwM $ JLocked jId lockInstance lockTime
       when hadStale .
         $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
-      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
+      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
                            , QueuedJobLockTime =. Just now
                            ]
       liftIO . atomically $ writeTVar hasLock True

src/Jobs/Crontab.hs

@@ -23,7 +23,7 @@ import qualified Data.Conduit.List as C
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
 determineCrontab = execWriterT $ do
-  AppSettings{..} <- getsYesod appSettings
+  AppSettings{..} <- getsYesod appSettings'
 
   case appJobFlushInterval of
     Just interval -> tell $ HashMap.singleton

src/Jobs/Handler/CorrectorInvitation.hs

@@ -0,0 +1,42 @@
+module Jobs.Handler.CorrectorInvitation
+  ( dispatchJobCorrectorInvitation
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Lens
+
+
+dispatchJobCorrectorInvitation :: UserId -> SheetCorrectorInvitation -> Handler ()
+dispatchJobCorrectorInvitation jInviter jCorrectorInvitation@SheetCorrectorInvitation{..} = do
+  ctx <- runDB . runMaybeT $ do
+    sheet <- MaybeT $ get sheetCorrectorInvitationSheet
+    course <- MaybeT . get $ sheetCourse sheet
+    void . MaybeT $ getByValue jCorrectorInvitation
+    user <- MaybeT $ get jInviter
+    return (sheet, course, user)
+
+  case ctx of
+    Just (Sheet{..}, Course{..}, User{..}) -> do
+      let baseRoute = CSheetR courseTerm courseSchool courseShorthand sheetName $ SCorrInviteR sheetCorrectorInvitationEmail
+      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
+      let
+        invitationUrl :: SomeRoute UniWorX
+        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
+      invitationUrl' <- toTextUrl invitationUrl
+
+      mailT def $ do
+        _mailTo .= [Address Nothing $ CI.original sheetCorrectorInvitationEmail]
+        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
+        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+        setSubjectI $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
+      
+        addPart ($(ihamletFile "templates/mail/correctorInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    Nothing -> runDB .
+      deleteBy $ UniqueSheetCorrectorInvitation sheetCorrectorInvitationEmail sheetCorrectorInvitationSheet

src/Jobs/Handler/HelpRequest.hs

@@ -21,15 +21,15 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
 dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
-  supportAddress <- getsYesod $ appMailSupport . appSettings
+  supportAddress <- view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
-  let userAddress = either
+  let senderAddress = either
         id
         (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
         userInfo
   mailT def $ do
     _mailTo .= [supportAddress]
-    whenIsJust userAddress (_mailFrom .=)
+    whenIsJust senderAddress (_mailFrom .=)
     replaceMailHeader "Auto-Submitted" $ Just "no"
     setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
     setDate jRequestTime

src/Jobs/Handler/LecturerInvitation.hs

@@ -0,0 +1,41 @@
+module Jobs.Handler.LecturerInvitation
+  ( dispatchJobLecturerInvitation
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Lens
+
+
+dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
+dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
+  ctx <- runDB . runMaybeT $ do
+    course <- MaybeT $ get lecturerInvitationCourse
+    void . MaybeT $ getByValue jLecturerInvitation
+    user <- MaybeT $ get jInviter
+    return (course, user)
+
+  case ctx of
+    Just (Course{..}, User{..}) -> do
+      let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
+      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
+      let
+        invitationUrl :: SomeRoute UniWorX
+        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
+      invitationUrl' <- toTextUrl invitationUrl
+
+      mailT def $ do
+        _mailTo .= [Address Nothing $ CI.original lecturerInvitationEmail]
+        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
+        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+        setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+      
+        addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    Nothing -> runDB .
+      deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse

src/Jobs/Handler/SendCourseCommunication.hs

@@ -0,0 +1,37 @@
+module Jobs.Handler.SendCourseCommunication
+  ( dispatchJobSendCourseCommunication
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils
+
+import qualified Data.Set as Set
+
+import qualified Data.CaseInsensitive as CI
+
+
+dispatchJobSendCourseCommunication :: Either UserEmail UserId
+                                   -> Set Address
+                                   -> CourseId
+                                   -> UserId
+                                   -> UUID
+                                   -> Maybe Text
+                                   -> Html
+                                   -> Handler ()
+dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do
+  (sender, Course{..}) <- runDB $ (,)
+    <$> getJust jSender
+    <*> getJust jCourse
+  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
+    void $ setMailObjectUUID jMailObjectUUID
+    _mailFrom .= userAddress sender
+    if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
+      | jRecipientEmail == Right jSender
+      -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
+      | otherwise
+      -> addMailHeader "Cc" "Undisclosed Recipients:;"
+    addMailHeader "Auto-Submitted" "no"
+    setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
+    void $ addPart jMailContent

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.CorrectionsAssigned
 
 import Import
 
+import Jobs.Handler.SendNotification.Utils
 import Handler.Utils.Mail
 
 import Text.Hamlet
@@ -28,6 +29,7 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
 
-    addAlternatives $ do
+    editNotifications <- mkEditNotifications jRecipient
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -7,6 +7,7 @@ module Jobs.Handler.SendNotification.SheetActive
 import Import
 
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.CaseInsensitive as CI
@@ -27,6 +28,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -8,6 +8,7 @@ module Jobs.Handler.SendNotification.SheetInactive
 import Import
 
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.CaseInsensitive as CI
@@ -30,8 +31,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
 dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@@ -56,7 +58,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -9,6 +9,7 @@ import Import
 import Utils.Lens
 import Handler.Utils.DateTime
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.Aeson as Aeson
@@ -35,6 +36,8 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
       csh = courseShorthand
       shn = sheetName
 
+  editNotifications <- mkEditNotifications jRecipient
+
   -- TODO: provide convienience template-haskell for `addAlternatives`
   addAlternatives $ do
     provideAlternative $ Aeson.object
@@ -52,5 +55,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
       , "course-school" Aeson..= courseSchool
       ]
     -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/UserRightsUpdate.hs

@@ -8,6 +8,7 @@ import Import
 
 import Handler.Utils.Database
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 -- import qualified Data.CaseInsensitive as CI
@@ -22,7 +23,7 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
-    addAlternatives $ do
+    editNotifications <- mkEditNotifications jRecipient
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 

src/Jobs/Handler/SendNotification/Utils.hs

@@ -0,0 +1,20 @@
+module Jobs.Handler.SendNotification.Utils
+  ( mkEditNotifications
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+
+mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
+mkEditNotifications uid = liftHandlerT $ do
+  cID <- encrypt uid
+  jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  let
+    editNotificationsUrl :: SomeRoute UniWorX
+    editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
+  editNotificationsUrl' <- toTextUrl editNotificationsUrl
+  return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Queue.hs

@@ -2,7 +2,7 @@ module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
   , queueJob, queueJob'
   , YesodJobDB
-  , runDBJobs, queueDBJob
+  , runDBJobs, queueDBJob, sinkDBJobs
   , module Jobs.Types
   ) where
 
@@ -21,6 +21,8 @@ import qualified Data.HashMap.Strict as HashMap
 
 import Control.Monad.Random (evalRand, mkStdGen, uniform)
 
+import qualified Data.Conduit.List as C
+
 
 data JobQueueException = JobQueuePoolEmpty
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -29,6 +31,10 @@ instance Exception JobQueueException
 
 
 writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
+-- | Pass an instruction to the `Job`-Workers
+--
+-- Instructions are assigned deterministically and pseudo-randomly to one specific worker.
+-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others
 writeJobCtl cmd = do
   tid <- liftIO myThreadId
   wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
@@ -39,6 +45,7 @@ writeJobCtl cmd = do
         liftIO . atomically $ writeTMChan chan cmd
 
 writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
+-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
 writeJobCtlBlock cmd = do
   getResVar <- asks jobConfirm
   resVar <- liftIO . atomically $ do
@@ -67,19 +74,30 @@ queueJobUnsafe job = do
   -- return jId
 
 queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+-- ^ Queue a job for later execution
+--
+-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
 queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
 
 queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
--- ^ `queueJob` followed by `JobCtlPerform`
+-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
 queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
 
+-- | Slightly modified Version of `YesodDB` for `runDBJobs`
 type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
 
-queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
+queueDBJob :: Job -> YesodJobDB UniWorX ()
+-- | Queue a job as part of a database transaction and execute it after the transaction succeeds
 queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
 
-runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX)
+sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
- => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+-- | Queue many jobs as part of a database transaction and execute them after the transaction passes
+sinkDBJobs = C.mapM_ queueDBJob
+
+runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
+-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
+--
+-- Jobs get immediately executed if the transaction succeeds
 runDBJobs act = do
   (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
   forM_ jIds $ writeJobCtl . JobCtlPerform

src/Jobs/Types.hs

@@ -15,14 +15,28 @@ import Data.List.NonEmpty (NonEmpty)
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
          | JobQueueNotification { jNotification :: Notification }
-         | JobHelpRequest { jSender :: Either (Maybe Address) UserId
+         | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
                           , jRequestTime :: UTCTime
-                          , jHelpSubject :: Maybe Text
+                          , jSubject :: Maybe Text
                           , jHelpRequest :: Text
                           , jReferer :: Maybe Text
                           }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }
+         | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
+                                      , jAllRecipientAddresses :: Set Address
+                                      , jCourse :: CourseId
+                                      , jSender :: UserId
+                                      , jMailObjectUUID :: UUID
+                                      , jSubject :: Maybe Text
+                                      , jMailContent :: Html
+                                      }
+         | JobLecturerInvitation { jInviter :: UserId
+                                 , jLecturerInvitation :: LecturerInvitation
+                                 }
+         | JobCorrectorInvitation { jInviter :: UserId
+                                  , jCorrectorInvitation :: SheetCorrectorInvitation
+                                  }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
@@ -37,15 +51,15 @@ instance Hashable Job
 instance Hashable Notification
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 1
   , tagSingleConstructors = True
   , sumEncoding = TaggedObject "job" "data"
   } ''Job
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 1
   , tagSingleConstructors = True
   , sumEncoding = TaggedObject "notification" "data"
   } ''Notification

src/Jose/Jwt/Instances.hs

@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Jose.Jwt.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Jose.Jwt
+
+
+instance PathPiece Jwt where
+  toPathPiece (Jwt bytes) = decodeUtf8 bytes
+  fromPathPiece = Just . Jwt . encodeUtf8
+
+deriving instance Generic JwtError
+deriving instance Typeable JwtError
+
+instance Exception JwtError

src/Language/Haskell/TH/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Haskell.TH.Instances
+  (
+  ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Lift (deriveLift)
+import Data.Binary (Binary)
+
+
+instance Binary Loc
+
+deriveLift ''Loc

src/Mail.hs

@@ -7,7 +7,9 @@ module Mail
     module Network.Mail.Mime
     -- * MailT
   , MailT, defMailT
-  , MailSmtpData(..), MailContext(..), MailLanguages(..)
+  , MailSmtpData(..)
+  , _MailSmtpDataSet
+  , MailContext(..), MailLanguages(..)
   , MonadMail(..)
   , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
@@ -24,9 +26,11 @@ module Mail
   , MailObjectId
   , replaceMailHeader, addMailHeader, removeMailHeader
   , replaceMailHeaderI, addMailHeaderI
-  , setSubjectI, setMailObjectId, setMailObjectId'
+  , setSubjectI
+  , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
   , setDate, setDateCurrent
   , setMailSmtpData
+  , _addressName, _addressEmail
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
@@ -60,18 +64,19 @@ import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 
-import Utils (MsgRendererS(..))
+import Utils (MsgRendererS(..), MonadSecretBox(..))
 import Utils.Lens.TH
 import Control.Lens hiding (from)
+import Control.Lens.Extras (is)
 
 import Text.Blaze.Renderer.Utf8
 
 import Data.UUID (UUID)
 import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
 import Data.UUID.Cryptographic.ImplicitNamespace
 
 import Data.Binary (Binary)
+import qualified Data.Binary as Binary
 
 import GHC.TypeLits (KnownSymbol)
 
@@ -104,7 +109,14 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
   
+import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
+import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
+import qualified Data.ByteArray as ByteArray (convert)
+import Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.Hash.Algorithms (SHAKE128)
 
+
+makeLenses_ ''Address
 makeLenses_ ''Mail
 makeLenses_ ''Part
 
@@ -131,6 +143,13 @@ instance Monoid (MailSmtpData) where
   mempty = memptydefault
   mappend = mappenddefault
 
+_MailSmtpDataSet :: Getter MailSmtpData Bool
+_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
+  [ is (_Wrapped . _Nothing) smtpEnvelopeFrom
+  , Set.null smtpRecipients
+  ]
+
+
 newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
   deriving newtype (FromJSON, ToJSON, IsList)
@@ -424,20 +443,33 @@ setMailObjectUUID uuid = do
   replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
   return objectId
 
-setMailObjectId :: ( MonadHeader m
+setMailObjectIdRandom :: ( MonadHeader m
-                   , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                   ) => m MailObjectId
+                         ) => m MailObjectId
-setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
 
-setMailObjectId' :: ( MonadHeader m
+setMailObjectIdCrypto :: ( MonadHeader m
-                    , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                    , MonadCrypto m
+                         , MonadCrypto m
-                    , HasCryptoUUID plain m
+                         , HasCryptoUUID plain m
-                    , MonadCryptoKey m ~ CryptoIDKey
+                         , MonadCryptoKey m ~ CryptoIDKey
-                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                         , KnownSymbol (CryptoIDNamespace UUID plain)
-                    , Binary plain
+                         , Binary plain
-                    ) => plain -> m MailObjectId
+                         ) => plain -> m MailObjectId
-setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid
+
+setMailObjectIdPseudorandom :: ( MonadHeader m
+                               , YesodMail (HandlerSite m)
+                               , Binary obj
+                               , MonadSecretBox m
+                               ) => obj -> m MailObjectId
+-- | Designed to leak no information about the `secretBoxKey` or the given object
+setMailObjectIdPseudorandom obj = do
+  sbKey <- secretBoxKey
+  let
+    seed :: HMAC (SHAKE128 64)
+    seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
+  setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
 
 
 setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()

src/Model.hs

@@ -40,5 +40,8 @@ deriving instance Eq (Unique Sheet)
 -- Automatically generated (i.e. numeric) ids are already taken care of
 deriving instance Binary (Key Term)
 
+instance Hashable LecturerInvitation
+instance Hashable SheetCorrectorInvitation
+
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration.hs

@@ -223,6 +223,23 @@ customMigrations = Map.fromListWith (>>)
         whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
         whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
     )
+  , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
+    , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
+        sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
+        [executeQQ|
+          ALTER TABLE "sheet" DROP COLUMN "upload_mode";
+          ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
+          ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
+        |]
+        forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
+          let submissionMode' = case (submissionMode, uploadMode) of
+                ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
+                ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
+                ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
+                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ Upload True)
+                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
+          [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
+    )
   ]
 
 

src/Model/Migration/Types.hs

@@ -1,12 +1,17 @@
 module Model.Migration.Types where 
 
 import ClassyPrelude.Yesod
+import Data.Aeson
 import Data.Aeson.TH (deriveJSON, defaultOptions)
-import Database.Persist.Sql
+
+import Utils.PathPiece
 
 import qualified Model as Current
 import qualified Model.Types.JSON as Current
 
+import Data.Universe
+
+
 data SheetType
   = Bonus  { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
   | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@@ -20,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..}
 sheetType Pass {..}   = Current.Normal Current.PassPoints {..}
 sheetType NotGraded   = Current.NotGraded
 
+
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveJSON defaultOptions ''UploadMode
+Current.derivePersistFieldJSON ''UploadMode
+
+instance Universe UploadMode where
+  universe = NoUpload : (Upload <$> universe)
+instance Finite UploadMode
+
+instance PathPiece UploadMode where
+  toPathPiece = \case
+    NoUpload     -> "no-upload"
+    Upload True  -> "unpack"
+    Upload False -> "no-unpack"
+  fromPathPiece = finiteFromPathPiece
+
+data SheetSubmissionMode = NoSubmissions
+                         | CorrectorSubmissions
+                         | UserSubmissions
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''SheetSubmissionMode
+derivePersistField "SheetSubmissionMode"
+
+instance Universe SheetSubmissionMode
+instance Finite SheetSubmissionMode
+
+nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
+
+  
 {- TODO:
   * RenderMessage instance for newtype(SheetType) if needed
 -}

src/Model/Tokens.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Tokens
+  ( BearerToken(..)
+  , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
+  , tokenRestrict
+  , tokenToJSON, tokenParseJSON
+  ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Core.Instances ()
+  
+import Model
+import Utils (assertM')
+import Utils.Lens hiding ((.=))
+import Data.Aeson.Lens (AsJSON(..))
+
+import Yesod.Auth (AuthId)
+
+import Jose.Jwt (IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Jose.Jwt.Instances ()
+import Data.Aeson.Types.Instances ()
+
+import Data.HashSet (HashSet)
+
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict.Instances ()
+import Data.HashSet.Instances ()
+import Data.Time.Clock.Instances ()
+
+import Data.Aeson.Types (Parser, (.:?), (.:), (.!=), (.=))
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+
+import CryptoID
+
+import Data.Time.Clock.POSIX
+
+import Data.Binary (Binary)
+
+
+
+-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
+data BearerToken site = BearerToken
+  { tokenIdentifier   :: TokenId
+    -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
+  , tokenAuthority    :: AuthId site
+    -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
+  , tokenRoutes       :: Maybe (HashSet (Route site))
+    -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+  , tokenAddAuth      :: Maybe AuthDNF
+    -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
+  , tokenRestrictions :: HashMap (Route site) Value
+    -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
+    --
+    -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
+  , tokenIssuedAt     :: UTCTime
+  , tokenIssuedBy     :: InstanceId
+  , tokenExpiresAt
+  , tokenStartsAt     :: Maybe UTCTime
+  } deriving (Generic, Typeable)
+
+deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
+deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
+deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
+
+instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
+
+makeLenses_ ''BearerToken
+
+_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
+-- ^ Focus a singular restriction (by route) if it exists
+--
+-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
+_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
+
+_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
+-- ^ Focus a singular restriction (by route) whether it exists, or not
+_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
+
+tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
+-- ^ Add a restriction to a `BearerToken`
+--
+-- If a restriction already exists for the targeted route, it's silently overwritten
+tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
+
+
+
+tokenToJSON :: forall m.
+               ( MonadHandler m
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               ) => BearerToken (HandlerSite m) -> m Value
+-- ^ Encode a `BearerToken` analogously to `toJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
+tokenToJSON BearerToken{..} = do
+  cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
+  let stdPayload = Jose.JwtClaims
+        { jwtIss = Just $ toPathPiece tokenIssuedBy
+        , jwtSub = Nothing
+        , jwtAud = Nothing
+        , jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
+        , jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
+        , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
+        , jwtJti = Just $ toPathPiece tokenIdentifier
+        }
+  return . JSON.object $
+    catMaybes [ Just $ "authority" .= cID
+              , ("routes" .=) <$> tokenRoutes
+              , ("add-auth" .=) <$> tokenAddAuth
+              , ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
+              ]
+    ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
+
+tokenParseJSON :: forall site.
+                  ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute site
+                  , Hashable (Route site)
+                  )
+               => Value
+               -> ReaderT CryptoIDKey Parser (BearerToken site)
+-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
+--
+-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
+tokenParseJSON v@(Object o) = do
+  tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
+  tokenAuthority <- decrypt tokenAuthority'
+
+  tokenRoutes        <- lift $ o .:? "routes"
+  tokenAddAuth       <- lift $ o .:? "add-auth"
+  tokenRestrictions  <- lift $ o .:? "restrictions" .!= HashMap.empty
+  Jose.JwtClaims{..} <- lift $ parseJSON v
+
+  let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
+
+  Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
+  Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
+  Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
+  let tokenExpiresAt = unIntDate <$> jwtExp
+      tokenStartsAt = unIntDate <$> jwtNbf
+
+  return BearerToken{..}
+tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
+

src/Model/Types.hs

@@ -24,9 +24,12 @@ import Data.Monoid (Sum(..))
 import Data.Maybe (fromJust)
 import Data.Universe
 import Data.Universe.Helpers
+import Data.Universe.TH
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
 
+import Data.NonNull.Instances ()
+
 import Data.Default
 
 import Text.Read (readMaybe)
@@ -54,7 +57,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
 import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -79,7 +82,8 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
-
+import qualified Data.Binary as Binary
+  
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -286,12 +290,14 @@ instance DisplayAble DA where
 data UploadMode = NoUpload | Upload { unpackZips :: Bool }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveJSON defaultOptions ''UploadMode
+deriveFinite ''UploadMode
-derivePersistFieldJSON ''UploadMode
 
-instance Universe UploadMode where
+deriveJSON defaultOptions
-  universe = NoUpload : (Upload <$> universe)
+  { constructorTagModifier = camelToPathPiece
-instance Finite UploadMode
+  , fieldLabelModifier = camelToPathPiece
+  , sumEncoding = TaggedObject "mode" "settings"
+  }''UploadMode
+derivePersistFieldJSON ''UploadMode
 
 instance PathPiece UploadMode where
   toPathPiece = \case
@@ -300,20 +306,51 @@ instance PathPiece UploadMode where
     Upload False -> "no-unpack"
   fromPathPiece = finiteFromPathPiece
 
-data SheetSubmissionMode = NoSubmissions
+data SubmissionMode = SubmissionMode
-                         | CorrectorSubmissions
+  { submissionModeCorrector :: Bool
-                         | UserSubmissions
+  , submissionModeUser :: Maybe UploadMode
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+  }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveFinite ''SubmissionMode
 
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
+  { fieldLabelModifier = camelToPathPiece' 2
-  } ''SheetSubmissionMode
+  } ''SubmissionMode
-derivePersistField "SheetSubmissionMode"
+derivePersistFieldJSON ''SubmissionMode
 
-instance Universe SheetSubmissionMode
+finitePathPiece ''SubmissionMode
-instance Finite SheetSubmissionMode
+  [ "no-submissions"
+  , "no-upload"
+  , "no-unpack"
+  , "unpack"
+  , "correctors"
+  , "correctors+no-upload"
+  , "correctors+no-unpack"
+  , "correctors+unpack"
+  ]
 
-nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
+data SubmissionModeDescr = SubmissionModeNone
+                         | SubmissionModeCorrector
+                         | SubmissionModeUser
+                         | SubmissionModeBoth
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe SubmissionModeDescr
+instance Finite SubmissionModeDescr
+
+finitePathPiece ''SubmissionModeDescr
+  [ "no-submissions"
+  , "correctors"
+  , "users"
+  , "correctors+users"
+  ]
+
+classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
+classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
+classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
+classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
+classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
+  
 
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
@@ -329,6 +366,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
 deriveJSON defaultOptions ''Load
 derivePersistFieldJSON ''Load
 
+instance Hashable Load
 
 instance Semigroup Load where
   (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@@ -526,9 +564,11 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Corrector"
   } ''CorrectorState
 
-instance Universe CorrectorState where universe = universeDef
+instance Universe CorrectorState
 instance Finite CorrectorState
 
+instance Hashable CorrectorState
+
 nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
 
 derivePersistField "CorrectorState"
@@ -712,6 +752,7 @@ pseudonymFragments = folding
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
+  | AuthToken
   | AuthLecturer
   | AuthCorrector
   | AuthRegistered
@@ -724,6 +765,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthCorrectorSubmissions
   | AuthCapacity
   | AuthEmpty
+  | AuthSelf
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead
@@ -731,7 +773,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthDeprecated
   | AuthDevelopment
   | AuthFree
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe AuthTag
 instance Finite AuthTag
@@ -749,6 +791,8 @@ instance ToJSONKey AuthTag where
 instance FromJSONKey AuthTag where
   fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
 
+instance Binary AuthTag
+
 
 newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
   deriving (Read, Show, Generic)
@@ -772,6 +816,45 @@ instance FromJSON AuthTagActive where
 derivePersistFieldJSON ''AuthTagActive
 
 
+data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable a => Hashable (PredLiteral a)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , unwrapUnaryRecords = True
+  } ''PredLiteral
+
+instance PathPiece a => PathPiece (PredLiteral a) where
+  toPathPiece PLVariable{..} = toPathPiece plVar
+  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
+
+  fromPathPiece t = PLVariable <$> fromPathPiece t
+                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
+
+instance Binary a => Binary (PredLiteral a)
+
+
+newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+$(return [])
+
+instance ToJSON a => ToJSON (PredDNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
+instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
+
+instance (Ord a, Binary a) => Binary (PredDNF a) where
+  get = PredDNF <$> Binary.get
+  put = Binary.put . dnfTerms
+
+type AuthLiteral = PredLiteral AuthTag
+
+type AuthDNF = PredDNF AuthTag
+
 
 data LecturerType = CourseLecturer | CourseAssistant
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -785,6 +868,8 @@ deriveJSON  defaultOptions
   } ''LecturerType
 derivePersistFieldJSON ''LecturerType
 
+instance Hashable LecturerType
+
 
 -- Type synonyms
 
@@ -799,4 +884,5 @@ type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
+type TokenId         = UUID
 type TermCandidateIncidence = UUID

src/Model/Types/JSON.hs

@@ -1,5 +1,6 @@
 module Model.Types.JSON
   ( derivePersistFieldJSON
+  , predNFAesonOptions
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -9,11 +10,13 @@ import Database.Persist.Sql
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Encoding as Text
 
-import qualified Data.Aeson as JSON
+import Data.Aeson as JSON
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Datatype
 
+import Utils.PathPiece
+
 
 derivePersistFieldJSON :: Name -> DecsQ
 derivePersistFieldJSON tName = do
@@ -28,10 +31,10 @@ derivePersistFieldJSON tName = do
         | otherwise = cxt [[t|PersistField|] `appT` t]
   sequence
     [ instanceD iCxt ([t|PersistField|] `appT` t)
-      [ funD (mkName "toPersistValue")
+      [ funD 'toPersistValue
         [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
         ]
-      , funD (mkName "fromPersistValue")
+      , funD 'fromPersistValue
         [ do
             bs <- newName "bs"
             clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@@ -45,8 +48,20 @@ derivePersistFieldJSON tName = do
         ]
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
-      [ funD (mkName "sqlType")
+      [ funD 'sqlType
         [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]
     ]
+
+
+predNFAesonOptions :: Options
+-- ^ Needed for JSON instances of `predCNF` and `predDNF`
+--
+-- Moved to this module due to stage restriction
+predNFAesonOptions = defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , tagSingleConstructors = True
+  }
+  

src/Settings.hs

@@ -21,12 +21,18 @@ import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
 import           Database.Persist.Postgresql (PostgresConf)
-import           Language.Haskell.TH.Syntax  (Exp, Name, Q)
 import           Network.Wai.Handler.Warp    (HostPreference)
 import           Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
-import           Yesod.Default.Util          (WidgetFileSettings,
+#ifdef DEVELOPMENT
-                                              widgetFileNoReload,
+import           Yesod.Default.Util          (WidgetFileSettings, widgetFileReload)
-                                              widgetFileReload)
+import           Language.Haskell.TH.Syntax  (Exp, Q, location, Loc(..))
+
+import Text.Shakespeare.Text (st)
+import Text.Blaze.Html (preEscapedToHtml)
+#else
+import           Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload, widgetFileReload)
+import           Language.Haskell.TH.Syntax  (Exp, Q)
+#endif
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import Data.Time (NominalDiffTime, nominalDay)
@@ -63,6 +69,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 
 import qualified System.FilePath as FilePath
 
+import Jose.Jwt (JwtEncoding(..))
+
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -100,6 +109,8 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
+    , appJwtExpiration          :: Maybe NominalDiffTime
+    , appJwtEncoding            :: JwtEncoding
 
     , appInitialLogSettings     :: LogSettings
 
@@ -310,6 +321,18 @@ deriveFromJSON
     }
   ''SmtpAuthConf
 
+instance FromJSON JwtEncoding where
+  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
+  parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
+    [ do
+        alg <- obj .: "alg"
+        return $ JwsEncoding alg
+    , do
+        alg <- obj .: "alg"
+        enc <- obj .: "enc"
+        return $ JweEncoding alg enc
+    ]
+
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
@@ -352,6 +375,8 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
+        appJwtExpiration          <- o .:? "jwt-expiration"
+        appJwtEncoding            <- o .: "jwt-encoding"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -379,6 +404,8 @@ instance FromJSON AppSettings where
 
         return AppSettings {..}
 
+makeClassy_ ''AppSettings
+
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
 --
@@ -388,18 +415,29 @@ instance FromJSON AppSettings where
 widgetFileSettings :: WidgetFileSettings
 widgetFileSettings = def
 
--- | How static files should be combined.
-combineSettings :: CombineSettings
-combineSettings = def
-
 -- The rest of this file contains settings which rarely need changing by a
 -- user.
 
 widgetFile :: String -> Q Exp
-widgetFile = (if appReloadTemplates compileTimeAppSettings
+#ifdef DEVELOPMENT
-                then widgetFileReload
+widgetFile nameBase = do
-                else widgetFileNoReload)
+  Loc{..} <- location
-              widgetFileSettings
+  let nameBase' = "templates" </> nameBase
+      before, after :: Text
+      before = [st|<!-- BEGIN ‘#{nameBase'}.*’ IN ‘#{loc_filename}’ #{tshow loc_start}–#{tshow loc_end} -->|]
+      after  = [st|<!-- END ‘#{nameBase'}.*’ -->|]
+  [e| do
+        toWidget $ preEscapedToHtml before
+        $(widgetFileReload widgetFileSettings nameBase)
+        toWidget $ preEscapedToHtml after
+    |]
+#else
+widgetFile
+  | appReloadTemplates compileTimeAppSettings
+  = widgetFileReload widgetFileSettings
+  | otherwise
+  = widgetFileNoReload widgetFileSettings
+#endif
 
 -- | Raw bytes at compile time of @config/settings.yml@
 configSettingsYmlBS :: ByteString
@@ -416,19 +454,3 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Error e -> error e
         Success settings -> settings
-
--- The following two functions can be used to combine multiple CSS or JS files
--- at compile time to decrease the number of http requests.
--- Sample usage (inside a Widget):
---
--- > $(combineStylesheets 'StaticR [style1_css, style2_css])
-
-combineStylesheets :: Name -> [Route Static] -> Q Exp
-combineStylesheets = combineStylesheets'
-    (appSkipCombining compileTimeAppSettings)
-    combineSettings
-
-combineScripts :: Name -> [Route Static] -> Q Exp
-combineScripts = combineScripts'
-    (appSkipCombining compileTimeAppSettings)
-    combineSettings

src/Settings/Cluster.hs

@@ -32,11 +32,16 @@ import qualified Data.Binary as Binary
 import qualified Data.Serialize as Serialize
 import qualified Data.ByteString.Base64.URL as Base64
 
+import qualified Jose.Jwa as Jose
+import qualified Jose.Jwk as Jose
+import qualified Jose.Jwt as Jose
+
 
 data ClusterSettingsKey
   = ClusterCryptoIDKey
   | ClusterClientSessionKey
   | ClusterSecretBoxKey
+  | ClusterJSONWebKeySet
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 instance Universe ClusterSettingsKey
@@ -120,3 +125,12 @@ instance FromJSON SecretBox.Key where
   parseJSON = Aeson.withText "Key" $ \t -> do
     bytes <- either fail return . Base64.decode $ encodeUtf8 t
     maybe (fail "Could not parse key") return $ Saltine.decode bytes
+
+
+instance ClusterSetting 'ClusterJSONWebKeySet where
+  type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
+  initClusterSetting _ = liftIO $ do
+    now <- getCurrentTime
+    jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
+    return $ Jose.JwkSet [jwkSig]
+  knownClusterSetting _ = ClusterJSONWebKeySet

src/Text/Blaze/Instances.hs

@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Blaze.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Text.Blaze
+import qualified Text.Blaze.Renderer.Text as Text
+
+import Text.Read (Read(..))
+
+import Data.Hashable (Hashable(..))
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import qualified Data.Aeson as Aeson
+
+
+instance Eq Markup where
+  (==) = (==) `on` Text.renderMarkup
+
+instance Ord Markup where
+  compare = comparing Text.renderMarkup
+
+instance Read Markup where
+  readPrec = preEscapedLazyText <$> readPrec
+
+instance Show Markup where
+  showsPrec prec = showsPrec prec . Text.renderMarkup
+
+instance Hashable Markup where
+  hashWithSalt s = hashWithSalt s . Text.renderMarkup
+
+instance ToJSON Markup where
+  toJSON = Aeson.String . toStrict . Text.renderMarkup
+
+instance FromJSON Markup where
+  parseJSON = Aeson.withText "Html" $ return . preEscapedText

src/Utils.hs

@@ -45,13 +45,14 @@ import Control.Lens as Utils (none)
 import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
-import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
 import Control.Monad.Catch hiding (throwM)
 
 
 import qualified Database.Esqueleto as E (Value, unValue)
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Instances ()
 import Instances.TH.Lift ()
 
 import Text.Shakespeare.Text (st)
@@ -69,6 +70,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
 import Data.Fixed (Centi)
 import Data.Ratio ((%))
 
+import qualified Data.Binary as Binary
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -490,6 +493,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
 maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
 maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
 
+maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
+maybeTExceptT err act = maybeExceptT err $ runMaybeT act
+  
+maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
+maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
+
 whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
 whenExceptT b err = when b $ throwE err
 
@@ -601,6 +610,15 @@ choice = foldr (<|>) empty
 -- Sessions --
 --------------
 
+data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
+                | SessionNewStudyTerms
+                | SessionBearer
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe SessionKey
+instance Finite SessionKey
+
+nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
+
 setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
 setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
 
@@ -725,3 +743,12 @@ encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, Mo
 encodedSecretBoxOpen ciphertext = do
   sKey <- secretBoxKey
   encodedSecretBoxOpen' sKey ciphertext
+
+-------------
+-- Caching --
+-------------
+
+cachedHere :: Q Exp
+cachedHere = do
+  loc <- location
+  [e| cachedBy (toStrict $ Binary.encode loc) |]

src/Utils/DB.hs

@@ -35,6 +35,12 @@ 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
 
+updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
+  => Unique record -> [Update record] -> ReaderT backend m ()
+updateBy uniq updates = do
+  key <- getKeyBy uniq
+  for_ key $ flip update updates
+
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m
        ,Eq (Unique record)

src/Utils/Form.hs

@@ -189,6 +189,7 @@ data FormIdentifier
   | FIDcUserNote
   | FIDAdminDemo
   | FIDUserDelete
+  | FIDCommunication
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -440,6 +441,9 @@ optionsFinite = do
       }
   return . mkOptionList $ mkOption <$> universeF
 
+rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
+rationalField = convertField toRational fromRational doubleField
+
 
 -----------
 -- Forms --

src/Utils/Lens.hs

@@ -1,14 +1,15 @@
 module Utils.Lens ( module Utils.Lens ) where
 
-import Import.NoFoundation
+import ClassyPrelude.Yesod
-import Control.Lens as Utils.Lens hiding ((<.>))
+import Model
+import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
+
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 
-_unValue :: Lens' (E.Value a) a
-_unValue f (E.Value a) = E.Value <$> f a
 
 _PathPiece :: PathPiece v => Prism' Text v
 _PathPiece = prism' toPathPiece fromPathPiece
@@ -90,7 +91,27 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makeLenses_ ''FieldView
+
+makePrisms ''HandlerContents
+
+makePrisms ''ErrorResponse
+
+makeLenses_ ''SheetCorrectorInvitation
+
+makeLenses_ ''SubmissionMode
+
+makePrisms ''E.Value
+
 
 -- makeClassy_ ''Load
 
+--------------------------
+-- Fields for `UniWorX` --
+--------------------------
 
+class HasInstanceID s a | s -> a where
+  instanceID :: Lens' s a
+  
+class HasJSONWebKeySet s a | s -> a where
+  jsonWebKeySet :: Lens' s a

src/Utils/Parameters.hs

@@ -1,10 +1,10 @@
 module Utils.Parameters
   ( GlobalGetParam(..)
-  , lookupGlobalGetParam, hasGlobalGetParam
+  , lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams
   , lookupGlobalGetParamForm, hasGlobalGetParamForm
   , globalGetParamField
   , GlobalPostParam(..)
-  , lookupGlobalPostParam, hasGlobalPostParam
+  , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams
   , lookupGlobalPostParamForm, hasGlobalPostParamForm
   , globalPostParamField
   ) where
@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer
+data GlobalGetParam = GetReferer | GetBearer | GetRecipient
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam
@@ -33,6 +33,9 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
 hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
 hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
 
+lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result]
+lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident)
+
 
 lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
 lookupGlobalGetParamForm ident = runMaybeT $ do
@@ -42,7 +45,7 @@ lookupGlobalGetParamForm ident = runMaybeT $ do
 hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
 hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
 
-globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a)
 globalGetParamField ident Field{fieldParse} = runMaybeT $ do
   ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
   fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
@@ -51,6 +54,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
 data GlobalPostParam = PostFormIdentifier
                      | PostDeleteTarget
                      | PostMassInputShape
+                     | PostBearer
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalPostParam
@@ -62,7 +66,11 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie
 
 hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
 hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
+  
+lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result]
+lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident)
 
+  
 lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
 lookupGlobalPostParamForm ident = runMaybeT $ do
   ps <- MaybeT askParams

src/Utils/PathPiece.hs

@@ -1,9 +1,10 @@
 module Utils.PathPiece
   ( finiteFromPathPiece
   , nullaryToPathPiece
-  , nullaryPathPiece
+  , nullaryPathPiece, finitePathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
+  , tuplePathPiece
   ) where
 
 import ClassyPrelude.Yesod
@@ -15,8 +16,14 @@ import Data.Universe
 import qualified Data.Text as Text
 import qualified Data.Char as Char
 
+import Data.Map ((!), (!?))
+import qualified Data.Map as Map
+
 import Numeric.Natural
 
+import Data.List (foldl)
+  
+
 finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
 finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
   [x] -> Just x
@@ -40,6 +47,16 @@ nullaryPathPiece nullaryType mangle =
     , funD 'fromPathPiece
       [ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
     ]
+
+finitePathPiece :: Name -> [Text] -> DecsQ
+finitePathPiece finiteType verbs =
+  pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
+    [ funD 'toPathPiece
+      [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
+    , funD 'fromPathPiece
+      [ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
+    ]
+  
   
 splitCamel :: Textual t => t -> [t]
 splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
@@ -63,3 +80,32 @@ camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dro
 
 camelToPathPiece :: Textual t => t -> t
 camelToPathPiece = camelToPathPiece' 0
+
+
+tuplePathPiece :: Int -> DecQ
+tuplePathPiece tupleDim = do
+  let
+    tupleSeparator :: Text
+    tupleSeparator = ","
+  
+  xs <- replicateM tupleDim $ newName "x" :: Q [Name]
+  xs' <- replicateM tupleDim $ newName "x'" :: Q [Name]
+
+  let tupleType = foldl appT (tupleT tupleDim) $ map varT xs
+      tCxt = cxt
+        [ [t|PathPiece $(varT x)|] | x <- xs ]
+
+  t <- newName "t"
+
+  instanceD tCxt [t|PathPiece $(tupleType)|]
+    [ funD 'toPathPiece
+      [ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
+      ]
+    , funD 'fromPathPiece
+      [ clause [varP t] (normalB . doE $ concat
+                         [ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
+                         , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
+                         , pure $ noBindS [e|return $(tupE $ map varE xs')|]
+                         ]) []
+      ]
+    ]

src/Utils/Tokens.hs

@@ -0,0 +1,174 @@
+module Utils.Tokens
+  ( bearerToken
+  , encodeToken, BearerTokenException(..), decodeToken
+  , tokenParseJSON'
+  , askJwt
+  , formEmbedJwtPost, formEmbedJwtGet
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Yesod.Auth (AuthId)
+
+import Utils (NTop(..), hoistMaybe, SessionKey(..))
+import Utils.Parameters
+import Utils.Lens
+
+import Model
+import Model.Tokens
+
+import Jose.Jwk (JwkSet(..))
+import Jose.Jwt (Jwt(..))
+import qualified Jose.Jwt as Jose
+
+import Data.Aeson.Types (Parser)
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Parser as JSON
+import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
+import qualified Data.Aeson.Internal as JSON (iparse, formatError)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.Time.Clock
+
+import Control.Monad.Random (MonadRandom(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+import Settings
+
+import CryptoID
+
+import Text.Blaze (Markup)
+
+
+tokenParseJSON' :: forall m.
+                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute (HandlerSite m)
+                  , Hashable (Route (HandlerSite m))
+                  , MonadHandler m
+                  , MonadCrypto m
+                  , MonadCryptoKey m ~ CryptoIDKey
+                  )
+               => m (Value -> Parser (BearerToken (HandlerSite m)))
+-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
+tokenParseJSON' = do
+  cidKey <- cryptoIDKey return
+  return $ flip runReaderT cidKey . tokenParseJSON
+
+
+bearerToken :: forall m.
+               ( MonadHandler m
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasAppSettings (HandlerSite m)
+               )
+            => AuthId (HandlerSite m)
+            -> Maybe (HashSet (Route (HandlerSite m)))
+            -> Maybe AuthDNF
+            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
+            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
+            -> m (BearerToken (HandlerSite m))
+-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
+bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
+  tokenIdentifier <- liftIO getRandom
+  tokenIssuedAt <- liftIO getCurrentTime
+  tokenIssuedBy <- getsYesod $ view instanceID
+
+  defaultExpiration <- getsYesod $ view _appJwtExpiration
+  
+  let tokenExpiresAt
+        | Just t <- mTokenExpiresAt
+        = t
+        | Just tDiff <- defaultExpiration
+        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+        | otherwise
+        = Nothing
+      tokenRestrictions = HashMap.empty
+
+  return BearerToken{..}
+
+
+encodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasAppSettings (HandlerSite m)
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               )
+            => BearerToken (HandlerSite m) -> m Jwt
+-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
+encodeToken token = do
+  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  jwtEncoding <- getsYesod $ view _appJwtEncoding
+  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+
+
+data BearerTokenException
+  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
+  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
+  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
+  | BearerTokenExpired | BearerTokenNotStarted
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Exception BearerTokenException
+
+decodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+               , MonadCryptoKey m ~ CryptoIDKey
+               , MonadCrypto m
+               , MonadThrow m
+               , ParseRoute (HandlerSite m)
+               , Hashable (Route (HandlerSite m))
+               )
+            => Jwt -> m (BearerToken (HandlerSite m))
+-- ^ Decode a `Jwt` and call `tokenParseJSON`
+--
+-- Throws `bearerTokenException`s
+decodeToken (Jwt bs) = do
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
+  content' <- case content of
+    Jose.Unsecured _ -> throwM BearerTokenUnsecured
+    Jose.Jws (_header, payload) -> return payload
+    Jose.Jwe (_header, payload) -> return payload
+  parser <- tokenParseJSON'
+  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+  now <- liftIO getCurrentTime
+  unless (NTop tokenExpiresAt > NTop (Just now)) $
+    throwM BearerTokenExpired
+  unless (tokenStartsAt <= Just now) $
+    throwM BearerTokenNotStarted
+  return token
+
+
+askJwt :: forall m. ( MonadHandler m )
+       => m (Maybe Jwt)
+-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
+askJwt = runMaybeT $ asum
+  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+  , MaybeT $ lookupGlobalPostParam PostBearer
+  , MaybeT $ lookupGlobalGetParam GetBearer
+  , fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
+  ]
+
+formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
+formEmbedJwtPost f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]
+formEmbedJwtGet f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]

src/Web/PathPieces/Instances.hs

@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Web.PathPieces.Instances
+  (
+  ) where
+
+import Prelude
+
+import Utils.PathPiece
+
+
+$(mapM tuplePathPiece [2..4])

src/Yesod/Core/Instances.hs

@@ -15,37 +15,61 @@ import Data.ByteString.Builder (toLazyByteString)
 import System.FilePath ((</>))
 
 import Data.Aeson
+import Data.Aeson.Types
 
 import Control.Monad.Fix
 import Control.Monad.Fail (MonadFail)
 import qualified Control.Monad.Fail as MonadFail
 import Control.Monad.Except (MonadError(..))
 import Data.Functor.Extend
-  
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
+routeFromPathPiece
+  = parseRoute
+  . over (_2.traverse._2) (fromMaybe "")
+  . over _2 queryToQueryText
+  . decodePath
+  . encodeUtf8
+
+routeToPathPiece :: RenderRoute site => Route site -> Text
+routeToPathPiece
+  = pack
+  . ("/" </>)
+  . unpack
+  . decodeUtf8
+  . toLazyByteString
+  . uncurry encodePath
+  . over _2 queryTextToQuery
+  . over (_2.traverse._2) (assertM' $ not . null)
+  . renderRoute
+
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
-  fromPathPiece
+  fromPathPiece = routeFromPathPiece
-    = parseRoute
+  toPathPiece = routeToPathPiece
-    . over (_2.traverse._2) (fromMaybe "")
-    . over _2 queryToQueryText
-    . decodePath
-    . encodeUtf8
-  toPathPiece
-    = pack
-    . ("/" </>)
-    . unpack
-    . decodeUtf8
-    . toLazyByteString
-    . uncurry encodePath
-    . over _2 queryTextToQuery
-    . over (_2.traverse._2) (assertM' $ not . null)
-    . renderRoute
     
-instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
+instance ParseRoute site => FromJSON (Route site) where
-  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
+  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
 
-instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
+instance RenderRoute site => ToJSON (Route site) where
-  toJSON = String . toPathPiece
+  toJSON = String . routeToPathPiece
+
+instance ParseRoute site => FromJSONKey (Route site) where
+  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
+
+instance RenderRoute site => ToJSONKey (Route site) where
+  toJSONKey = toJSONKeyText routeToPathPiece
+
+instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
+  put = Binary.put . toPathPiece
+  get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
+
+instance RenderRoute site => Hashable (Route site) where
+  hashWithSalt s = hashWithSalt s . routeToPathPiece
 
 
 instance Monad FormResult where
@@ -77,3 +101,5 @@ instance Extend FormResult where
   duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
   duplicated  FormMissing       = FormMissing
   duplicated (FormFailure errs) = FormFailure errs
+
+deriving instance Eq a => Eq (FormResult a)

src/Yesod/Core/Types/Instances.hs

@@ -1,16 +1,48 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Yesod.Core.Types.Instances
-  (
+  ( CachedMemoT(..)
   ) where
 
-import ClassyPrelude
+import ClassyPrelude.Yesod
 import Yesod.Core.Types
 
 import Control.Monad.Fix
 
+import Control.Monad.Memo
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Control.Monad.Logger (MonadLoggerIO)
+  
+
 instance MonadFix m => MonadFix (HandlerT site m) where
   mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
   
 instance MonadFix m => MonadFix (WidgetT site m) where
   mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
+
+
+-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
+newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
+  deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
+                   , MonadIO
+                   , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
+                   , MonadResource, MonadHandler, MonadWidget
+                   , IsString, Semigroup, Monoid
+                   )
+
+deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
+deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
+
+deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
+
+instance MonadTrans (CachedMemoT k v) where
+  lift = CachedMemoT
+
+
+-- | Uses `cachedBy` with a `Binary`-encoded @k@
+instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
+  memo act key = cachedBy (toStrict $ Binary.encode key) $ act key

start.sh

@@ -1,12 +1,11 @@
 #!/usr/bin/env bash
 
 unset HOST
-export DETAILED_LOGGING=true
+export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
-export LOG_ALL=false
+export LOG_ALL=${LOG_ALL:-false}
-export LOGLEVEL=info
+export LOGLEVEL=${LOGLEVEL:-info}
-export DUMMY_LOGIN=true
+export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
-export ALLOW_DEPRECATED=true
+export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
-export PWFILE=users.yml
 
 move-back() {
     mv -v .stack-work .stack-work-run

static/css/utils/form.scss

@@ -1,16 +1,13 @@
 fieldset {
   border: 0;
-  margin: 20px 0 30px;
+  margin: 0;
+  padding: 0;
 
   legend {
     display: none;
   }
 }
 
-.form-group__input > fieldset {
-  margin-bottom: 0;
-}
-
 @media (min-width: 769px) {
   .form-group__input {
     grid-column: 2;

static/css/utils/modal.scss

@@ -1,27 +1,43 @@
-.modal {
+.modals-wrapper {
   position: fixed;
-  left: 50%;
+  left: 0;
-  top: 50%;
+  top: 0;
-  transform: translate(-50%, -50%) scale(0.8, 0.8);
+  width: 100%;
+  height: 100%;
+  z-index: -1;
   display: flex;
+  align-items: center;
+  justify-content: center;
+
+  &.modals-wrapper--open {
+    z-index: 200;
+    width: 100%;
+    height: 100%;
+  }
+}
+
+.modal {
+  position: relative;
+  display: none;
   background-color: rgba(255, 255, 255, 1);
   min-width: 60vw;
+  max-width: 70vw;
   min-height: 100px;
   max-height: calc(100vh - 30px);
   border-radius: 2px;
   z-index: -1;
   color: var(--color-font);
-  padding: 0 65px 0 20px;
+  padding: 0 40px;
   overflow: auto;
   overscroll-behavior: contain;
   pointer-events: none;
   opacity: 0;
 
   &.modal--open {
+    display: flex;
     opacity: 1;
     pointer-events: auto;
     z-index: 200;
-    transform: translate(-50%, -50%) scale(1, 1);
     transition:
       opacity .2s .1s ease-in-out,
       transform .3s ease-in-out;

static/js/services/utilRegistry.js

@@ -144,12 +144,4 @@
     window.UtilRegistry.setupAll();
   });
 
-
-  // REMOVE ME. JUST HERE TO AVOID JS ERRORS
-  window.utils = {
-    setup: function(name) {
-      console.log('not really setting up', name);
-    },
-  };
-
 })();

static/js/utils/checkAll.js

@@ -91,12 +91,10 @@
       checkboxColumn = columns[checkboxColumnId];
       var firstRow = element.querySelector('tr');
       var th = Array.from(firstRow.querySelectorAll('th, td'))[checkboxColumnId];
-      th.innerHTML = 'test';
       checkAllCheckbox = document.createElement('input');
       checkAllCheckbox.setAttribute('type', 'checkbox');
       checkAllCheckbox.setAttribute('id', getCheckboxId());
-      th.innerHTML = '';
+      th.insertBefore(checkAllCheckbox, th.firstChild);
-      th.insertBefore(checkAllCheckbox, null);
 
       // manually set up newly created checkbox
       if (UtilRegistry) {

static/js/utils/form.js

@@ -124,8 +124,10 @@
    *    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
    *
    * Example usage:
+   * ## example with text input
    *  <input id="input-0" type="text">
    *  <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="yes">...</fieldset>
    *  <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="no">...</fieldset>
@@ -135,16 +137,25 @@
    *    <option value="1">One
    *  <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="0">...</fieldset>
    *  <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="1">...</fieldset>
+   * ## example with checkbox
+   *  <input id="checkbox-0" type="checkbox">
+   *  <input id="checkbox-1" type="checkbox">
+   *  <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-0">...</fieldset>
+   *  <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-1">...</fieldset>
    */
 
   var INTERACTIVE_FIELDSET_UTIL_NAME = 'interactiveFieldset';
   var INTERACTIVE_FIELDSET_UTIL_SELECTOR = '[uw-interactive-fieldset]';
+  var INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset__target';
 
   var INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized';
+  var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled]), select:not([disabled]), textarea:not([disabled]), button:not([disabled])';
 
   var interactiveFieldsetUtil = function(element) {
     var conditionalInput;
     var conditionalValue;
+    var target;
+    var childInputs;
 
     function init() {
       if (!element) {
@@ -166,12 +177,23 @@
       }
 
       // param conditionalValue
-      if (!element.dataset.conditionalValue) {
+      if (!element.dataset.conditionalValue && !isCheckbox()) {
         throw new Error('Interactive Fieldset needs a conditional value!');
       }
       conditionalValue = element.dataset.conditionalValue;
 
+      target = element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR);
+      if (!target || element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) {
+        target = element;
+      }
+
+      childInputs = Array.from(element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR));
+
       // add event listener
+      var observer = new MutationObserver(function(mutationsList, observer) {
+        updateVisibility();
+      });
+      observer.observe(conditionalInput, { attributes: true, attributeFilter: ['disabled'] });
       conditionalInput.addEventListener('input', updateVisibility);
 
       // initial visibility update
@@ -188,7 +210,25 @@
     }
 
     function updateVisibility() {
-      element.classList.toggle('hidden', conditionalInput.value !== conditionalValue);
+      var active = matchesConditionalValue() && !conditionalInput.disabled;
+
+      target.classList.toggle('hidden', !active);
+
+      childInputs.forEach(function(el) {
+        el.disabled = !active;
+      });
+    }
+
+    function matchesConditionalValue() {
+      if (isCheckbox()) {
+        return conditionalInput.checked === true;
+      }
+
+      return conditionalInput.value === conditionalValue;
+    }
+
+    function isCheckbox() {
+      return conditionalInput.getAttribute('type') === 'checkbox';
     }
 
     return init();
@@ -260,6 +300,7 @@
   var FORM_GROUP_SELECTOR = '.form-group';
   var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error';
 
+
   var formErrorRemoverUtil = function(element) {
     var formGroups;
 

static/js/utils/inputs.js

@@ -161,7 +161,7 @@
         return false;
       }
 
-      var siblingEl = element.nextElementSibling;
+      var siblingEl = element.nextSibling;
       var parentEl = element.parentElement;
 
       var wrapperEl = document.createElement('div');

static/js/utils/modal.js

@@ -37,9 +37,17 @@
 
   var MAIN_CONTENT_CLASS = 'main__content-body'
 
+  // one singleton wrapper to keep all the modals to avoid CSS bug
+  // with blurry text due to `transform: translate(-50%, -50%)`
+  // will be created (and reused) for the first modal that gets initialized
+  var MODALS_WRAPPER_CLASS = 'modals-wrapper';
+  var MODALS_WRAPPER_SELECTOR = '.' + MODALS_WRAPPER_CLASS;
+  var MODALS_WRAPPER_OPEN_CLASS = 'modals-wrapper--open';
+
   var modalUtil = function(element) {
 
-    var overlayElement = document.createElement('div');
+    var modalsWrapper;
+    var modalOverlay;
     var modalUrl;
 
     function _init() {
@@ -51,6 +59,8 @@
         return false;
       }
 
+      ensureModalWrapper();
+
       // param modalTrigger
       if (!element.dataset.modalTrigger) {
         throw new Error('Modal utility cannot be setup without a trigger element!');
@@ -63,8 +73,6 @@
         setupCloser();
       }
 
-      // setupForm();
-
       // mark as initialized and add modal class for styling
       element.classList.add(MODAL_INITIALIZED_CLASS, MODAL_CLASS);
 
@@ -75,6 +83,24 @@
       };
     }
 
+    function ensureModalWrapper() {
+      modalsWrapper = document.querySelector(MODALS_WRAPPER_SELECTOR);
+      if (!modalsWrapper) {
+        // create modal wrapper
+        modalsWrapper = document.createElement('div');
+        modalsWrapper.classList.add(MODALS_WRAPPER_CLASS);
+        document.body.appendChild(modalsWrapper);
+      }
+
+      modalOverlay = modalsWrapper.querySelector('.' + MODAL_OVERLAY_CLASS);
+      if (!modalOverlay) {
+        // create modal overlay
+        modalOverlay = document.createElement('div');
+        modalOverlay.classList.add(MODAL_OVERLAY_CLASS);
+        modalsWrapper.appendChild(modalOverlay);
+      }
+    }
+
     function setupTrigger() {
       var triggerSelector = element.dataset.modalTrigger;
       if (!triggerSelector.startsWith('#')) {
@@ -96,7 +122,7 @@
       element.insertBefore(closerElement, null);
       closerElement.classList.add(MODAL_CLOSER_CLASS);
       closerElement.addEventListener('click', onCloseClicked, false);
-      overlayElement.addEventListener('click', onCloseClicked, false);
+      modalOverlay.addEventListener('click', onCloseClicked, false);
     }
 
     function onTriggerClicked(event) {
@@ -116,11 +142,10 @@
     }
 
     function open() {
-      document.body.insertBefore(element, null);
       element.classList.add(MODAL_OPEN_CLASS);
-      overlayElement.classList.add(MODAL_OVERLAY_CLASS);
+      modalOverlay.classList.add(MODAL_OVERLAY_OPEN_CLASS);
-      document.body.insertBefore(overlayElement, element);
+      modalsWrapper.classList.add(MODALS_WRAPPER_OPEN_CLASS);
-      overlayElement.classList.add(MODAL_OVERLAY_OPEN_CLASS);
+      modalsWrapper.appendChild(element);
 
       if (modalUrl) {
         fillModal(modalUrl);
@@ -130,8 +155,9 @@
     }
 
     function close() {
-      overlayElement.classList.remove(MODAL_OVERLAY_OPEN_CLASS);
+      modalOverlay.classList.remove(MODAL_OVERLAY_OPEN_CLASS);
       element.classList.remove(MODAL_OPEN_CLASS);
+      modalsWrapper.classList.remove(MODALS_WRAPPER_OPEN_CLASS);
 
       document.removeEventListener('keyup', onKeyUp);
     };

templates/course/lecturerMassInput/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=3>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}

templates/course/lecturerMassInput/cellInvitation.hamlet

@@ -0,0 +1,12 @@
+ $newline never
+ <td>
+   #{csrf}
+   <span style="font-family: monospace">
+     #{lEmail}
+ <td>
+   <div .tooltip>
+     <div .tooltip__handle>
+     <div .tooltip__content>
+       _{MsgEmailInvitationWarning}
+ <td>
+   ^{fvInput lrwView}

templates/course/lecturerMassInput/cellKnown.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{nameEmailWidget userEmail userDisplayName userSurname} #
+<td>
+  ^{fvInput lrwView}

templates/course/lecturerMassInput/layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/courseLecInvite.hamlet

@@ -0,0 +1,3 @@
+<p>
+  _{MsgCourseLecInviteExplanation}
+^{btnWidget}

templates/default-layout.hamlet

@@ -15,16 +15,15 @@ $if not isModal
 
     <div .main__content-body>
 
-      <section>
+      $maybe headline <- contentHeadline
-        $maybe headline <- contentHeadline
+        <h1 .headline-one>
-          <h1 .headline-one>
+          <!-- $maybe back <- lastMaybe parents
-            <!-- $maybe back <- lastMaybe parents
+            <a .breadcrumbs__link href="@{fst back}">#{snd back}  -->
-              <a .breadcrumbs__link href="@{fst back}">#{snd back}  -->
+          ^{headline}
-            ^{headline}
 
-        $if not isModal && hasPageActions
+      $if not isModal && hasPageActions
-          <!-- page actions -->
+        <!-- page actions -->
-          ^{pageaction}
+        ^{pageaction}
 
       <!-- actual content -->
       ^{widget}

templates/default-layout.lucius

@@ -541,5 +541,5 @@ section {
 }
 
 .headline-one {
-  margin-bottom: 15px;
+  margin-bottom: 10px;
 }

templates/help.hamlet

@@ -1,3 +1,4 @@
-<p>
+<section>
   _{MsgHelpIntroduction}
-^{formWidget}
+<section>
+  ^{formWidget}

templates/mail/correctorInvitation.hamlet

@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      _{MsgSheetCorrInviteExplanation}
+    <p>
+      <a href=#{invitationUrl'}>
+        _{MsgInvitationAcceptDecline}

templates/mail/editNotifications.hamlet

@@ -1,4 +1,3 @@
 <p>      
-  <a href=@{ProfileR}>
+  <a href=#{editNotificationsUrl'}>
-    _{MsgProfileHeading}
+    _{MsgMailEditNotifications}
-  \ _{MsgMailEditNotifications}

templates/mail/lecturerInvitation.hamlet

@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      _{MsgCourseLecInviteExplanation}
+    <p>
+      <a href=#{invitationUrl'}>
+        _{MsgInvitationAcceptDecline}

templates/profile.hamlet

@@ -1,2 +0,0 @@
-<div .profile>
-  ^{settingsForm}