Merge branch 'master' into 'live'

Master

See merge request !94

.vscode/tasks.json

@@ -28,7 +28,8 @@
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
-      }      
+      },
+      "problemMatcher": []
     },
     {
       "label": "test",

README.md

@@ -3,72 +3,118 @@
 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:` - [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*:
-  `createdb uniworx`
+  ```sh
+  $ createdb uniworx
+  ```
 
-  to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:  
+  after you added the database switch back to your own user with `Ctrl + D`.
-  `sudo adduser 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*.
+  ```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:
+  ```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:
-  `./fill-db.hs`
+  ```sh
+  $ ./db.sh -f
+  ```
 
   Run the app:
-  `./start.sh`
+  ```sh
-
+  $ ./start.sh
-  `Devel application launched: http://localhost:3000`  
+  ...
-  means you are good to go.
+  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.
 

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

messages/uniworx/de.msg

@@ -142,10 +142,13 @@ 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})
 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 +170,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.
@@ -189,6 +194,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.
@@ -228,6 +234,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.
@@ -299,6 +306,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
@@ -484,6 +493,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
 
@@ -516,3 +526,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

models

@@ -15,7 +15,7 @@ User json
     notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
-    deriving Show
+    deriving Show Eq
 UserAdmin
     user   UserId
     school SchoolId

package.yaml

@@ -107,6 +107,7 @@ dependencies:
   - word24
   - mmorph
   - clientsession
+  - monad-memo
 
 other-extensions:
   - GeneralizedNewtypeDeriving

routes

@@ -40,8 +40,10 @@
 /info                       VersionR          GET             !free
 /help                       HelpR             GET POST        !free
 
-/profile                    ProfileR          GET POST        !free                             !free
+/profile                    ProfileR          GET POST        !free
-/profile/data               ProfileDataR      GET POST        !free                             !free
+/profile/data               ProfileDataR      GET POST        !free
+
+/authpreds                  AuthPredsR        GET POST        !free
 
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
@@ -79,6 +81,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

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,6 +302,22 @@ data AccessPredicate
   | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
   | APDB       (Route UniWorX -> Bool -> DB 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
@@ -313,30 +331,18 @@ andAR _  _ reason@(Unauthorized _) = reason
 andAR _  Authorized          other = other
 andAR _  AuthenticationRequired  _ = AuthenticationRequired
 
-orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
+trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
-orAP  = liftAR  orAR (== Authorized)
+trueAR = const Authorized
-andAP = liftAR andAR (const False)
+falseAR = Unauthorized . ($ MsgUnauthorized) . render
 
-liftAR :: (MsgRenderer ->  AuthResult -> AuthResult -> AuthResult)
+trueAP, falseAP :: AccessPredicate
-          -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
+trueAP  = APPure . const . const $ trueAR <$> ask
-          -> AccessPredicate -> AccessPredicate -> AccessPredicate
+falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
--- 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
+tagAccessPredicate :: AuthTag -> AccessPredicate
-trueAP  = APPure . const . const $ return Authorized
+tagAccessPredicate AuthFree = trueAP
-falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
+tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
-
-
-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
@@ -353,28 +359,21 @@ adminAP = APDB $ \route _ -> case route of
   _other -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
-        guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
+    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-
+tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
-
-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
-    )
+tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
-  ,("development", APHandler $ \r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
 #ifdef DEVELOPMENT
   return Authorized
 #else
   return $ Unauthorized "Route under development"
 #endif
-    )
+tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
-  ,("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
@@ -390,8 +389,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
      authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
      return Authorized
-    )
+tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
-  ,("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
@@ -419,8 +417,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
       return Authorized
-   )
+tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
-  ,("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
@@ -428,6 +425,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
     let
       visible = NTop sheetVisibleFrom <= NTop (Just cTime)
       active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+      marking = cTime > sheetActiveTo
 
     guard visible
 
@@ -436,6 +434,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   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
       SubmissionR _ _        -> guard   active
       _                      -> return ()
 
@@ -457,8 +456,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
     return Authorized
 
   r -> $unsupportedAuthPredicate "time" r
-   )
+tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
-  ,("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
@@ -471,55 +469,48 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
     return Authorized
   r -> $unsupportedAuthPredicate "registered" r
-   )
+tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
-  ,("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
-   )
+tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
-  ,("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
-    )
+tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
-  ,("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
-   )
+tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
-  ,("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
-   )
+tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
-  ,("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
-   )
+tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
-  ,("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
-   )
+tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
-  ,("authentication", APDB $ \route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
     SystemMessage{..} <- MaybeT $ get smId
@@ -527,37 +518,84 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized      
   r -> $unsupportedAuthPredicate "authentication" r
-   )
+tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
-  ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
+tagAccessPredicate AuthIsWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
-  ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
-  ]
 
 
-tag2ap :: Text -> AccessPredicate
+newtype InvalidAuthTag = InvalidAuthTag Text
-tag2ap t = case Map.lookup (CI.mk t) knownTags of
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
-    (Just acp) -> acp
+instance Exception InvalidAuthTag
-    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
 
