From af40d86de952b4257f91bc212c5eb85014e0ef53 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 9 Nov 2018 17:45:06 +0100
Subject: [PATCH 01/10] Bugfix: assignAction  no longer delivers duplicate
 actions

---
 src/Handler/Corrections.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index e97f93c9e..99d7510b5 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -366,13 +366,13 @@ assignAction :: Either CourseId SheetId -> ActionCorrections'
 assignAction selId = ( CorrSetCorrector
                      , wFormToAForm $ do
                          correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
-                           E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
-                           E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+                           E.on $   user E.^. UserId   E.==. sheetCorrector E.^. SheetCorrectorUser
+                           E.on $  sheet E.^. SheetId  E.==. sheetCorrector E.^. SheetCorrectorSheet
                            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
 
                            E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
 
-                           return user
+                           E.distinct $ return user
 
                          mr <- getMessageRender
 

From 05c4a5da2fa2f495d9f8dfeeb9d758366f1bc451 Mon Sep 17 00:00:00 2001
From: Felix Hamann <felix.hamann@satellytes.com>
Date: Sun, 11 Nov 2018 23:13:57 +0100
Subject: [PATCH 02/10] updates to README

---
 README.md | 45 ++++++++++++++++++++++++++-------------------
 1 file changed, 26 insertions(+), 19 deletions(-)

diff --git a/README.md b/README.md
index e6b42fe4f..afa47f082 100644
--- a/README.md
+++ b/README.md
@@ -6,68 +6,75 @@ The following Description applies to Ubuntu or similar.
   Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`.
 
 ## LDAP
-  install:  
+  install:
   `sudo apt-get install slapd ldap-utils`
 
 
 ## PostgreSQL
-  install:  
+  install:
   `sudo apt-get install postgresql`
 
-  switch to user *postgres* (got created during installation):  
+  switch to user *postgres* (got created during installation):
   `sudo -i -u postgres`
 
-  add db user *uniworx*:  
+  add db user *uniworx*:
   `createuser --interactive`
 
   you'll get a prompt:
 
   ```
-  Enter name of role to add:` - [enter 'uniworx']
+  Enter name of role to add:` - uniworx
   Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
+  Password: uniworx
+  ...
   ```
 
-  create database *uniworx*:  
+  create database *uniworx*:
   `createdb uniworx`
+  after you added the database switch back to your own user with `Ctrl + D`.
 
-  to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:  
+  to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
   `sudo adduser uniworx`
 
-  log-in as new user *uniworx*:  
+  log-in as new user *uniworx*:
   `sudo -i -u uniworx`
 
   you can now use `psql uniworx` to execute SQL-commands and such.
 
 ## stack
-  Install with:  
+  Install with:
   `curl -sSL https://get.haskellstack.org/ | sh`
 
-  setup stack and install dependencies:  
+  setup stack and install dependencies:
   `stack setup`
 
-  During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using  
+  During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
   `sudo apt-get install libsasl2-dev libldap2-dev`
 
-  If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*  
-  Go ahead an install `libpq-dev` with  
+  If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
+  Go ahead an install `libpq-dev` with
   `sudo apt-get install libpq-dev`
 
-  Build the app:  
+  Other packages you might need to install during this process:
+  `sudo apt-get install pkg-config`
+  `sudo apt-get install libsodium-dev`
+
+  Build the app:
   `stack build`
 
   This might take a few minutes if not hours... be prepared.
 
-  install yesod:  
+  install yesod:
   `stack install yesod-bin --install-ghc`
 
 ## Add Dumy-Data and run the app
   After building the app you can prepare the database and add some dummy data:
-  `./fill-db.hs`
+  `./db.sh -f`
 
-  Run the app:  
+  Run the app:
   `./start.sh`
 
-  `Devel application launched: http://localhost:3000`  
+  `Devel application launched: http://localhost:3000`
   means you are good to go.
 
   If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
@@ -75,7 +82,7 @@ The following Description applies to Ubuntu or similar.
 ***
 
 # Sources and more infos
-  PostgreSQl:   
+  PostgreSQl:
   https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04
 
   stack:   https://docs.haskellstack.org/en/stable/README/#how-to-install

From 22ebc3d96ab62b4b8919575d2ad85af1aaa2b569 Mon Sep 17 00:00:00 2001
From: Felix Hamann <felix.hamann@satellytes.com>
Date: Sun, 11 Nov 2018 23:24:18 +0100
Subject: [PATCH 03/10] more beautifully signalled shell commands in README

---
 README.md | 85 ++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 62 insertions(+), 23 deletions(-)

diff --git a/README.md b/README.md
index afa47f082..2d59db31a 100644
--- a/README.md
+++ b/README.md
@@ -3,26 +3,37 @@
 The following Description applies to Ubuntu or similar.
 
 ## Clone repository
-  Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`.
+  Clone this repository and navigate into
+  ```sh
+  $ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX
+  ```
 
 ## LDAP
   install:
-  `sudo apt-get install slapd ldap-utils`
+  ```sh
+  $ sudo apt-get install slapd ldap-utils
+  ```
 
 
 ## PostgreSQL
   install:
-  `sudo apt-get install postgresql`
+  ```sh
+  $ sudo apt-get install postgresql
+  ```
 
   switch to user *postgres* (got created during installation):
-  `sudo -i -u postgres`
+  ```sh
+  $ sudo -i -u postgres
+  ```
 
   add db user *uniworx*:
-  `createuser --interactive`
+  ```sh
+  $ createuser --interactive
+  ```
 
   you'll get a prompt:
 
-  ```
+  ```sh
   Enter name of role to add:` - uniworx
   Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
   Password: uniworx
@@ -30,52 +41,80 @@ The following Description applies to Ubuntu or similar.
   ```
 
   create database *uniworx*:
-  `createdb uniworx`
+  ```sh
+  $ createdb uniworx
+  ```
+
   after you added the database switch back to your own user with `Ctrl + D`.
 
   to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
-  `sudo adduser uniworx`
+  ```sh
+  $ sudo adduser uniworx
+  ```
 
   log-in as new user *uniworx*:
-  `sudo -i -u uniworx`
+  ```sh
+  $ sudo -i -u uniworx
+  ```
 
-  you can now use `psql uniworx` to execute SQL-commands and such.
+  you can now use
+  ```sh
+  $ psql uniworx
+  ```
+  to execute SQL-commands and such.
 
 ## stack
   Install with:
-  `curl -sSL https://get.haskellstack.org/ | sh`
+  ```sh
+  $ curl -sSL https://get.haskellstack.org/ | sh
+  ```
 
   setup stack and install dependencies:
-  `stack setup`
+  ```sh
+  $ stack setup
+  ```
 
   During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
-  `sudo apt-get install libsasl2-dev libldap2-dev`
+  ```sh
+  $ sudo apt-get install libsasl2-dev libldap2-dev
+  ```
 
   If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
   Go ahead an install `libpq-dev` with
-  `sudo apt-get install libpq-dev`
+  ```sh
+  $ sudo apt-get install libpq-dev
+  ```
 
   Other packages you might need to install during this process:
-  `sudo apt-get install pkg-config`
-  `sudo apt-get install libsodium-dev`
+  ```sh
+  $ sudo apt-get install pkg-config
+  sudo apt-get install libsodium-dev
+  ```
 
   Build the app:
-  `stack build`
+  ```sh
+  $ stack build
+  ```
 
   This might take a few minutes if not hours... be prepared.
 
   install yesod:
-  `stack install yesod-bin --install-ghc`
+  ```sh
+  $ stack install yesod-bin --install-ghc
+  ```
 
 ## Add Dumy-Data and run the app
   After building the app you can prepare the database and add some dummy data:
-  `./db.sh -f`
+  ```sh
+  $ ./db.sh -f
+  ```
 
   Run the app:
-  `./start.sh`
-
-  `Devel application launched: http://localhost:3000`
-  means you are good to go.
+  ```sh
+  $ ./start.sh
+  ...
+  Devel application launched: http://localhost:3000
+  ```
 
   If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
 

From 56d5da648aca7877194b022a7bf27b8ae41ffd9e Mon Sep 17 00:00:00 2001
From: Felix Hamann <felix.hamann@satellytes.com>
Date: Sun, 11 Nov 2018 23:34:47 +0100
Subject: [PATCH 04/10] dont text-align:right number inputs

---
 templates/standalone/inputs.lucius | 1 -
 1 file changed, 1 deletion(-)

diff --git a/templates/standalone/inputs.lucius b/templates/standalone/inputs.lucius
index 54e6aa5a6..5f9d90206 100644
--- a/templates/standalone/inputs.lucius
+++ b/templates/standalone/inputs.lucius
@@ -91,7 +91,6 @@ input[type*="time"] {
 
 input[type="number"] {
   width: 100px;
-  text-align: right;
 }
 
 input[type*="date"],

From 673d98ff91c0346c54ee3a81542a1bdd479480d8 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Mon, 12 Nov 2018 17:12:24 +0100
Subject: [PATCH 05/10] Single submission assign corrector

---
 .vscode/tasks.json                 |  3 +-
 messages/uniworx/de.msg            | 10 ++--
 models                             | 14 ++---
 routes                             |  3 +-
 src/Foundation.hs                  | 41 ++++++++------
 src/Handler/Corrections.hs         | 87 +++++++++++++++++++++---------
 templates/formPage.hamlet          |  2 +-
 templates/formPageI18n.hamlet      |  2 +-
 templates/submission-assign.hamlet |  2 +
 9 files changed, 109 insertions(+), 55 deletions(-)
 create mode 100644 templates/submission-assign.hamlet

diff --git a/.vscode/tasks.json b/.vscode/tasks.json
index ac3e4e9ee..9f3625c7e 100644
--- a/.vscode/tasks.json
+++ b/.vscode/tasks.json
@@ -28,7 +28,8 @@
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
-      }      
+      },
+      "problemMatcher": []
     },
     {
       "label": "test",
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 5c7b3cfe6..14fff01cf 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -142,6 +142,8 @@ SubmissionGroupName: Gruppenname
 CorrectionsTitle: Zugewiesene Korrekturen
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
 CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
+CorrectorAssignTitle: Korrektor zuweisen
+
 
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
@@ -189,6 +191,7 @@ CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Ante
 
 DeleteRow: Zeile entfernen
 ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorUpdated: Korrektor erfolgreich aktualisiert
 CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
 CorrectorsPlaceholder: Korrektoren...
 CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
@@ -258,7 +261,7 @@ RatingDone: Bewertung fertiggestellt
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
-PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein 
+PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
 ColumnRatingPointsDone: Punktzahl/Abgeschlossen
 Pseudonyms: Pseudonyme
@@ -366,7 +369,7 @@ SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
 SheetGradingPassBinary:  Bestanden/Nicht Bestanden
-SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. 
+SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
 
 SheetGradingPoints': Punkte
 SheetGradingPassPoints': Bestehen nach Punkten
@@ -424,7 +427,7 @@ HelpUser: Meinen Benutzeraccount
 HelpAnonymous: Keine Antwort (Anonym)
 HelpEMail: E-Mail
 HelpRequest: Supportanfrage / Verbesserungsvorschlag
-HelpProblemPage: Problematische Seite 
+HelpProblemPage: Problematische Seite
 HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
 HelpSent: Ihre Supportanfrage wurde weitergeleitet.
 
@@ -484,6 +487,7 @@ ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
 ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
 ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
 ErrMsgHeading: Fehlermeldung entschlüsseln
+ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
 
 InvalidRoute: Konnte URL nicht interpretieren
 
diff --git a/models b/models
index 32dba863f..47e95f579 100644
--- a/models
+++ b/models
@@ -15,7 +15,7 @@ User json
     notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
-    deriving Show
+    deriving Show Eq
 UserAdmin
     user   UserId
     school SchoolId
@@ -46,9 +46,9 @@ Term json
     start         Day            -- TermKey   :: TermIdentifier -> TermId
     end           Day
     holidays      [Day]
-    lectureStart  Day 
-    lectureEnd    Day 
-    active        Bool    
+    lectureStart  Day
+    lectureEnd    Day
+    active        Bool
     Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
     deriving Show      -- type TermId = Key Term
 School json
@@ -57,7 +57,7 @@ School json
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
     Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
-    deriving Eq    
+    deriving Eq
 DegreeCourse json
     course       CourseId
     degree       StudyDegreeId
@@ -89,7 +89,7 @@ CourseFavourite
     course       CourseId
     UniqueCourseFavourite user course
     deriving Show
-Lecturer 
+Lecturer
     user         UserId
     course       CourseId
     UniqueLecturer user course
@@ -135,7 +135,7 @@ SheetFile
     file            FileId
     type            SheetFileType
     UniqueSheetFile file sheet type
-File        
+File
     title           FilePath
     content         ByteString Maybe -- Nothing iff this is a directory
     modified        UTCTime
diff --git a/routes b/routes
index 399f3bf72..b4c90b0cd 100644
--- a/routes
+++ b/routes
@@ -23,7 +23,7 @@
 --    !isWrite     -- only if it is write access     (i.e. POST only) why needed???
 --
 --    !deprecated  -- like free, but logs and gives a warning; entirely disabled in production
---    !development -- like free, but only for development builds 
+--    !development -- like free, but only for development builds
 
 /static StaticR Static appStatic                              !free
 /auth   AuthR   Auth   getAuth                                !free
@@ -79,6 +79,7 @@
     /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
       /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
       /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner
+      /assign                   SAssignR      GET POST	      !lecturerANDtime
       /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
diff --git a/src/Foundation.hs b/src/Foundation.hs
index a2d0f20ac..ee0c578d5 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -208,7 +208,7 @@ instance RenderMessage UniWorX (SheetType) where
   renderMessage foundation ls sheetType = case sheetType of
       NotGraded -> mr $ SheetTypeHeader NotGraded
       other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
-    where 
+    where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
@@ -432,12 +432,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
         guard visible
 
         case subRoute of
-          SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
-          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
-          SubmissionNewR         -> guard   active
-          SubmissionR _ _        -> guard   active
-          _                      -> return ()
+          SFileR SheetExercise _    -> guard $ sheetActiveFrom <= cTime
+          SFileR SheetHint     _    -> guard $ maybe False (<= cTime) sheetHintFrom
+          SFileR SheetSolution _    -> guard $ maybe False (<= cTime) sheetSolutionFrom
+          SubmissionNewR            -> guard   active
+          SubmissionR _ SAssignR    -> guard $ not active -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
+          SubmissionR _ _           -> guard   active
+          _                         -> return ()
 
         return Authorized
 
@@ -525,7 +526,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          SystemMessage{..} <- MaybeT $ get smId
          isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
          guard $ not systemMessageAuthenticatedOnly || isAuthenticated
-         return Authorized      
+         return Authorized
        r -> $unsupportedAuthPredicate "authentication" r
    )
   ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