-route2ap :: Route UniWorX -> AccessPredicate
+type DNF a = Set (NonNull (Set a))
-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)
+
+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
+    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
-    splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
+    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
+evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
+-- ^ `tell`s disabled predicates, identified as pivots
-  (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
-  (APHandler p) -> lift $ p r w
+  = startEvalMemoT $ do
-  (APDB      p) -> p r w
+      mr <- lift getMsgRenderer
+      let
+        authTagIsInactive = not . authTagIsActive
         
-evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
+        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
-evalAccess r w = liftHandlerT $ case route2ap r of
+        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
-  (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 +764,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 +799,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
@@ -783,8 +823,6 @@ siteLayout headingOverride widget = do
       -- 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
@@ -1226,6 +1264,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
@@ -1417,6 +1463,7 @@ routeNormalizers =
   , ncSchool
   , ncCourse
   , ncSheet
+  , verifySubmission
   ]
   where
     normalizeRender route = route <$ do
@@ -1454,6 +1501,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.

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, _, _) } ->
+        $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
-          let tid = course ^. _3
-              ssh = course ^. _4
-              csh = course ^. _2
-          in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
 
 colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@@ -306,8 +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
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-          num <- updateWhereCount [SubmissionId <-. Set.toList 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
                     ]
@@ -319,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
+                  [ SubmissionRatingBy       =. Nothing
-                  , SubmissionRatingComment  =. 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
@@ -340,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
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-          (assigned, stillUnassigned) <- assignSubmissions shid (Just 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
@@ -353,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)
 
@@ -372,7 +389,7 @@ assignAction selId = ( CorrSetCorrector
 
                            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
 
@@ -762,3 +779,36 @@ 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
+    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")
+
+
+
+

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")

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 ->
+    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
-      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)
-
 
 
 getProfileR, postProfileR :: Handler Html

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 (!) . 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
 

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

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
 

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 :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
-shortCircuitM sc mx my bop = do
+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,40 @@ ifM c m m' =
 ifNotM :: Monad m => m Bool -> m a -> m a -> m a
 ifNotM c = flip $ ifM c
 
--- | Lazy monadic conjunction.
+and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
-and2M :: 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"
+
+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 --
 --------------
@@ -452,3 +466,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)

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
 
 

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

src/Yesod/Core/Instances.hs

@@ -13,6 +13,8 @@ import Data.ByteString.Builder (toLazyByteString)
 
 import System.FilePath ((</>))
 
+import Data.Aeson
+  
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
   fromPathPiece
@@ -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

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

templates/authpreds.hamlet

@@ -0,0 +1,2 @@
+<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
+  ^{authActiveWidget}

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}

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}

templates/messages/submissionsAssignUnauthorized.hamlet

@@ -0,0 +1,5 @@
+_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
+
+<ul>
+  $forall cID <- unassignedUnauth'
+    <li><pre>#{toPathPiece cID}

templates/standalone/inputs.lucius

@@ -91,7 +91,6 @@ input[type*="time"] {
 
 input[type="number"] {
   width: 100px;
-  text-align: right;
 }
 
 input[type*="date"],

templates/submission-assign.hamlet

@@ -0,0 +1,2 @@
+<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
+   ^{corrForm}

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