@@ -601,7 +602,7 @@ instance Yesod UniWorX where
                 cid  <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
                 user <- MaybeT $ get uid
                 let courseFavourite = CourseFavourite uid now cid
-    
+
                 $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
                 -- update Favourites
                 void . lift $ upsertBy
@@ -650,7 +651,7 @@ instance Yesod UniWorX where
                     #{formatted}
                 |]
             | otherwise -> plaintext
-        
+
         errPage = case err of
           NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
           InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
@@ -938,7 +939,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       }
   , do
       mCurrentRoute <- getCurrentRoute
-      
+
       return MenuItem
         { menuItemType = NavbarRight
         , menuItemLabel = MsgMenuHelp
@@ -1226,6 +1227,14 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgCorrectorAssignTitle
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SCorrR) =
   [ MenuItem
@@ -1455,7 +1464,7 @@ routeNormalizers =
       hasChanged shn sheetName
       return $ CSheetR tid ssh csh sheetName subRoute
 
-  
+
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend
@@ -1525,7 +1534,7 @@ instance YesodAuth UniWorX where
             userEmail' = lookup (Attr "mail") ldapData
             userDisplayName' = lookup (Attr "displayName") ldapData
             userSurname' = lookup (Attr "sn") ldapData
-          
+
             userAuthentication
               | isPWHash  = error "PWHash should only work for users that are already known"
               | otherwise = AuthLDAP
@@ -1631,13 +1640,13 @@ instance YesodMail UniWorX where
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
     withResource pool act
-  mailT ctx mail = defMailT ctx $ do 
+  mailT ctx mail = defMailT ctx $ do
     void setMailObjectId
     setDateCurrent
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-  
+
     ret <- mail
-  
+
     setMailSmtpData
     return ret
 
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 99d7510b5..a64605446 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -83,11 +83,7 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
 
 colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
-        $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
-          let tid = course ^. _3
-              ssh = course ^. _4
-              csh = course ^. _2
-          in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
+        $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
 
 colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@@ -135,7 +131,7 @@ colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
   protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
   in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
-  
+
 colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
   let csh = course ^. _2
@@ -181,7 +177,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
 
 
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-            
+
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
                      => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
@@ -303,9 +299,10 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
         unless (null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
-          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
+          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
           addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
+
         unless (null unassigned) $ do
           num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
                     [ SubmissionRatingBy       =. Just uid
@@ -337,7 +334,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
         unless (null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
-          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
+          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
           addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         unless (null unassigned) $ do
@@ -356,7 +353,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
 
 
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
-  
+
 downloadAction :: ActionCorrections'
 downloadAction = ( CorrDownload
                  , pure CorrDownloadData
@@ -483,8 +480,8 @@ postCorrectionR tid ssh csh shn cid = do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
           pointsForm = case sheetType of
             NotGraded  -> pure Nothing
-            _otherwise -> aopt  (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) 
-                                (fslpI MsgRatingPoints "Punktezahl") 
+            _otherwise -> aopt  (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
+                                (fslpI MsgRatingPoints "Punktezahl")
                                 (Just submissionRatingPoints)
 
       ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
@@ -500,7 +497,7 @@ postCorrectionR tid ssh csh shn cid = do
       case corrResult of
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-        FormSuccess (rated, ratingPoints', ratingComment') 
+        FormSuccess (rated, ratingPoints', ratingComment')
           | errs <- validateRating sheetType Rating'
                       { ratingPoints=ratingPoints'
                       , ratingComment=ratingComment'
@@ -511,7 +508,7 @@ postCorrectionR tid ssh csh shn cid = do
             runDBJobs $ do
               uid <- liftHandlerT requireAuthId
               now <- liftIO getCurrentTime
-            
+
               update sub  [ SubmissionRatingBy      =. Just uid
                           , SubmissionRatingTime    =. (now <$ guard rated)
                           , SubmissionRatingPoints  =. ratingPoints'
@@ -522,7 +519,7 @@ postCorrectionR tid ssh csh shn cid = do
 
               when (rated && isNothing submissionRatingTime) $ do
                 $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-                queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
+                queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
 
             redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
@@ -531,7 +528,7 @@ postCorrectionR tid ssh csh shn cid = do
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess fileUploads -> do
           uid <- requireAuthId
-          
+
           void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
           addMessageI Success MsgRatingFilesUpdated
@@ -545,7 +542,7 @@ postCorrectionR tid ssh csh shn cid = do
     _ -> notFound
 getCorrectionUserR tid ssh csh shn cid = do
   sub <- decrypt cid
-  
+
   results <- runDB $ correctionData tid ssh csh shn sub
 
   case results of
@@ -557,7 +554,7 @@ getCorrectionUserR tid ssh csh shn cid = do
         $(widgetFile "correction-user")
     _ -> notFound
 
-  
+
 getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
@@ -577,7 +574,7 @@ postCorrectionsUploadR = do
             subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
             mr <- (toHtml .) <$> getMessageRender
             addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
-        
+
 
   defaultLayout $
     $(widgetFile "corrections-upload")
@@ -692,17 +689,17 @@ postCorrectionsCreateR = do
                 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
-                    }               
+                    }
                 addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
       redirect CorrectionsGradeR
-                
-  
+
+
   defaultLayout $
     $(widgetFile "corrections-create")
   where
     partitionEithers' :: [[Either a b]] -> ([[b]], [a])
-    partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) 
-    
+    partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
+
     textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
     textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
       = let
@@ -735,7 +732,7 @@ postCorrectionsGradeR = do
       psValidator = def
         & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
-  
+
   tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
     cID <- encrypt subId
     void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
@@ -762,3 +759,43 @@ postCorrectionsGradeR = do
 
   defaultLayout $
     $(widgetFile "corrections-grade")
+
+
+getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSAssignR = postSAssignR
+postSAssignR tid ssh csh shn cID = do
+  let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
+  sId <- decrypt cID
+  (currentCorrector, sheetCorrectors) <- runDB $ do
+    Submission{submissionRatingBy, submissionSheet} <- get404 sId
+    -- Beginn Verify that CryptoId matches ordinary prameters
+    -- Necessarry, since authorisation checks those parameters only, but can be changed by user!
+    Sheet{sheetCourse, sheetName} <- get404 submissionSheet
+    Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse
+    let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName]
+    unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch]
+    -- End Verification
+    sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
+    userCorrector <- traverse getJustEntity submissionRatingBy
+    return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
+
+  $logDebugS "SAssignR" $ tshow currentCorrector
+  let correctorField  = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
+  ((corrResult, corrForm), corrEncoding) <- runFormPost . renderAForm FormStandard $
+        aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
+    <*  submitButton
+  formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
+    when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
+      now <- liftIO getCurrentTime
+      update sId  [ SubmissionRatingBy =. mbUserId
+                  , SubmissionRatingAssigned =. (now <$ mbUserId)
+                  ]
+      addMessageI Success MsgCorrectorUpdated
+    redirect actionUrl
+  defaultLayout $ do
+      setTitleI MsgCorrectorAssignTitle
+      $(widgetFile "submission-assign")
+
+
+
+
diff --git a/templates/formPage.hamlet b/templates/formPage.hamlet
index f75289e29..c0b36d13f 100644
--- a/templates/formPage.hamlet
+++ b/templates/formPage.hamlet
@@ -1,2 +1,2 @@
-<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
+<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
   ^{formWidget}
diff --git a/templates/formPageI18n.hamlet b/templates/formPageI18n.hamlet
index 34c3bd3f9..bf8b877ca 100644
--- a/templates/formPageI18n.hamlet
+++ b/templates/formPageI18n.hamlet
@@ -1,5 +1,5 @@
 $maybe text <- formText
   <h3>
     _{text}
-<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
+<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
    ^{formWidget}
diff --git a/templates/submission-assign.hamlet b/templates/submission-assign.hamlet
new file mode 100644
index 000000000..0c6d86757
--- /dev/null
+++ b/templates/submission-assign.hamlet
@@ -0,0 +1,2 @@
+<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
+   ^{corrForm}
\ No newline at end of file

From b27fb8f391800f195f6434bf96ce0fd9f4f30ea6 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Tue, 13 Nov 2018 14:23:43 +0100
Subject: [PATCH 06/10] Bugfix: SAssignR time attribute

---
 src/Foundation.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index ee0c578d5..239cc33cc 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -427,7 +427,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
         cTime <- liftIO getCurrentTime
         let
           visible = NTop sheetVisibleFrom <= NTop (Just cTime)
-          active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+          active  = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+          marking = cTime > sheetActiveTo
 
         guard visible
 
@@ -436,7 +437,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
           SFileR SheetHint     _    -> guard $ maybe False (<= cTime) sheetHintFrom
           SFileR SheetSolution _    -> guard $ maybe False (<= cTime) sheetSolutionFrom
           SubmissionNewR            -> guard   active
-          SubmissionR _ SAssignR    -> guard $ not active -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
+          SubmissionR _ SAssignR    -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
           SubmissionR _ _           -> guard   active
           _                         -> return ()
 

From dc4f37c921d9c1fcbee8af2e300a37aed57f0652 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Tue, 13 Nov 2018 15:36:59 +0100
Subject: [PATCH 07/10] Subtask for #233. Rights checked for Corrector
 assignment

---
 messages/uniworx/de.msg                       |  1 +
 routes                                        |  4 +-
 src/Handler/Corrections.hs                    | 44 ++++++++++++++-----
 src/Utils.hs                                  | 20 ++++++++-
 .../submissionsAssignUnauthorized.hamlet      |  5 +++
 5 files changed, 58 insertions(+), 16 deletions(-)
 create mode 100644 templates/messages/submissionsAssignUnauthorized.hamlet

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 14fff01cf..f28a96c9c 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -231,6 +231,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
 NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
 
 SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
+SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
 UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
 NoCorrector: Kein Korrektor
 RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
diff --git a/routes b/routes
index b4c90b0cd..406500f4d 100644
--- a/routes
+++ b/routes
@@ -77,10 +77,10 @@
     /subs/new                   SubmissionNewR GET POST        !timeANDregisteredANDuser-submissions
     /subs/own                   SubmissionOwnR GET             !free -- just redirect
     /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
-      /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
+      /                         SubShowR      GET POST !ownerANDtime !ownerANDisRead
       /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner
       /assign                   SAssignR      GET POST	      !lecturerANDtime
-      /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
+      /correction               CorrectionR   GET POST        !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
     /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index a64605446..06cc76545 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -302,9 +302,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
           addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
-
-        unless (null unassigned) $ do
-          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
+        unless (null unassignedUnauth) $ do
+          let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
+          unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
+          $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
+        unless (null unassignedAuth) $ do
+          num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
                     [ SubmissionRatingBy       =. Just uid
                     , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
                     ]
@@ -316,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             return (E.countRows :: E.SqlExpr (E.Value Int64))
         when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
       redirect currentRoute
-    FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
+    FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
       subs <- mapM decrypt $ Set.toList subs'
       runDB $ do
         num <- updateWhereCount [SubmissionId <-. subs]
-                  [ SubmissionRatingPoints   =. Nothing
-                  , SubmissionRatingComment  =. Nothing
-                  , SubmissionRatingBy       =. Nothing
+                  [ SubmissionRatingBy       =. Nothing
                   , SubmissionRatingAssigned =. Nothing
                   , SubmissionRatingTime     =. Nothing
+                  -- , SubmissionRatingPoints   =. Nothing -- Kept for easy reassignment by 2nd corrector
+                  -- , SubmissionRatingComment  =. Nothing -- Kept for easy reassignment by 2nd corrector
                   ]
         addMessageI Success $ MsgRemovedCorrections num
       redirect currentRoute
@@ -337,8 +341,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
           addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
-        unless (null unassigned) $ do
-          (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
+        unless (null unassignedUnauth) $ do
+          let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
+          unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
+          $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
+        unless (null unassignedAuth) $ do
+          (assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
           unless (null assigned) $
             addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
           unless (null stillUnassigned) $ do
@@ -350,7 +359,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
-
+  where
+    authorizedToAssign :: SubmissionId -> DB Bool
+    authorizedToAssign sId = do
+      [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
+        E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
+          E.on $  sheet E.^. SheetId  E.==. submission E.^. SubmissionSheet
+          E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+          E.where_ $ submission E.^. SubmissionId E.==. E.val sId
+          return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
+      cID <- encrypt sId
+      let route  = CSubmissionR tid ssh csh shn cID SAssignR
+      (== Authorized) <$> evalAccessDB route True
 
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
 
@@ -768,12 +788,12 @@ postSAssignR tid ssh csh shn cID = do
   sId <- decrypt cID
   (currentCorrector, sheetCorrectors) <- runDB $ do
     Submission{submissionRatingBy, submissionSheet} <- get404 sId
-    -- Beginn Verify that CryptoId matches ordinary prameters
+    -- Beginn Verify that CryptoId matches ordinary prameters, see #233
     -- Necessarry, since authorisation checks those parameters only, but can be changed by user!
     Sheet{sheetCourse, sheetName} <- get404 submissionSheet
     Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse
     let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName]
-    unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch]
+    unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored
     -- End Verification
     sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
     userCorrector <- traverse getJustEntity submissionRatingBy
diff --git a/src/Utils.hs b/src/Utils.hs
index 23dc860ff..c035e8d93 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x
 
 maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
 maybePositive a | a > 0     = Just a
-                | otherwise = Nothing 
+                | otherwise = Nothing
 
-positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive                
+positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
 positiveSum (Sum x) = maybePositive x
 
 maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
@@ -443,6 +443,22 @@ orM = Fold.foldr or2M (return False)
 anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
 anyM xs f = orM $ fmap f xs
 
+partitionM :: forall mono m .
+  ( MonoFoldable mono
+  , Monoid mono
+  , MonoPointed mono
+  , Monad m)
+    => (Element mono -> m Bool) -> mono -> m (mono, mono)
+partitionM crit = ofoldlM dist mempty
+  where
+    dist :: (mono,mono) -> Element mono -> m (mono,mono)
+    dist acc x = do
+      okay <- crit x
+      return $ if
+        | okay ->      acc `mappend` (opoint x, mempty)
+        | otherwise -> acc `mappend` (mempty, opoint x)
+
+
 --------------
 -- Sessions --
 --------------
diff --git a/templates/messages/submissionsAssignUnauthorized.hamlet b/templates/messages/submissionsAssignUnauthorized.hamlet
new file mode 100644
index 000000000..f0002faed
--- /dev/null
+++ b/templates/messages/submissionsAssignUnauthorized.hamlet
@@ -0,0 +1,5 @@
+_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
+
+<ul>
+  $forall cID <- unassignedUnauth'
+    <li><pre>#{toPathPiece cID}

From 94ee06d3c7c3b3cbba1ee92edd5165714bde4937 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Tue, 13 Nov 2018 16:03:13 +0100
Subject: [PATCH 08/10] All routes with CryptoIds are verified now, see #233

---
 src/Foundation.hs          | 10 ++++++++++
 src/Handler/Corrections.hs |  7 -------
 2 files changed, 10 insertions(+), 7 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 239cc33cc..92049906e 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1427,6 +1427,7 @@ routeNormalizers =
   , ncSchool
   , ncCourse
   , ncSheet
+  , verifySubmission
   ]
   where
     normalizeRender route = route <$ do
@@ -1464,6 +1465,15 @@ routeNormalizers =
       Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
       hasChanged shn sheetName
       return $ CSheetR tid ssh csh sheetName subRoute
+    verifySubmission = maybeOrig $ \route -> do
+      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
+      sId <- decrypt cID
+      Submission{submissionSheet}   <- lift . lift $ get404 sId
+      Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
+      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
 
 
 -- How to run database actions.
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 06cc76545..73f0df665 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -788,13 +788,6 @@ postSAssignR tid ssh csh shn cID = do
   sId <- decrypt cID
   (currentCorrector, sheetCorrectors) <- runDB $ do
     Submission{submissionRatingBy, submissionSheet} <- get404 sId
-    -- Beginn Verify that CryptoId matches ordinary prameters, see #233
-    -- Necessarry, since authorisation checks those parameters only, but can be changed by user!
-    Sheet{sheetCourse, sheetName} <- get404 submissionSheet
-    Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse
-    let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName]
-    unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored
-    -- End Verification
     sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
     userCorrector <- traverse getJustEntity submissionRatingBy
     return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)

From 4697efab5ff8cc821a48042fba87d45afb8ec610 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 14 Nov 2018 14:20:32 +0100
Subject: [PATCH 09/10] Overhaul auth-predicates

---
 ghci.sh                     |   4 +-
 messages/uniworx/de.msg     |  27 +-
 package.yaml                |   1 +
 routes                      |   6 +-
 src/Foundation.hs           | 526 +++++++++++++++++++-----------------
 src/Handler/Home.hs         |  20 ++
 src/Handler/Profile.hs      |  20 +-
 src/Handler/Utils/Form.hs   |  29 +-
 src/Import/NoFoundation.hs  |   2 +-
 src/Model/Types.hs          |  65 ++++-
 src/Utils.hs                |  46 ++--
 src/Utils/Lens.hs           |   3 +
 src/Utils/Message.hs        |  12 +-
 src/Yesod/Core/Instances.hs |   7 +
 start.sh                    |   4 +-
 templates/authpreds.hamlet  |   2 +
 test.sh                     |   4 +-
 17 files changed, 482 insertions(+), 296 deletions(-)
 create mode 100644 templates/authpreds.hamlet

diff --git a/ghci.sh b/ghci.sh
index 825a936f0..76b9b6e9b 100755
--- a/ghci.sh
+++ b/ghci.sh
@@ -7,11 +7,11 @@ export DUMMY_LOGIN=true
 
 move-back() {
     mv -v .stack-work .stack-work-ghci
-    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
 }
 
 if [[ -d .stack-work-ghci ]]; then
-    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
     mv -v .stack-work-ghci .stack-work
     trap move-back EXIT
 fi
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 5c7b3cfe6..85936833b 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -146,6 +146,7 @@ CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
+UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
@@ -167,7 +168,9 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
 UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
-UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
+UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@@ -299,6 +302,8 @@ DownloadFiles: Dateien automatisch herunterladen
 DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
 NotificationSettings: Erwünschte Benachrichtigungen
 
+ActiveAuthTags: Aktivierte Authorisierungsprädikate
+
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
 AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
 IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
@@ -516,3 +521,23 @@ MenuSheetEdit: Übungsblatt editieren
 MenuCorrectionsUpload: Korrekturen hochladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben bewerten
+
+AuthPredsActive: Aktive Authorisierungsprädikate
+AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
+AuthTagFree: Seite ist generell zugänglich
+AuthTagAdmin: Nutzer ist Administrator
+AuthTagDeprecated: Seite ist nicht überholt
+AuthTagDevelopment: Seite ist nicht in Entwicklung
+AuthTagLecturer: Nutzer ist Dozent
+AuthTagCorrector: Nutzer ist Korrektor
+AuthTagTime: Zeitliche Einschränkungen sind erfüllt
+AuthTagRegistered: Nutzer ist Kursteilnehmer
+AuthTagCapacity: Kapazität ist ausreichend
+AuthTagMaterials: Kursmaterialien sind freigegeben
+AuthTagOwner: Nutzer ist Besitzer
+AuthTagRated: Korrektur ist bewertet
+AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
+AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
+AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
+AuthTagIsRead: Zugriff ist nur lesend
+AuthTagIsWrite: Zugriff ist i.A. schreibend
\ No newline at end of file
diff --git a/package.yaml b/package.yaml
index c9fdbb55a..20a50b6c5 100644
--- a/package.yaml
+++ b/package.yaml
@@ -107,6 +107,7 @@ dependencies:
   - word24
   - mmorph
   - clientsession
+  - monad-memo
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/routes b/routes
index 399f3bf72..06768ea3e 100644
--- a/routes
+++ b/routes
@@ -40,8 +40,10 @@
 /info                       VersionR          GET             !free
 /help                       HelpR             GET POST        !free
 
-/profile                    ProfileR          GET POST        !free                             !free
-/profile/data               ProfileDataR      GET POST        !free                             !free
+/profile                    ProfileR          GET POST        !free
+/profile/data               ProfileDataR      GET POST        !free
+
+/authpreds                  AuthPredsR        GET POST        !free
 
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
diff --git a/src/Foundation.hs b/src/Foundation.hs
index a2d0f20ac..431c51717 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -40,7 +40,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
-import Data.List (foldr1)
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
@@ -58,12 +57,14 @@ import qualified Database.Esqueleto as E
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
-import Control.Monad.Trans.Writer (WriterT(..))
+import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
 import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
 import qualified Control.Monad.Catch as C
 
 import Handler.Utils.StudyFeatures
-import Control.Lens
+import Handler.Utils.Templates
+import Utils.Lens
 import Utils.Form
 import Utils.SystemMessage
 
@@ -200,6 +201,7 @@ embedRenderMessage ''UniWorX ''SheetFileType id
 embedRenderMessage ''UniWorX ''CorrectorState id
 embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
+embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -300,264 +302,298 @@ data AccessPredicate
   | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
   | APDB       (Route UniWorX -> Bool -> DB AuthResult)
 
-orAR, andAR :: MsgRenderer ->  AuthResult -> AuthResult -> AuthResult
+class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
+  evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult
+
+instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
+  evalAccessPred aPred r w = liftHandlerT $ case aPred of
+    (APPure    p) -> runReader (p r w) <$> getMsgRenderer
+    (APHandler p) -> p r w
+    (APDB      p) -> runDB $ p 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
+    (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
+    (APHandler p) -> lift $ p r w
+    (APDB      p) -> p r w
+
+
+orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
 orAR  _  Authorized _ = Authorized
 orAR  _  _ Authorized = Authorized
 orAR  _  AuthenticationRequired _  = AuthenticationRequired
 orAR  _  _ AuthenticationRequired  = AuthenticationRequired
-orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedOr x y
+orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
 -- and
-andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedAnd x y
+andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
 andAR _  reason@(Unauthorized _) _ = reason
 andAR _  _ reason@(Unauthorized _) = reason
 andAR _  Authorized          other = other
 andAR _  AuthenticationRequired  _ = AuthenticationRequired
 
-orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
-orAP  = liftAR  orAR (== Authorized)
-andAP = liftAR andAR (const False)
+trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
+trueAR = const Authorized
+falseAR = Unauthorized . ($ MsgUnauthorized) . render
 
-liftAR :: (MsgRenderer ->  AuthResult -> AuthResult -> AuthResult)
-          -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
-          -> AccessPredicate -> AccessPredicate -> AccessPredicate
--- Ensure to first evaluate Pure conditions, then Handler before DB
-liftAR ops sc (APPure    f) (APPure     g) = APPure     $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask
-liftAR ops sc (APHandler f) (APHandler  g) = APHandler  $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
-liftAR ops sc (APDB      f) (APDB       g) = APDB       $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
-liftAR ops sc (APPure    f) apg  = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg
-liftAR ops sc apf           apg@(APPure _)    = liftAR ops sc apg apf
-liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB      $ \r w -> lift $ f r w) apdb
-liftAR ops sc apdb          apg@(APHandler _) = liftAR ops sc apg apdb
+trueAP, falseAP :: AccessPredicate
+trueAP  = APPure . const . const $ trueAR <$> ask
+falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
 
 
-trueAP,falseAP :: AccessPredicate
-trueAP  = APPure . const . const $ return Authorized
-falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
-
-
-adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
-adminAP = APDB $ \route _ -> case route of
-    -- Courses: access only to school admins
-    CourseR tid ssh csh _ -> exceptT return return $ do
-        authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-        [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
-                E.&&. course E.^. CourseTerm      E.==. E.val tid
-                E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                E.&&. course E.^. CourseShorthand E.==. E.val csh
-          return (E.countRows :: E.SqlExpr (E.Value Int64))
-        guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
-        return Authorized
-    -- other routes: access to any admin is granted here
-    _other -> exceptT return return $ do
-        authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-        adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
-        guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
-        return Authorized
-
-
-knownTags :: Map (CI Text) AccessPredicate
-knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
-  [("free", trueAP)
-  ,("deprecated", APHandler $ \r _ -> do
-      $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
-      addMessageI Error MsgDeprecatedRoute
-      allow <- appAllowDeprecated . appSettings <$> getYesod
-      return $ bool (Unauthorized "Deprecated Route") Authorized allow
-    )
-  ,("development", APHandler $ \r _ -> do
-      $logWarnS "AccessControl" ("route in development: " <> tshow r)
+tagAccessPredicate :: AuthTag -> AccessPredicate
+tagAccessPredicate AuthFree = trueAP
+tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
+  -- Courses: access only to school admins
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    [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
+            E.&&. course E.^. CourseTerm      E.==. E.val tid
+            E.&&. course E.^. CourseSchool    E.==. E.val ssh
+            E.&&. course E.^. CourseShorthand E.==. E.val csh
+      return (E.countRows :: E.SqlExpr (E.Value Int64))
+    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
+    return Authorized
+  -- other routes: access to any admin is granted here
+  _other -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
+    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
+    return Authorized
+tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
+  $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
+  addMessageI Error MsgDeprecatedRoute
+  allow <- appAllowDeprecated . appSettings <$> getYesod
+  return $ bool (Unauthorized "Deprecated Route") Authorized allow
+tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
+  $logWarnS "AccessControl" ("route in development: " <> tshow r)
 #ifdef DEVELOPMENT
-      return Authorized
+  return Authorized
 #else
-      return $ Unauthorized "Route under development"
+  return $ Unauthorized "Route under development"
 #endif
-    )
-  ,("lecturer", APDB $ \route _ -> case route of
-      CourseR tid ssh csh _ -> exceptT return return $ do
-          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-          [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
-                 E.&&. course E.^. CourseTerm      E.==. E.val tid
-                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                 E.&&. course E.^. CourseShorthand E.==. E.val csh
-            return (E.countRows :: E.SqlExpr (E.Value Int64))
-          guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
-          return Authorized
-      _ -> exceptT return return $ do
-          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-          void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
-          return Authorized
-    )
-  ,("corrector", APDB $ \route _ -> exceptT return return $ do
-       authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-       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
-         E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
-         return (course E.^. CourseId, sheet E.^. SheetId)
-       let
-         resMap :: Map CourseId (Set SheetId)
-         resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
-       case route of
-         CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
-           sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
-           Submission{..} <- MaybeT . lift $ get sid
-           guard $ maybe False (== authId) submissionRatingBy
-           return Authorized
-         CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
-           Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
-           Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
-           guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
-           return Authorized
-         CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
-           Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
-           guard $ cid `Set.member` Map.keysSet resMap
-           return Authorized
-         _ -> do
-           guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
-           return Authorized
-   )
-  ,("time", APDB $ \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
-        cTime <- liftIO getCurrentTime
-        let
-          visible = NTop sheetVisibleFrom <= NTop (Just cTime)
-          active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
+  CourseR tid ssh csh _ -> exceptT return return $ do
+     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     [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
+            E.&&. course E.^. CourseTerm      E.==. E.val tid
+            E.&&. course E.^. CourseSchool    E.==. E.val ssh
+            E.&&. course E.^. CourseShorthand E.==. E.val csh
+       return (E.countRows :: E.SqlExpr (E.Value Int64))
+     guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
+     return Authorized
+  _ -> exceptT return return $ do
+     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
+     return Authorized
+tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
+  authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+  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
+    E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
+    return (course E.^. CourseId, sheet E.^. SheetId)
+  let
+    resMap :: Map CourseId (Set SheetId)
+    resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
+  case route of
+    CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+      sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+      Submission{..} <- MaybeT . lift $ get sid
+      guard $ maybe False (== authId) submissionRatingBy
+      return Authorized
+    CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
+      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
+      guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
+      return Authorized
+    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      guard $ cid `Set.member` Map.keysSet resMap
+      return Authorized
+    _ -> do
+      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
+      return Authorized
+tagAccessPredicate AuthTime = APDB $ \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
+    cTime <- liftIO getCurrentTime
+    let
+      visible = NTop sheetVisibleFrom <= NTop (Just cTime)
+      active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
 
-        guard visible
+    guard visible
 
-        case subRoute of
-          SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
-          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
-          SubmissionNewR         -> guard   active
-          SubmissionR _ _        -> guard   active
-          _                      -> return ()
+    case subRoute of
+      SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
+      SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+      SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+      SubmissionNewR         -> guard   active
+      SubmissionR _ _        -> guard   active
+      _                      -> return ()
 
-        return Authorized
+    return Authorized
 
-      CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
-        Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-        cTime <- (NTop . Just) <$> liftIO getCurrentTime
-        guard $ NTop courseRegisterFrom <= cTime
-             && NTop courseRegisterTo   >= cTime
-        return Authorized
+  CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
+    Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    cTime <- (NTop . Just) <$> liftIO getCurrentTime
+    guard $ NTop courseRegisterFrom <= cTime
+         && NTop courseRegisterTo   >= cTime
+    return Authorized
 
-      MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
-        smId <- decrypt cID
-        SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
-        cTime <- (NTop . Just) <$> liftIO getCurrentTime
-        guard $ NTop systemMessageFrom <= cTime
-             && NTop systemMessageTo   >= cTime
-        return Authorized
+  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
+    smId <- decrypt cID
+    SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
+    cTime <- (NTop . Just) <$> liftIO getCurrentTime
+    guard $ NTop systemMessageFrom <= cTime
+         && NTop systemMessageTo   >= cTime
+    return Authorized
 
-      r -> $unsupportedAuthPredicate "time" r
-   )
-  ,("registered", APDB $ \route _ -> case route of
-       CourseR tid ssh csh _ -> exceptT return return $ do
-         authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-         [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
-                E.&&. course E.^. CourseTerm      E.==. E.val tid
-                E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                E.&&. course E.^. CourseShorthand E.==. E.val csh
-           return (E.countRows :: E.SqlExpr (E.Value Int64))
-         guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
-         return Authorized
-       r -> $unsupportedAuthPredicate "registered" r
-   )
-  ,("capacity", 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 "capacity" r
-   )
-  ,("materials", 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 "materials" r
-    )
-  ,("owner", APDB $ \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
-         void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
-         return Authorized
-       r -> $unsupportedAuthPredicate "owner" r
-   )
-  ,("rated", 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 "rated" r
-   )
-  ,("user-submissions", 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
-         guard $ sheetSubmissionMode == UserSubmissions
-         return Authorized
-       r -> $unsupportedAuthPredicate "user-submissions" r
-   )
-  ,("corrector-submissions", 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
-         guard $ sheetSubmissionMode == CorrectorSubmissions
-         return Authorized
-       r -> $unsupportedAuthPredicate "corrector-submissions" r
-   )
-  ,("authentication", APDB $ \route _ -> case route of
-       MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
-         smId <- decrypt cID
-         SystemMessage{..} <- MaybeT $ get smId
-         isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
-         guard $ not systemMessageAuthenticatedOnly || isAuthenticated
-         return Authorized      
-       r -> $unsupportedAuthPredicate "authentication" r
-   )
-  ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
-  ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
-  ]
+  r -> $unsupportedAuthPredicate "time" r
+tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    [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
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+      return (E.countRows :: E.SqlExpr (E.Value Int64))
+    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
+    return Authorized
+  r -> $unsupportedAuthPredicate "registered" r
+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 "capacity" r
+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 "materials" r
+tagAccessPredicate AuthOwner = APDB $ \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
+    void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
+    return Authorized
+  r -> $unsupportedAuthPredicate "owner" r
+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 "rated" r
+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
+    guard $ sheetSubmissionMode == UserSubmissions
+    return Authorized
+  r -> $unsupportedAuthPredicate "user-submissions" r
+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
+    guard $ sheetSubmissionMode == CorrectorSubmissions
+    return Authorized
+  r -> $unsupportedAuthPredicate "corrector-submissions" r
+tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
+  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
+    smId <- decrypt cID
+    SystemMessage{..} <- MaybeT $ get smId
+    isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
+    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
+    return Authorized      
+  r -> $unsupportedAuthPredicate "authentication" r
+tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
+tagAccessPredicate AuthIsWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
-tag2ap :: Text -> AccessPredicate
-tag2ap t = case Map.lookup (CI.mk t) knownTags of
-    (Just acp) -> acp
-    Nothing   -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
-      $logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
-      unauthorizedI MsgUnauthorized
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
 
-route2ap :: Route UniWorX -> AccessPredicate
-route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
+type DNF a = Set (NonNull (Set a))
+
+data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+instance Universe SessionAuthTags
+instance Finite SessionAuthTags
+$(return [])
+instance PathPiece SessionAuthTags where
+  toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
+  fromPathPiece = finiteFromPathPiece
+
+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
   where
-    attrsAND = map splitAND $ Set.toList $ routeAttrs r
-    splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
+    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
+    partition' prev t
+      | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
+        = if
+           | oany (authTags `Set.isSubsetOf`) prev
+             -> Right prev
+           | otherwise
+             -> Right $ Set.insert authTags prev
+      | otherwise
+        = Left $ InvalidAuthTag t
 
-evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
-evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
-  (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
-  (APHandler p) -> lift $ p r w
-  (APDB      p) -> p r w
+evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> 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
+  = startEvalMemoT $ do
+      mr <- lift getMsgRenderer
+      let
+        authTagIsInactive = not . authTagIsActive
+        
+        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
 
-evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
-evalAccess r w = liftHandlerT $ case route2ap r of
-  (APPure    p) -> runReader (p r w) <$> getMsgRenderer
-  (APHandler p) -> p r w
-  (APDB      p) -> runDB $ p r w
+        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 = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
+
+      lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
+      
+      result <- evalDNF $ filter (all authTagIsActive) authDNF
+
+      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj -> 
+        whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
+          let pivots = filter authTagIsInactive conj
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
+            lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
+            lift . tell $ Set.fromList pivots
+  
+      return result
+
+evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
+evalAccess route isWrite = do
+  tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+  dnf <- either throwM return $ routeAuthTags route
+  (result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
+  result <$ tellSessionJson SessionInactiveAuthTags deactivated
+
+evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
+evalAccessDB = evalAccess
 
 
 -- Please see the documentation for the Yesod typeclass. There are a number
@@ -726,12 +762,6 @@ siteLayout headingOverride widget = do
 
   isModal <- isJust <$> siteModalId
 
-  mmsgs <- if
-    | isModal -> return []
-    | otherwise -> do
-        applySystemMessages
-        getMessages
-
   mcurrentRoute <- getCurrentRoute
 
   -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
@@ -767,6 +797,14 @@ siteLayout headingOverride widget = do
            items' <- forM items $ \i -> (i, ) <$> toTextUrl i
            return (c, courseRoute, items')
 
+  mmsgs <- if
+    | isModal -> return []
+    | otherwise -> do
+        applySystemMessages
+        authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
+        forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR)
+        getMessages
+
   let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
       highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
                       navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
@@ -777,14 +815,12 @@ siteLayout headingOverride widget = do
       favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
       favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
 
-  -- We break up the default layout into two components:
-  -- default-layout is the contents of the body tag, and
-  -- default-layout-wrapper is the entire page. Since the final
-  -- value passed to hamletToRepHtml cannot be a widget, this allows
-  -- you to use normal widget features in default-layout.
+      -- We break up the default layout into two components:
+      -- default-layout is the contents of the body tag, and
+      -- default-layout-wrapper is the entire page. Since the final
+      -- value passed to hamletToRepHtml cannot be a widget, this allows
+      -- you to use normal widget features in default-layout.
 
-
-  let
       navbar :: Widget
       navbar = $(widgetFile "widgets/navbar")
       asidenav :: Widget
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index e80ff8b64..96e782067 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -295,3 +295,23 @@ postHelpR = do
     $(widgetFile "help")
 
 
+getAuthPredsR, postAuthPredsR :: Handler Html
+getAuthPredsR = postAuthPredsR
+postAuthPredsR = do
+  AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+  
+  let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag)
+  
+  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
+    $ AuthTagActive
+      <$> funcForm taForm (fslI MsgActiveAuthTags) True
+      <*  submitButton
+
+  formResult authActiveRes $ \authTagActive -> do
+    setSessionJson SessionActiveAuthTags authTagActive
+    addMessageI Success MsgAuthPredsActiveChanged
+    redirect AuthPredsR
+
+  defaultLayout $ do
+    setTitleI MsgAuthPredsActive
+    $(widgetFile "authpreds")
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index fbbdff58f..4e1f7abe1 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -10,8 +10,6 @@ import Utils.Lens
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
 import qualified Data.Map as Map
-import Data.Map ((!))
-import qualified Data.Set as Set
 -- import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
@@ -42,25 +40,11 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
-      <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
+      <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
       <*  submitButton
     return (result, widget) -- no validation required here
   where
-    nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
-      areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
-    nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
-    nsFieldView (res, fvInput) = do
-      mr <- getMessageRender
-      let fvLabel = toHtml $ mr MsgNotificationSettings
-          fvTooltip = mempty
-          fvRequired = True
-          fvErrors
-            | FormFailure (err:_) <- res = Just $ toHtml err
-            | otherwise = Nothing
-      fvId <- newIdent
-      return (res, pure FieldView{..})
-    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
-
+    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 
 getProfileR, postProfileR :: Handler Html
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index e4a32bb81..ce9aeec62 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -30,8 +30,9 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto as E
 
 import Data.Set (Set)
+import qualified Data.Set as Set
 
-import Data.Map (Map)
+import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import Control.Monad.Writer.Class
@@ -488,6 +489,32 @@ langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) .
 langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
 
 
+funcForm :: forall k v m.
+            ( Finite k, Ord k
+            , MonadHandler m
+            , HandlerSite m ~ UniWorX
+            )
+         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
+  where
+    funcForm' :: AForm m (k -> v)
+    funcForm' = fmap (\m x -> m ! x) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
+    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
+    funcFieldView (res, fvInput) = do
+      mr <- getMessageRender
+      let fvLabel = toHtml $ mr fsLabel
+          fvTooltip = fmap (toHtml . mr) fsTooltip
+          fvRequired = isRequired
+          fvErrors
+            | FormFailure (err:_) <- res = Just $ toHtml err
+            | otherwise = Nothing
+      fvId <- maybe newIdent return fsId
+      return (res, pure FieldView{..})
+    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
+
+
+
+
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
 fsm = bfs -- TODO: get rid of Bootstrap
 
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 49255b941..94c8ffbd2 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 396c26bbb..6872daf9c 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -564,6 +564,8 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
 derivePersistFieldJSON ''MailLanguages
 
 
+type PseudonymWord   = CI Text
+
 newtype Pseudonym = Pseudonym Word24
   deriving (Eq, Ord, Read, Show, Generic, Data)
   deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix)
@@ -642,9 +644,68 @@ pseudonymText = iso tFromWords tToWords . pseudonymWords
     tToWords = Text.unwords . map CI.original
 
 
--- Type synonyms
+data AuthTag
+  = AuthFree
+  | AuthAdmin
+  | AuthDeprecated
+  | AuthDevelopment
+  | AuthLecturer
+  | AuthCorrector
+  | AuthTime
+  | AuthRegistered
+  | AuthCapacity
+  | AuthMaterials
+  | AuthOwner
+  | AuthRated
+  | AuthUserSubmissions
+  | AuthCorrectorSubmissions
+  | AuthAuthentication
+  | AuthIsRead
+  | AuthIsWrite
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
-type PseudonymWord   = CI Text
+instance Universe AuthTag
+instance Finite AuthTag
+instance Hashable AuthTag
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''AuthTag
+
+instance PathPiece AuthTag where
+  toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel])
+  fromPathPiece = finiteFromPathPiece
+
+instance ToJSONKey AuthTag where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey AuthTag where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
+  deriving (Read, Show, Generic)
+  deriving newtype (Eq, Ord)
+
+instance Default AuthTagActive where
+  def = AuthTagActive $ \case
+    AuthAdmin -> False
+    _ -> True
+
+instance ToJSON AuthTagActive where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
+
+instance FromJSON AuthTagActive where
+  parseJSON = withObject "AuthTagActive" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
+    return . AuthTagActive $ \n -> case HashMap.lookup n o' of
+      Nothing -> authTagIsActive def n
+      Just b  -> b
+
+derivePersistFieldJSON ''AuthTagActive
+
+
+-- Type synonyms
 
 type Email           = Text
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 23dc860ff..2b138f36e 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -4,10 +4,11 @@ module Utils
   ( module Utils
   ) where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (foldlM)
 
 -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
-import Data.Foldable as Fold hiding (length)
+import qualified Data.Foldable as Fold
+import Data.Foldable as Utils (foldlM, foldrM)
 import Data.Monoid (Sum(..))
 
 import Data.CaseInsensitive (CI)
@@ -200,7 +201,6 @@ stepTextCounter text
 -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
 -- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]
 
-
 ------------
 -- Tuples --
 ------------
@@ -395,12 +395,12 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
 -- Monads --
 ------------
 
-shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
-shortCircuitM sc mx my bop = do
+shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
+shortCircuitM sc binOp mx my = do
   x <- mx
   if
     | sc x      -> return x
-    | otherwise -> bop <$> pure x <*> my
+    | otherwise -> binOp <$> pure x <*> my
 
 
 guardM :: MonadPlus m => m Bool -> m ()
@@ -423,26 +423,24 @@ ifM c m m' =
 ifNotM :: Monad m => m Bool -> m a -> m a -> m a
 ifNotM c = flip $ ifM c
 
--- | Lazy monadic conjunction.
-and2M :: Monad m => m Bool -> m Bool -> m Bool
+and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
 and2M ma mb = ifM ma mb (return False)
-
-andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
-andM = Fold.foldr and2M (return True)
-
-allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
-allM xs f = andM $ fmap f xs
-
--- | Lazy monadic disjunction.
-or2M :: Monad m => m Bool -> m Bool -> m Bool
 or2M ma = ifM ma (return True)
 
-orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM = Fold.foldr and2M (return True)
 orM = Fold.foldr or2M (return False)
 
-anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM xs f = andM $ fmap f xs
 anyM xs f = orM $ fmap f xs
 
+ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
+ofoldr1M f (otoList -> x:xs) = foldrM f x xs
+ofoldr1M _ _ = error "otoList of NonNull is empty"
+ofoldl1M f (otoList -> x:xs) = foldlM f x xs
+ofoldl1M _ _ = error "otoList of NonNull is empty"
+
 --------------
 -- Sessions --
 --------------
@@ -452,3 +450,13 @@ setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSe
 
 lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
 lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
+
+modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
+modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
+
+tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
+tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
+
+getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+-- ^ `lookupSessionJson` followed by `deleteSession`
+getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 46a2a5344..7d7df4350 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -2,6 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
 import Control.Lens as Utils.Lens
+import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
@@ -28,6 +29,8 @@ makeLenses_ ''SheetGrading
 
 makeLenses_ ''SheetType
 
+makePrisms ''AuthResult
+
 -- makeClassy_ ''Load
 
 
diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs
index 62e337328..62226de75 100644
--- a/src/Utils/Message.hs
+++ b/src/Utils/Message.hs
@@ -1,6 +1,6 @@
 module Utils.Message
   ( MessageClass(..)
-  , addMessage, addMessageI, addMessageIHamlet, addMessageFile
+  , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
   ) where
 
 
@@ -53,3 +53,13 @@ addMessageIHamlet mc iHamlet = do
 
 addMessageFile :: MessageClass -> FilePath -> ExpQ
 addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
+
+addMessageWidget :: forall m site.
+                    ( MonadHandler m
+                    , HandlerSite m ~ site
+                    , Yesod site
+                    ) => MessageClass -> WidgetT site IO () -> m ()
+-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
+addMessageWidget mc wgt = do
+  PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
+  addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index 85579cc5e..0b0f139c4 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/src/Yesod/Core/Instances.hs
@@ -12,6 +12,8 @@ import Control.Lens
 import Data.ByteString.Builder (toLazyByteString)
 
 import System.FilePath ((</>))
+
+import Data.Aeson
   
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
@@ -32,3 +34,8 @@ instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
     . over (_2.traverse._2) (assertM' $ not . null)
     . renderRoute
     
+instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
+  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
+
+instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
+  toJSON = String . toPathPiece
diff --git a/start.sh b/start.sh
index 67d80033a..24abcd36c 100755
--- a/start.sh
+++ b/start.sh
@@ -10,11 +10,11 @@ export PWFILE=users.yml
 
 move-back() {
     mv -v .stack-work .stack-work-run
-    [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
 }
 
 if [[ -d .stack-work-run ]]; then
-    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
     mv -v .stack-work-run .stack-work
     trap move-back EXIT
 fi
diff --git a/templates/authpreds.hamlet b/templates/authpreds.hamlet
new file mode 100644
index 000000000..4f04f04b7
--- /dev/null
+++ b/templates/authpreds.hamlet
@@ -0,0 +1,2 @@
+<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
+  ^{authActiveWidget}
diff --git a/test.sh b/test.sh
index 26f865cb1..dd625c99c 100755
--- a/test.sh
+++ b/test.sh
@@ -2,11 +2,11 @@
 
 move-back() {
     mv -v .stack-work .stack-work-test
-    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
 }
 
 if [[ -d .stack-work-test ]]; then
-    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
     mv -v .stack-work-test .stack-work
     trap move-back EXIT
 fi

From bc12fcda2f4dccffff715b1dc253c22c163181df Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 14 Nov 2018 14:38:03 +0100
Subject: [PATCH 10/10] Fix build

---
 src/Foundation.hs         | 2 +-
 src/Handler/Utils/Form.hs | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index cb727fe20..1424bb13d 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -434,8 +434,8 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
       SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
       SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
       SubmissionNewR         -> guard   active
+      SubmissionR _ SAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
       SubmissionR _ _        -> guard   active
-      SubmissionR _ SAssignR -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
       _                      -> return ()
 
     return Authorized
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index ce9aeec62..079897003 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -498,7 +498,7 @@ funcForm :: forall k v m.
 funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
   where
     funcForm' :: AForm m (k -> v)
-    funcForm' = fmap (\m x -> m ! x) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
+    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
     funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
     funcFieldView (res, fvInput) = do
       mr <- getMessageRender