Merge branch 'master' into http-client-html-helpers

config/archive-types

@@ -0,0 +1,40 @@
+# Simple list of mime-types corresponding to archive-formats
+#
+# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’
+#
+# Format is a single mime-type per line (may not contain whitespace)
+#
+# Largely copied from https://en.wikipedia.org/wiki/List_of_archive_formats
+
+application/x-archive 
+application/x-cpio
+application/x-bcpio
+application/x-shar
+application/x-iso9660-image 
+application/x-sbx
+application/x-tar
+application/x-7z-compressed 
+application/x-ace-compressed
+application/x-astrotite-afa 
+application/x-alz-compressed
+application/vnd.android.package-archive 
+application/x-arj 
+application/x-b1 
+application/vnd.ms-cab-compressed 
+application/x-cfs-compressed 
+application/x-dar 
+application/x-dgc-compressed 
+application/x-apple-diskimage 
+application/x-gca-compressed 
+application/java-archive 
+application/x-lzh 
+application/x-lzx 
+application/x-rar-compressed 
+application/x-stuffit 
+application/x-stuffitx 
+application/x-gtar 
+application/x-ms-wim 
+application/x-xar 
+application/zip 
+application/x-zoo 
+application/x-par2 

messages/uniworx/de.msg

@@ -64,7 +64,7 @@ TermActive: Aktiv
 
 
 SchoolListHeading: Übersicht über verwaltete Institute
-SchoolHeading school@SchoolName: Übersicht #{display school}
+SchoolHeading school@SchoolName: Übersicht #{school}
 
 LectureStart: Beginn Vorlesungen
 
@@ -89,10 +89,10 @@ CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display t
 CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
-TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
+TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{school}
 CourseListTitle: Alle Kurse
 TermCourseListTitle   tid@TermId: Kurse #{display tid}
-TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
+TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{school}
 CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
@@ -142,7 +142,7 @@ CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Re
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
-NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
+NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
 NoSuchCourse: Keinen passenden Kurs gefunden.
 
 Sheet: Blatt
@@ -169,6 +169,7 @@ SheetHintFrom: Hinweis ab
 SheetSolution: Lösung
 SheetSolutionFrom: Lösung ab
 SheetMarking: Hinweise für Korrektoren
+SheetMarkingFiles: Korrektur
 SheetType: Wertung
 SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
 SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
@@ -186,11 +187,16 @@ SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
 SheetPseudonym: Persönliches Abgabe-Pseudonym
 SheetGeneratePseudonym: Generieren
 
+SheetFormType: Wertung & Abgabe
+SheetFormTimes: Zeiten
+SheetFormFiles: Dateien
+
 SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
 SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
 SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
 SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
-
+SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt.
+SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt.
 
 Deadline: Abgabe
 Done: Eingereicht
@@ -444,6 +450,7 @@ SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file}
 SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
 SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
 SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
+SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname #{show file} hat keine der für dieses Übungsblatt zulässigen Dateiendungen.
 
 MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
 
@@ -487,7 +494,7 @@ LastEdit: Letzte Änderung
 LastEditByUser: Ihre letzte Bearbeitung
 NoEditByUser: Nicht von Ihnen bearbeitet
 
-SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
+SubmissionFilesIgnored n@Int: Es #{pluralDE n "wurde" "wurden"} #{tshow n} #{pluralDE n "Datei" "Dateien"} in der hochgeladenen Abgabe ignoriert
 SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
 
 LDAPLoginTitle: Campus-Login
@@ -506,8 +513,22 @@ DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszei
 DayIsOutOfTerm    tid@TermId date@Text: #{date} liegt nicht im #{display tid}
 
 UploadModeNone: Kein Upload
-UploadModeUnpack: Upload, einzelne Datei
+UploadModeAny: Upload, beliebige Datei(en)
-UploadModeNoUnpack: Upload, ZIP-Archive entpacken
+UploadModeSpecific: Upload, vorgegebene Dateinamen
+
+UploadModeUnpackZips: Abgabe mehrerer Dateien
+UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt.
+
+UploadModeExtensionRestriction: Zulässige Dateiendungen
+UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
+
+UploadSpecificFiles: Vorgegebene Dateinamen
+NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
+UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein
+UploadSpecificFilesDuplicateLabels: Bezeichner für vorgegebene Dateinamen müssen eindeutig sein
+UploadSpecificFileLabel: Bezeichnung
+UploadSpecificFileName: Dateiname
+UploadSpecificFileRequired: Zur Abgabe erforderlich
 
 NoSubmissions: Keine Abgabe
 CorrectorSubmissions: Abgabe extern mit Pseudonym
@@ -794,7 +815,7 @@ MenuSheetEdit: Übungsblatt editieren
 MenuSheetDelete: Übungsblatt löschen
 MenuSheetClone:  Als neues Übungsblatt klonen
 MenuCorrectionsUpload: Korrekturen hochladen
-MenuCorrectionsDownload: Abgaben herunterladen
+MenuCorrectionsDownload: Offene Abgaben herunterladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben online korrigieren
 MenuAuthPreds: Authorisierungseinstellungen

package.yaml

@@ -185,7 +185,7 @@ ghc-options:
   - -fno-warn-unrecognised-pragmas
   - -fno-warn-partial-type-signatures
   - -fno-max-relevant-binds
-  - -j2
+  - -j3
 
 when:
   - condition: flag(pedantic)

routes

@@ -95,7 +95,7 @@
   /ex                         SheetListR       GET             !course-registered !materials !corrector
   /ex/new                     SheetNewR        GET POST
   /ex/current                 SheetCurrentR    GET             !course-registered !materials !corrector
-  /ex/unassigned              SheetOldUnassigned    GET
+  /ex/unassigned              SheetOldUnassignedR  GET
   /ex/#SheetName SheetR:
     /show                       SShowR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
     /edit                       SEditR         GET POST
@@ -104,28 +104,27 @@
     !/subs/new                  SubmissionNewR GET POST        !timeANDcourse-registeredANDuser-submissions
     !/subs/own                  SubmissionOwnR GET             !free -- just redirect
     /subs/#CryptoFileNameSubmission SubmissionR:
-      /                         SubShowR       GET POST        !ownerANDtime !ownerANDread !correctorANDread
+      /                         SubShowR       GET POST        !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
-      /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR     GET      !owner !corrector
+      /delete                   SubDelR        GET POST        !ownerANDtimeANDuser-submissions
-      /delete                   SubDelR        GET POST        !ownerANDtime
       /assign                   SAssignR       GET POST        !lecturerANDtime
       /correction               CorrectionR    GET POST        !corrector !ownerANDreadANDrated
-      /invite                   SInviteR       GET POST        !ownerANDtime
+      /invite                   SInviteR       GET POST        !ownerANDtimeANDuser-submissions
+      !/#SubmissionFileType     SubArchiveR    GET             !owner !corrector
       !/#SubmissionFileType/*FilePath SubDownloadR  GET        !owner !corrector
     /correctors                 SCorrR         GET POST
     /iscorrector                SIsCorrR       GET             !corrector -- Route is used to check for corrector access to this sheet
     /pseudonym                  SPseudonymR    GET POST        !course-registeredANDcorrector-submissions
     /corrector-invite/          SCorrInviteR   GET POST
+    !/#SheetFileType            SZipR          GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
     !/#SheetFileType/*FilePath  SFileR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
-    !/#{ZIPArchiveName SheetFileType}  SZipR   GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
   /file                          MaterialListR GET             !course-registered !materials !corrector !tutor
   /file/new                      MaterialNewR  GET POST
   /file/#MaterialName MaterialR:
     /edit                       MEditR         GET POST
     /delete                     MDelR          GET POST
     /show                       MShowR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
-    /load/*FilePath             MFileR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
+    !/download                  MArchiveR      GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
-    /download                   MArchiveR      GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
+    !/download/*FilePath        MFileR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
-    /zip                        MZipR          GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
   /tuts                         CTutorialListR GET             !tutor -- THIS route is used to check for overall course tutor access!
   /tuts/new                     CTutorialNewR  GET POST
   /tuts/#TutorialName TutorialR:

src/Foundation.hs

@@ -280,18 +280,12 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
         verbMap [_, _, v] = v <> "Submissions"
         verbMap _ = error "Invalid number of verbs"
      in verbMap . splitCamel
+embedRenderMessage ''UniWorX ''UploadModeDescr id
+embedRenderMessage ''UniWorX ''SecretJSONFieldException id
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
 
-instance RenderMessage UniWorX UploadMode where
-  renderMessage foundation ls uploadMode = case uploadMode of
-    NoUpload     -> mr MsgUploadModeNone
-    Upload False -> mr MsgUploadModeNoUnpack
-    Upload True  -> mr MsgUploadModeUnpack
-    where
-      mr = renderMessage foundation ls
-
 instance RenderMessage UniWorX SheetType where
   renderMessage foundation ls sheetType = case sheetType of
       NotGraded -> mr $ SheetTypeHeader NotGraded
@@ -677,10 +671,10 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
       SFileR                SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
       SFileR                _             _ -> mzero
       -- Archives of SheetFileType
-      SZipR (ZIPArchiveName SheetExercise)  -> guard $ sheetActiveFrom <= cTime
+      SZipR                 SheetExercise   -> guard $ sheetActiveFrom <= cTime
-      SZipR (ZIPArchiveName SheetHint    )  -> guard $ maybe False (<= cTime) sheetHintFrom
+      SZipR                 SheetHint       -> guard $ maybe False (<= cTime) sheetHintFrom
-      SZipR (ZIPArchiveName SheetSolution)  -> guard $ maybe False (<= cTime) sheetSolutionFrom
+      SZipR                 SheetSolution   -> guard $ maybe False (<= cTime) sheetSolutionFrom
-      SZipR _                               -> mzero
+      SZipR                 _               -> mzero
       -- Submissions
       SubmissionNewR         -> guard   active
       SubmissionR _ SAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
@@ -1451,6 +1445,8 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
+  breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
+  breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = return ("Offene Abgaben", Just $ CourseR tid ssh csh SheetListR)
   breadcrumb (CourseR tid ssh csh CCommR    ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)
@@ -1950,7 +1946,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuSheetOldUnassigned
       , menuItemIcon  = Nothing
-      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           void . MaybeT $ sheetOldUnassigned tid ssh csh
@@ -2232,25 +2228,25 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
   ]
 pageActions (CorrectionsR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsDownload
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute CorrectionsDownloadR
-      , menuItemModal = True
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsUpload
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute CorrectionsUploadR
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsCreate
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute CorrectionsCreateR
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do

src/Handler/Admin.hs

@@ -2,7 +2,6 @@ module Handler.Admin where
 
 import Import
 import Handler.Utils
-import Handler.Utils.Form.MassInput
 import Jobs
 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
@@ -261,7 +260,11 @@ postAdminErrMsgR = do
     [whamlet|
       $maybe t <- plaintext
         <pre style="white-space:pre-wrap; font-family:monospace">
-          #{encodePrettyToTextBuilder t}
+          $case t
+            $of String t'
+              #{t'}
+            $of t'
+              #{encodePrettyToTextBuilder t'}
 
       ^{ctView'}
     |]

src/Handler/Corrections.hs

@@ -36,6 +36,7 @@ import Data.Monoid (All(..))
 -- import qualified Data.Conduit.List as C
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Language (From)
 -- import qualified Database.Esqueleto.Internal.Sql as E
 
 -- import Control.Monad.Writer (MonadWriter(..), execWriterT)
@@ -60,7 +61,7 @@ import Data.Foldable (foldrM)
 
 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))
 type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
-type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym))
 
 correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
 correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
@@ -70,6 +71,12 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
     E.where_ $ whereClause t
     return $ returnStatement t
 
+lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit))
+  => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
+lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
+  E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
+  return $ E.max_ $ edit E.^. SubmissionEditTime
+
 -- Where Clauses
 ratedBy :: UserId -> CorrectionTableWhere
 ratedBy uid   ((_course `E.InnerJoin` _sheet `E.InnerJoin`  submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
@@ -84,40 +91,41 @@ sheetIs shid  ((_course `E.InnerJoin`  sheet `E.InnerJoin` _submission) `E.LeftO
 -- Columns
 colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
-        $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
+        $ \DBRow{ dbrOutput } ->
-          -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
+          textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel
-          textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
 
 colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
-          $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
+          $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in
             anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
 
 colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
-        $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
+        $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _) } -> courseCellCL (tid,sid,csh)
 
 colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
+colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
-        $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
+          let sheet = row ^. _dbrOutput . _2
-          let tid   = course ^. _3
+              course= row ^. _dbrOutput . _3
+              tid   = course ^. _3
               ssh   = course ^. _4
               csh   = course ^. _2
               shn   = sheetName $ entityVal sheet
           in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
 
 colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
+colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
-        $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
+        i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
+        -- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
 
 colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
-  DBRow{ dbrOutput = (_, _, _, Nothing  , _) } -> cell mempty
+  DBRow{ dbrOutput = (_, _, _, Nothing  , _, _) } -> cell mempty
-  DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
+  DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname
 
 colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
-        $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
+        $ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } ->
           let csh = course ^. _2
               tid = course ^. _3
               ssh = course ^. _4
@@ -129,10 +137,10 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
           in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
 
 colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
-colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
+colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
 
 colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> let
   csh = course ^. _2
   tid = course ^. _3
   ssh = course ^. _4
@@ -144,12 +152,12 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
   in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
 colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+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 :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
-colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
+colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _) } ->
   let csh = course ^. _2
       tid = course ^. _3
       ssh = course ^. _4
@@ -169,36 +177,40 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
      ]
 
 colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
   maybe mempty dateTimeCell submissionRatingAssigned
 
 colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
   maybe mempty dateTimeCell submissionRatingTime
 
 colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
     lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
       cell [whamlet|#{review _PseudonymText pseudo}|]
   in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
 colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
 colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
-  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
+  (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
 
 colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
 colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
-  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of
       NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
       _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
 colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id
-  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
+
+colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
+colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $
+   \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _) } -> maybe mempty dateTimeCell mbLastEdit
 
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
@@ -212,10 +224,10 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
                         , course E.^. CourseTerm
                         , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
                         )
-            in (submission, sheet, crse, corrector)
+            in (submission, sheet, crse, corrector, lastEditQuery submission)
           )
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
-      dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
+      dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector,  E.Value mbLastEdit) -> do
         submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
           E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
@@ -225,7 +237,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
           submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
-        dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
+        dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
   dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
@@ -271,6 +283,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
       , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
         )
+      , ( "last-edit"
+        , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission
+        )
       ]
     , dbtFilter    = Map.fromList
       [ ( "term"
@@ -502,7 +517,7 @@ postCorrectionsR = do
   let whereClause = ratedBy uid
       colonnade = mconcat
         [ colSelect
-        -- , dbRow
+        , dbRow     -- very useful, since correction statistics are still missing.
         , colSchool
         , colTerm
         , colCourse
@@ -531,7 +546,7 @@ postCorrectionsR = do
         optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
 
       psValidator = def
-        & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+        & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
         & restrictSorting (\name _ -> name /= "corrector")
         & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
         -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
@@ -551,6 +566,7 @@ postCCorrectionsR tid ssh csh = do
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
+        , colLastEdit
         , colRating
         , colRated
         , colCorrector
@@ -574,6 +590,7 @@ postSSubsR tid ssh csh shn = do
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
+        , colLastEdit
         , colRating
         , colRated
         , colCorrector
@@ -627,7 +644,7 @@ postCorrectionR tid ssh csh shn cid = do
             }
 
       ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
-            areq (zipFileField True) (fslI MsgRatingFiles) Nothing
+            areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
       let uploadForm = wrapForm uploadForm' def
             { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
             , formEncoding = uploadEncoding
@@ -703,7 +720,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
   ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
-       areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
+       areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
 
   case uploadRes of
     FormMissing -> return ()
@@ -897,8 +914,8 @@ postCorrectionsGradeR = do
         ] -- Continue here
       psValidator = def
         & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
-      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
+      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
-      dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
+      dbtProj' 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
         return i

src/Handler/Course.hs

@@ -11,7 +11,6 @@ import Handler.Utils
 import Handler.Utils.Course
 import Handler.Utils.Tutorial
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells

src/Handler/Material.hs

@@ -9,7 +9,7 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Conduit.List as C
 -- import qualified Data.CaseInsensitive as CI
-import qualified Data.Text.Encoding as Text
+-- import qualified Data.Text.Encoding as Text
 
 import qualified Database.Esqueleto as E
 import Database.Esqueleto.Utils.TH
@@ -107,15 +107,18 @@ getMaterialListR tid ssh csh = do
   seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
   table <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
+    let row2material = view $ _dbrOutput . _1 . _entityVal
         psValidator  = def & defaultSorting [SortDescBy "last-edit"]
     dbTableWidget' psValidator DBTable
       { dbtIdent     = "material-list" :: Text
       , dbtStyle     = def
       , dbtParams    = def
       , dbtSQLQuery  = \material -> do
-            E.where_ $ material E.^. MaterialCourse  E.==.  E.val cid
+          E.where_ $ material E.^. MaterialCourse  E.==.  E.val cid
-            return material
+          let filesNum = E.sub_select . E.from $ \materialFile -> do
+                E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
+                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
+          return (material, filesNum)
       , dbtRowKey    = (E.^. MaterialId)
       -- , dbtProj      = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
       , dbtProj      = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
@@ -127,8 +130,10 @@ getMaterialListR tid ssh csh = do
                 $ liftA2 anchorCell matLink toWgt . materialName . row2material
             , sortable (toNothingS "description") mempty
                 $ foldMap modalCell . materialDescription . row2material
-            , sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files!
+            , sortable (toNothingS "zip-archive") mempty
-                $ fileCell . filesLink . materialName . row2material
+                $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
+                  | fileNum == 0 -> mempty
+                  | otherwise    -> fileCell $ filesLink materialName
             , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
                 $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
             , sortable (Just "last-edit") (i18nCell MsgFileModified)
@@ -156,9 +161,9 @@ getMaterialListR tid ssh csh = do
 
 
 getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
-getMFileR tid ssh csh mnm title = serveOneFile fileQuery
+getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
   where
-    fileQuery = E.select $ E.from $
+    fileQuery = E.selectSource $ E.from $
       \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
         -- Restrict to consistent rows that correspond to each other
         E.on (file     E.^. FileId               E.==. matFile  E.^. MaterialFileFile)
@@ -180,7 +185,7 @@ getMShowR tid ssh csh mnm = do
       matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
 
       zipLink :: Route UniWorX
-      zipLink = CMaterialR tid ssh csh mnm MZipR
+      zipLink = CMaterialR tid ssh csh mnm MArchiveR
 
   seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
 
@@ -351,28 +356,12 @@ postMDelR tid ssh csh mnm = do
     , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
     }
 
--- | Variant of getMArchiveR that always serves a Zip Archive, even for single files. Kept, since we might change this according to UX feedback.
+-- | Serve all material-files
-getMZipR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
-getMZipR tid ssh csh mnm = do
-  let filename = ZIPArchiveName mnm
-  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
-  respondSourceDB "application/zip" $ do
-    mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm
-    -- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm
-    let
-      fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> do
-        E.on     $  materialFile E.^. MaterialFileFile E.==. file E.^. FileId
-        E.where_ $  materialFile E.^. MaterialFileMaterial E.==. E.val mid
-        return file
-      zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm)
-    fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder
-
--- | Variant of getMZipR that does not serve single file Zip Archives. Maybe confusing to users.
 getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
 getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery
   where
-    archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)
+    archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip"
-    getMatQuery = E.select . E.from $
+    getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
       \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
         E.on $ file     E.^. FileId         E.==. materialFile E.^. MaterialFileFile
         E.on $ material E.^. MaterialId     E.==. materialFile E.^. MaterialFileMaterial

src/Handler/Sheet.hs

@@ -14,7 +14,6 @@ import Handler.Utils.Table.Cells
 -- import Handler.Utils.Table.Columns
 import Handler.Utils.SheetType
 import Handler.Utils.Delete
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Data.Time
@@ -69,19 +68,19 @@ import Text.Hamlet (ihamlet)
 
 data SheetForm = SheetForm
       { sfName         :: SheetName
-      , sfDescription  :: Maybe Html
-      , sfType         :: SheetType
-      , sfGrouping     :: SheetGroup
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSubmissionMode :: SubmissionMode
-      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
-      , sfHintF        :: Maybe (Source Handler (Either FileId File))
       , sfSolutionFrom :: Maybe UTCTime
+      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
+      , sfHintF        :: Maybe (Source Handler (Either FileId File))
       , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
       , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
+      , sfType         :: SheetType
+      , sfGrouping     :: SheetGroup
+      , sfSubmissionMode :: SubmissionMode
+      , sfDescription  :: Maybe Html
       , sfMarkingText  :: Maybe Html
       -- Keine SheetId im Formular!
       }
@@ -103,12 +102,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
     ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
-      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
+      <* aformSection MsgSheetFormTimes
-                                                          (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType
-            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
-                                                          (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -116,17 +110,24 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
-      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
-      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
-            & setTooltip MsgSheetSolutionFromTip)
+            & setTooltip MsgSheetSolutionFromTip)             (sfSolutionFrom <$> template)
-                                                              (sfSolutionFrom <$> template)
+      <* aformSection MsgSheetFormFiles
+      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
-      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
+      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarkingFiles
-            & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
+            & setTooltip MsgSheetMarkingTip)                  (sfMarkingF <$> template)
+      <* aformSection MsgSheetFormType
+      <*> sheetTypeAFormReq   (fslI MsgSheetType
+            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
+                                                          (sfType        <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
+      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
+                                                          (sfDescription <$> template)
       <*> aopt htmlField    (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
     return $ case result of
       FormSuccess sheetResult
@@ -146,16 +147,33 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
 
 
 getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getSheetCurrentR tid ssh csh = runDB $ do
+getSheetCurrentR tid ssh csh = do
-  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
+  mbShn <- runDB $ sheetCurrent tid ssh csh
-  shn <- sheetCurrent tid ssh csh
+  case mbShn of
-  maybe notFound redi shn
+    Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR
+    Nothing  -> do -- no current sheet exists
+      -- users should never see a link to this URL in this situation,
+      -- but we had confused users that used a bookmark instead.
+      let headingShort = [whamlet|_{MsgMenuSheetCurrent}|]
+          headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent
+      siteLayout headingShort $ do
+        setTitleI headingLong
+        [whamlet|_{MsgSheetNoCurrent}|]
 
-getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
+
-getSheetOldUnassigned tid ssh csh = runDB $ do
+getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html
-  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
+getSheetOldUnassignedR tid ssh csh = do
-  shn <- sheetOldUnassigned tid ssh csh
+    mbShn <- runDB $ sheetOldUnassigned tid ssh csh
-  maybe notFound redi shn
+    case mbShn of
+      Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR
+      Nothing  -> do -- no unassigned submissions in any inactive sheet
+        -- users should never see a link to this URL in this situation,
+        -- but we had confused users that used a bookmark instead.
+        let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|]
+            headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned
+        siteLayout headingShort $ do
+          setTitleI headingLong
+          [whamlet|_{MsgSheetNoOldUnassigned}|]
 
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetListR tid ssh csh = do
@@ -198,7 +216,7 @@ getSheetListR tid ssh csh = do
               [ icnCell & addIconFixedWidth
               | let existingSFTs = hasSFT existFiles
               , sft <- [minBound..maxBound]
-              , let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft
+              , let link = CSheetR tid ssh csh sheetName $ SZipR sft
               , let icn  = toWidget $ sheetFile2markup sft
               , let icnCell = if sft `elem` existingSFTs
                               then linkEmptyCell link icn
@@ -438,11 +456,11 @@ postSPseudonymR tid ssh csh shn = do
 
 
 getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
-getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file
+getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal
 
-getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent
+getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
-getSZipR tid ssh csh shn filename@(ZIPArchiveName sft)
+getSZipR tid ssh csh shn sft
-  = serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
+  = serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
 
 
 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

src/Handler/Submission.hs

@@ -14,7 +14,6 @@ import Handler.Utils
 import Handler.Utils.Delete
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Control.Monad.Trans.Maybe
@@ -38,8 +37,6 @@ import Data.Map (Map, (!), (!?))
 import qualified Data.Map as Map
 -- import Data.Bifunctor
 
-import System.FilePath
-
 import Text.Blaze (Markup)
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
@@ -132,8 +129,19 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
     fileUploadForm = case uploadMode of
       NoUpload
         -> pure Nothing
-      (Upload unpackZips)
+      UploadAny{..}
-        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      UploadSpecific{..}
+        -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
+
+    specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
+    specificFileForm spec@UploadSpecificFile{..}
+      = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
+
+    mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
+    mergeFileSources (catMaybes -> sources) = case sources of
+      [] -> Nothing
+      fs -> Just $ sequence_ fs
 
     miCell' :: Markup -> Either UserEmail UserId -> Widget
     miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
@@ -354,7 +362,9 @@ submissionHelper tid ssh csh shn mcid = do
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
+  -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
+  -- Therefore we do not restrict upload behaviour in any way in that case
+  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies 
   let formWidget = wrapForm' BtnHandIn formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
@@ -515,8 +525,8 @@ submissionHelper tid ssh csh shn mcid = do
 
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
-    let urlArchive  cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
+    let urlArchive  cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected
-        urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
+        urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal
     $(widgetFile "submission")
 
 getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
@@ -525,72 +535,60 @@ postSInviteR = invitationR submissionUserInvitationConfig
 
 
 getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
-getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
+getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
-  submissionID <- submissionMatchesSheet tid ssh csh shn cID
+  (submissionID, isRating) <- runDB $ do
+    submissionID <- submissionMatchesSheet tid ssh csh shn cID
 
-  isRating <- (== Just submissionID) <$> isRatingFile path
+    isRating <- (== Just submissionID) <$> isRatingFile path
 
-  when (isUpdate || isRating) $
+    when (isUpdate || isRating) $
-    guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
+      guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
+
+    return (submissionID, isRating)
 
   case isRating of
     True
-      | isUpdate -> do
+      | isUpdate -> runDB $ do
           file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
           maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
       | otherwise -> notFound
     False -> do
-      results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+      let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
-        E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+            E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-        E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-             E.&&. f E.^. FileTitle E.==. E.val path
+                 E.&&. f E.^. FileTitle E.==. E.val path
-             E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
+                 E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
-             E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+                 E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-             -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
+                 -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
-        return f
+            return f
 
-      case results of
+      serveOneFile results
-        [] -> notFound
-        [Entity _ File{ fileContent = Just c, fileTitle }] -> do
-          whenM downloadFiles $
-            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
-          return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
-        [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
-        other -> do
-          $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
-          error "Multiple matching files found."
 
-getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
+getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
-getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
+getSubArchiveR tid ssh csh shn cID sfType = do
   when (sfType == SubmissionCorrected) $
     guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
 
   let filename
-        | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
+        | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType
-        | otherwise = ZIPArchiveName $ toPathPiece cID
+        | otherwise = toPathPiece cID
 
-  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
+      source = do
-  respondSourceDB "application/zip" $ do
+        submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
-    submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
+        rating <- lift $ getRating submissionID
-    rating <- lift $ getRating submissionID
 
-    let
+        case sfType of
-      fileSelect = case sfType of
+          SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
-        SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+            E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
-          E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
+            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+                 E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
-               E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
+            return f
-          return f
+          _ -> submissionFileSource submissionID .| Conduit.map entityVal
-        _ -> submissionFileSource submissionID
 
-      fileSource' = do
-        fileSelect .| Conduit.map entityVal
         when (sfType == SubmissionCorrected) $
           maybe (return ()) (yieldM . ratingFile cID) rating
 
-      zipComment = Text.encodeUtf8 $ toPathPiece cID
+  serveSomeFiles (unpack filename <.> "zip") source
-
-    fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
 
 getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
 getSubDelR = postSubDelR
@@ -612,4 +610,4 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
   when (null subs) $ do
     addMessageI Info MsgNoOpenSubmissions
     redirect CorrectionsR
-  submissionMultiArchive $ Set.fromList subs
+  submissionMultiArchive $ Set.fromList subs

src/Handler/Term.hs

@@ -3,7 +3,6 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
 import Utils.Lens

src/Handler/Tutorial.hs

@@ -8,7 +8,6 @@ import Handler.Utils.Tutorial
 import Handler.Utils.Table.Cells
 import Handler.Utils.Delete
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Form.Occurences
 import Handler.Utils.Invitations
 import Jobs.Queue

src/Handler/Utils.hs

@@ -38,6 +38,7 @@ import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
 
 
+-- | Check whether the user's preference for files is inline-viewing or downloading
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
 downloadFiles = do
   mauth <- liftHandlerT maybeAuth
@@ -47,40 +48,47 @@ downloadFiles = do
       UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
       return userDefaultDownloadFiles
 
+setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
+setContentDisposition' mFileName = do
+  wantsDownload <- downloadFiles
+  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
+
+-- | Simply send a `File`-Value
+sendThisFile :: File -> Handler TypedContent
+sendThisFile File{..}
+  | Just fileContent' <- fileContent = do
+      setContentDisposition' . Just $ takeFileName fileTitle
+      return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+  | otherwise = sendResponseStatus noContent204 ()
+
 -- | Serve a single file, identified through a given DB query
-serveOneFile :: DB [Entity File] -> Handler TypedContent
+serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
-serveOneFile query = do
+serveOneFile source = do
-  results <- runDB query
+  results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
   case results of
-    [Entity _fileId File{fileTitle, fileContent}]
+    [file] -> sendThisFile file
-      | Just fileContent' <- fileContent -> do
+    []     -> notFound
-          whenM downloadFiles $
+    other  -> do
-            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
-          return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
-      | otherwise -> sendResponseStatus noContent204 ()
-    [] -> notFound
-    other -> do
       $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
       error "Multiple matching files found."
 
 -- | Serve one file directly or a zip-archive of files, identified through a given DB query
+--
 -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
-serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent
+serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
-serveSomeFiles archiveName query = do
+serveSomeFiles archiveName source = do
-  results <- runDB query
+  results <- runDB . runConduit $ source .| peekN 2
+
+  $logDebugS "serveSomeFiles" . tshow $ length results
+  
   case results of
-    [] -> notFound
+    []         -> notFound
-    [Entity _fileId File{fileTitle, fileContent}]
+    [file]     -> sendThisFile file
-      | Just fileContent' <- fileContent -> do
+    _moreFiles -> do
-          whenM downloadFiles $
+      setContentDisposition' $ Just archiveName
-            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
-          return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
-      | otherwise -> sendResponseStatus noContent204 ()
-    files -> do
-      addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|]
       respondSourceDB "application/zip" $ do
-        let zipComment = T.encodeUtf8 archiveName
+        let zipComment = T.encodeUtf8 $ pack archiveName
-        yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
 
 
 tidFromText :: Text -> Maybe TermId

src/Handler/Utils/Communication.hs

@@ -9,7 +9,6 @@ module Handler.Utils.Communication
 
 import Import
 import Handler.Utils
-import Handler.Utils.Form.MassInput
 import Utils.Lens
 
 import Jobs.Queue

src/Handler/Utils/Form.hs

@@ -1,5 +1,6 @@
 module Handler.Utils.Form
   ( module Handler.Utils.Form
+  , module Handler.Utils.Form.MassInput
   , module Utils.Form
   , MonadWriter(..)
   ) where
@@ -35,6 +36,7 @@ import qualified Data.Map as Map
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
 import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
+import Control.Monad.Error.Class (MonadError(..))
 
 import Data.Scientific (Scientific)
 import Text.Read (readMaybe)
@@ -49,6 +51,13 @@ import Data.Proxy
 
 import qualified Text.Email.Validate as Email
 
+import Yesod.Core.Types (FileInfo(..))
+
+import System.FilePath (isExtensionOf)
+import Data.Text.Lens (unpacked)
+
+import Handler.Utils.Form.MassInput
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -341,14 +350,88 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
           }
 
 
-uploadModeField :: Field Handler UploadMode
+uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
-uploadModeField = selectField optionsFinite
+uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
+  where
+    actions :: Map UploadModeDescr (AForm Handler UploadMode)
+    actions = Map.fromList
+      [ ( UploadModeNone, pure NoUpload)
+      , ( UploadModeAny
+        , UploadAny
+          <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
+          <*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
+        )
+      , ( UploadModeSpecific
+        , UploadSpecific <$> specificFileForm
+        )
+      ]
+  
+    extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension)))
+    extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField
+      where
+        toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
+        stripDot ext
+          | Just nExt <- Text.stripPrefix "." ext = nExt
+          | otherwise = ext
+    
+    specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
+    specificFileForm = wFormToAForm $ do
+      Just currentRoute <- getCurrentRoute
+      let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
+      miIdent <- ("specific-files--" <>) <$> newIdent
+      postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
+      where
+        preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
+        preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
+        
+        postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
+        postProcess mapResult = do
+          MsgRenderer mr <- getMsgRenderer
+          return $ do
+            mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult
+            case fromNullable mapResult' of
+              Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured]
+              Just lResult -> do
+                let names = Set.map specificFileName mapResult'
+                    labels = Set.map specificFileLabel mapResult'
+                if
+                  | Set.size names /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateNames]
+                  | Set.size labels /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateLabels]
+                  | otherwise
+                    -> return lResult
+
+        sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile
+        sFileForm nudge mPrevUF csrf = do
+          (labelRes, labelView) <- mpreq textField ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
+          (nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF
+          (reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
+
+          return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes
+                 , $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
+                 )
+
+        miAdd _ _ nudge submitView = Just $ \csrf -> do
+          (formRes, formWidget) <- sFileForm nudge Nothing csrf
+          let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
+              addRes' = formRes <&> \fileRes oldRess ->
+                let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
+                 in pure $ Map.singleton iStart fileRes
+          return (addRes', formWidget')
+        miCell _ initFile initFile' nudge csrf =
+          sFileForm nudge (Just $ fromMaybe initFile initFile') csrf
+        miDelete = miDeleteList
+        miAllowAdd _ _ _ = True
+        miAddEmpty _ _ _ = Set.empty
+        miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
+                                               
 
 submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
 submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
   where
-    uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
-
     actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
     actions = Map.fromList
       [ ( SubmissionModeNone
@@ -358,10 +441,10 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
         , pure $ SubmissionMode True  Nothing
         )
       , ( SubmissionModeUser
-        , SubmissionMode False . Just <$> uploadModeForm
+        , SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       , ( SubmissionModeBoth
-        , SubmissionMode True  . Just <$> uploadModeForm
+        , SubmissionMode True  . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       ]
 
@@ -374,17 +457,41 @@ pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (re
       | otherwise
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
-zipFileField :: Bool -- ^ Unpack zips?
+specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
-             -> Field Handler (Source Handler File)
+specificFileField UploadSpecificFile{..} = Field{..}
-zipFileField doUnpack = Field{..}
   where
     fieldEnctype = Multipart
     fieldParse _ files
-      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
+      | [f] <- files
+      = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
+      | null files   = return $ Right Nothing
+      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
+    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
+
+    extensions = fileNameExtensions specificFileName
+    acceptRestricted = not $ null extensions
+    accept = Text.intercalate "," . map ("." <>) $ extensions
+
+
+zipFileField :: Bool -- ^ Unpack zips?
+             -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
+             -> Field Handler (Source Handler File)
+zipFileField doUnpack permittedExtensions = Field{..}
+  where
+    fieldEnctype = Multipart
+    fieldParse _ files
+      | [f@FileInfo{..}] <- files
+      , maybe True (anyOf (re _nullable . folded . unpacked) (`isExtensionOf` unpack fileName)) permittedExtensions || doUnpack
+      = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
       | null files   = return $ Right Nothing
       | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
     fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
 
+    zipExtensions = mimeExtensions "application/zip"
+
+    acceptRestricted = isJust permittedExtensions
+    accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
+
 multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
 multiFileField permittedFiles' = Field{..}
   where
@@ -590,23 +697,6 @@ jsonField hide = Field{..}
     |]
     fieldEnctype = UrlEncoded
 
-secretJsonField :: ( ToJSON a, FromJSON a
-                   , MonadHandler m
-                   , HandlerSite m ~ UniWorX
-                   )
-                => Field m a
-secretJsonField = Field{..}
-  where
-    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
-    fieldParse [] [] = return $ Right Nothing
-    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
-    fieldView theId name attrs val _isReq = do
-      val' <- traverse (encodedSecretBox SecretBoxShort) val
-      [whamlet|
-        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
-      |]
-    fieldEnctype = UrlEncoded
-
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              )

src/Handler/Utils/Form/MassInput.hs

@@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
 import Import
 import Utils.Form
 import Utils.Lens
-import Handler.Utils.Form (secretJsonField)
 import Handler.Utils.Form.MassInput.Liveliness
 import Handler.Utils.Form.MassInput.TH
 

src/Handler/Utils/Form/Occurences.hs

@@ -4,7 +4,6 @@ module Handler.Utils.Form.Occurences
 
 import Import
 import Handler.Utils.Form
-import Handler.Utils.Form.MassInput
 import Handler.Utils.DateTime
 
 import qualified Data.Set as Set

src/Handler/Utils/Submission.hs

@@ -318,8 +318,10 @@ extractRatingsMsg = do
   let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
       ignoredFiles = Right `Set.map` ignored'
   unless (null ignoredFiles) $ do
-    mr <- (toHtml . ) <$> getMessageRender
+    let ignoredModal = msgModal
-    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+          [whamlet|_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}|]
+          (Right $(widgetFile "messages/submissionFilesIgnored"))
+    addMessageWidget Warning ignoredModal
 
 -- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
 msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
@@ -362,10 +364,28 @@ sinkSubmission userId mExists isUpdate = do
       return sId
     Right sId -> return sId
 
-  sId <$ sinkSubmission' sId
+  Sheet{..} <- lift $ case mExists of
+    Left sheetId -> getJust sheetId
+    Right subId  -> getJust . submissionSheet =<< getJust subId
+
+  sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId)
   where
     tellSt = modify . mappend
 
+    guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent
+    guardFileTitles SubmissionMode{..}
+      | Just UploadAny{..} <- submissionModeUser
+      , not isUpdate
+      , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
+      = Conduit.mapM $ \x -> if
+          | Left File{..} <- x
+          , none (`isExtensionOf` fileTitle) exts
+          , isn't _Nothing fileContent -- File record is not a directory, we don't care about those
+            -> throwM $ InvalidFileTitleExtension fileTitle
+          | otherwise
+            -> return x
+      | otherwise = Conduit.map id
+
     sinkSubmission' :: SubmissionId
                     -> Sink SubmissionContent (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case

src/Import/NoFoundation.hs

@@ -99,6 +99,8 @@ import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
 
 import Data.Ratio as Import ((%))
 
+import Network.Mime as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Model/Migration.hs

@@ -79,7 +79,7 @@ migrateAll = do
 
 requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
-  initial <- getMigration initialMigration
+  initial <- either id (map snd) <$> parseMigration initialMigration
   when (not $ null initial) $ do
     $logInfoS "Migration" $ intercalate "; " initial
     throwError True
@@ -89,7 +89,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do
     $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
     throwError True
     
-  automatic <- getMigration migrateAll'
+  automatic <- either id (map snd) <$> parseMigration migrateAll'
   when (not $ null automatic) $ do
     $logInfoS "Migration" $ intercalate "; " automatic
     throwError True
@@ -279,8 +279,8 @@ customMigrations = Map.fromListWith (>>)
                 ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
                 ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
                 ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
-                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ Upload True)
+                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
-                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
+                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
           [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
     )
   , ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]

src/Model/Submission.hs

@@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
                              | DuplicateRating
                              | RatingWithoutUpdate
                              | ForeignRating CryptoFileNameSubmission
+                             | InvalidFileTitleExtension FilePath
   deriving (Typeable, Show)
 
 instance Exception SubmissionSinkException

src/Model/Types.hs

@@ -1,10 +1,14 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-# LANGUAGE UndecidableInstances #-}
-           , UndecidableInstances
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
+
+
 module Model.Types
   ( module Model.Types
+  , module Model.Types.Sheet
+  , module Model.Types.DateTime
+  , module Model.Types.Security
+  , module Model.Types.Misc
   , module Numeric.Natural
   , module Mail
   , module Utils.DateTime
@@ -12,86 +16,32 @@ module Model.Types
   ) where
 
 import ClassyPrelude
-import Utils
-import Control.Lens hiding (universe)
-import Utils.Lens.TH
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Fixed
-import Data.Monoid (Sum(..))
-import Data.Maybe (fromJust)
-import Data.Universe
-import Data.Universe.Helpers
-import Data.Universe.TH
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
-
 import Data.NonNull.Instances ()
 
-import Data.Default
-
-import Text.Read (readMaybe)
-
-import Database.Persist.TH hiding (derivePersistFieldJSON)
-import Model.Types.JSON
-import Database.Persist.Class
-import Database.Persist.Sql
-
-import Web.HttpApiData
-import Web.PathPieces
-
-import Text.Blaze (Markup)
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.Text.Lens as Text
-
-import qualified Data.HashMap.Strict as HashMap
-
 import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
 import Data.CaseInsensitive.Instances ()
 
-import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Types as Aeson
-import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
-import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
-
-import GHC.Generics (Generic)
-import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-import Data.Typeable (Typeable)
-
 import Data.Universe.Instances.Reverse ()
 
+import Yesod.Core.Dispatch (PathPiece(..))
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
+import Web.PathPieces
 
 import Mail (MailLanguages(..))
 import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
-
 import Numeric.Natural
-import Data.Word.Word24 (Word24)
-import Data.Bits
-import Data.Ix
-import Data.List (genericIndex, elemIndex)
-import System.Random (Random(..))
-import Data.Data (Data)
 
-import Model.Types.Wordlist
+import Model.Types.Sheet
-import Data.Text.Metrics (damerauLevenshtein)
+import Model.Types.DateTime
-
+import Model.Types.Security
-import Data.Binary (Binary)
+import Model.Types.Misc
-import qualified Data.Binary as Binary
-
-import Time.Types (WeekDay(..))
-import Data.Time.LocalTime (LocalTime, TimeOfDay)
-
-import Data.Semigroup (Min(..))
-import Control.Monad.Trans.Writer (execWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
 
+----
+-- Just bringing together the different Model.Types submodules.
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -102,885 +52,6 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where
   toPathMultiPiece = Text.splitOn "/" . pack
 
 
-type Count  = Sum Integer
-type Points = Centi
-
-toPoints :: Integral a => a -> Points -- deprecated
-toPoints = fromIntegral
-
-pToI :: Points -> Integer -- deprecated
-pToI = fromPoints
-
-fromPoints :: Integral a => Points -> a -- deprecated
-fromPoints = round
-
-instance DisplayAble Points
-
-instance DisplayAble a => DisplayAble (Sum a) where
-  display (Sum x) = display x
-
-data SheetGrading
-  = Points     { maxPoints :: Points }
-  | PassPoints { maxPoints, passingPoints :: Points }
-  | PassBinary -- non-zero means passed
-  deriving (Eq, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"
-  } ''SheetGrading
-derivePersistFieldJSON ''SheetGrading
-
-makeLenses_ ''SheetGrading
-
-_passingBound :: Fold SheetGrading (Either () Points)
-_passingBound = folding passPts
-  where
-    passPts :: SheetGrading -> Maybe (Either () Points)
-    passPts (Points{}) = Nothing
-    passPts (PassPoints{passingPoints}) = Just $ Right passingPoints
-    passPts (PassBinary) = Just $ Left ()
-
-gradingPassed :: SheetGrading -> Points -> Maybe Bool
-gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
-    where pBinary _ = pts /= 0
-          pPoints b = pts >= b
-
-
-data SheetGradeSummary = SheetGradeSummary
-  { numSheets       :: Count       -- Total number of sheets, includes all
-  , numSheetsPasses :: Count       -- Number of sheets required to pass FKA: numGradePasses
-  , numSheetsPoints :: Count       -- Number of sheets having points    FKA: sumGradePointsd
-  , sumSheetsPoints :: Sum Points  -- Total of all points in all sheets
-  -- Marking dependend
-  , numMarked       :: Count       -- Number of already marked sheets
-  , numMarkedPasses :: Count       -- Number of already marked sheets with passes
-  , numMarkedPoints :: Count       -- Number of already marked sheets with points
-  , sumMarkedPoints :: Sum Points  -- Achieveable points within marked sheets
-  --
-  , achievedPasses :: Count        -- Achieved passes (within marked sheets)
-  , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
-  } deriving (Generic, Read, Show, Eq)
-
-instance Monoid SheetGradeSummary where
-  mempty  = memptydefault
-  mappend = mappenddefault
-
-instance Semigroup SheetGradeSummary where
-  (<>) = mappend -- TODO: remove for GHC > 8.4.x
-
-makeLenses_ ''SheetGradeSummary
-
-sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
-sheetGradeSum gr Nothing  = mempty
-  { numSheets = 1
-  , numSheetsPasses = bool  mempty   1 $ has _passingBound gr
-  , numSheetsPoints = bool  mempty   1 $ has _maxPoints    gr
-  , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
-  }
-sheetGradeSum gr (Just p) =
-  let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
-  in  unmarked
-        { numMarked       = numSheets
-        , numMarkedPasses = numSheetsPasses
-        , numMarkedPoints = numSheetsPoints
-        , sumMarkedPoints = sumSheetsPoints
-        , achievedPasses  = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p
-        , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
-        }
-
-
-data SheetType
-  = NotGraded
-  | Normal        { grading :: SheetGrading }
-  | Bonus         { grading :: SheetGrading }
-  | Informational { grading :: SheetGrading }
-  deriving (Eq, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = camelToPathPiece
-  , sumEncoding = TaggedObject "type" "data"
-  } ''SheetType
-derivePersistFieldJSON ''SheetType
-
-data SheetTypeSummary = SheetTypeSummary
-  { normalSummary
-  , bonusSummary
-  , informationalSummary :: SheetGradeSummary
-  , numNotGraded :: Count
-  } deriving (Generic, Read, Show, Eq)
-
-instance Monoid SheetTypeSummary where
-  mempty  = memptydefault
-  mappend = mappenddefault
-
-instance Semigroup SheetTypeSummary where
-  (<>) = mappend -- TODO: remove for GHC > 8.4.x
-
-makeLenses_ ''SheetTypeSummary
-
-sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
-sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
-sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }
-
-data SheetGroup
-  = Arbitrary { maxParticipants :: Natural }
-  | RegisteredGroups
-  | NoGroups
-  deriving (Show, Read, Eq, Generic)
-deriveJSON defaultOptions ''SheetGroup
-derivePersistFieldJSON ''SheetGroup
-
-makeLenses_ ''SheetGroup
-
-data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-derivePersistField "SheetFileType"
-
-instance Universe SheetFileType where universe = universeDef
-instance Finite SheetFileType
-
-instance PathPiece SheetFileType where
-  toPathPiece SheetExercise = "file"
-  toPathPiece SheetHint     = "hint"
-  toPathPiece SheetSolution = "solution"
-  toPathPiece SheetMarking  = "marking"
-  fromPathPiece = finiteFromPathPiece
-
-sheetFile2markup :: SheetFileType -> Markup
-sheetFile2markup SheetExercise = iconQuestion
-sheetFile2markup SheetHint     = iconHint
-sheetFile2markup SheetSolution = iconSolution
-sheetFile2markup SheetMarking  = iconMarking
-
--- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
-instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
-  display SheetExercise = "Aufgabenstellung"
-  display SheetHint     = "Hinweise"
-  display SheetSolution = "Musterlösung"
-  display SheetMarking  = "Korrekturhinweise"
-
--- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
--- partitionFileType' = groupMap
-
-partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
-partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
-
-data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-
-instance Universe SubmissionFileType where universe = universeDef
-instance Finite SubmissionFileType
-
-submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
-submissionFileTypeIsUpdate SubmissionOriginal  = False
-submissionFileTypeIsUpdate SubmissionCorrected = True
-
-isUpdateSubmissionFileType :: Bool -> SubmissionFileType
-isUpdateSubmissionFileType False = SubmissionOriginal
-isUpdateSubmissionFileType True  = SubmissionCorrected
-
-instance PathPiece SubmissionFileType where
-  toPathPiece SubmissionOriginal  = "original"
-  toPathPiece SubmissionCorrected = "corrected"
-  fromPathPiece = finiteFromPathPiece
-
-instance DisplayAble SubmissionFileType where
-  display SubmissionOriginal  = "Abgabe"
-  display SubmissionCorrected = "Korrektur"
-
-{-
-data DA = forall a . (DisplayAble a) => DA a
-
-instance DisplayAble DA where
-  display (DA x) = display x
--}
-
-
-data UploadMode = NoUpload | Upload { unpackZips :: Bool }
-  deriving (Show, Read, Eq, Ord, Generic)
-
-deriveFinite ''UploadMode
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = camelToPathPiece
-  , sumEncoding = TaggedObject "mode" "settings"
-  }''UploadMode
-derivePersistFieldJSON ''UploadMode
-
-instance PathPiece UploadMode where
-  toPathPiece = \case
-    NoUpload     -> "no-upload"
-    Upload True  -> "unpack"
-    Upload False -> "no-unpack"
-  fromPathPiece = finiteFromPathPiece
-
-data SubmissionMode = SubmissionMode
-  { submissionModeCorrector :: Bool
-  , submissionModeUser :: Maybe UploadMode
-  }
-  deriving (Show, Read, Eq, Ord, Generic)
-
-deriveFinite ''SubmissionMode
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 2
-  } ''SubmissionMode
-derivePersistFieldJSON ''SubmissionMode
-
-finitePathPiece ''SubmissionMode
-  [ "no-submissions"
-  , "no-upload"
-  , "no-unpack"
-  , "unpack"
-  , "correctors"
-  , "correctors+no-upload"
-  , "correctors+no-unpack"
-  , "correctors+unpack"
-  ]
-
-data SubmissionModeDescr = SubmissionModeNone
-                         | SubmissionModeCorrector
-                         | SubmissionModeUser
-                         | SubmissionModeBoth
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-instance Universe SubmissionModeDescr
-instance Finite SubmissionModeDescr
-
-finitePathPiece ''SubmissionModeDescr
-  [ "no-submissions"
-  , "correctors"
-  , "users"
-  , "correctors+users"
-  ]
-
-classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
-classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
-classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
-classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
-classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
-
-
-data ExamStatus = Attended | NoShow | Voided
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-derivePersistField "ExamStatus"
-
--- | Specify a corrector's workload
-data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
-    = Load { byTutorial :: Maybe Bool  -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
-           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
-           }
-  deriving (Show, Read, Eq, Ord, Generic)
-
-deriveJSON defaultOptions ''Load
-derivePersistFieldJSON ''Load
-
-instance Hashable Load
-
-instance Semigroup Load where
-  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
-    where
-      byTut''
-        | Nothing <- byTut  = byTut'
-        | Nothing <- byTut' = byTut
-        | Just a <- byTut
-        , Just b <- byTut'  = Just $ a || b
-
-instance Monoid Load where
-  mempty = Load Nothing 0
-  mappend = (<>)
-
-{- Use (is _ByTutorial) instead of this unneeded definition:
-  isByTutorial :: Load -> Bool
-  isByTutorial (ByTutorial {}) = True
-  isByTutorial _               = False
--}
-
-data Season = Summer | Winter
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
-
-instance Binary Season
-
-seasonToChar :: Season -> Char
-seasonToChar Summer = 'S'
-seasonToChar Winter = 'W'
-
-seasonFromChar :: Char -> Either Text Season
-seasonFromChar c
-  | c ~= 'S'  = Right Summer
-  | c ~= 'W'  = Right Winter
-  | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
-  where
-    (~=) = (==) `on` CI.mk
-
-instance DisplayAble Season
-
-data TermIdentifier = TermIdentifier
-  { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
-  , season :: Season
-  } deriving (Show, Read, Eq, Ord, Generic, Typeable)
-
-instance Binary TermIdentifier
-
-instance Enum TermIdentifier where
-  -- ^ Do not use for conversion – Enumeration only
-  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
-  fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
-
--- Conversion TermId <-> TermIdentifier::
--- from_TermId_to_TermIdentifier = unTermKey
--- from_TermIdentifier_to_TermId = TermKey
-
-shortened :: Iso' Integer Integer
-shortened = iso shorten expand
-  where
-    century = ($currentYear `div` 100) * 100
-    expand year
-      | 0 <= year
-      , year < 100 = let
-          options = [ expanded | offset <- [-1, 0, 1]
-                               , let century' = century + offset * 100
-                                     expanded = century' + year
-                               , $currentYear - 50 <= expanded
-                               , expanded < $currentYear + 50
-                               ]
-          in case options of
-               [unique] -> unique
-               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
-      | otherwise = year
-    shorten year
-      | $currentYear - 50 <= year
-      , year < $currentYear + 50 = year `mod` 100
-      | otherwise = year
-
-termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
-
--- also see Hander.Utils.tidFromText
-termFromText :: Text -> Either Text TermIdentifier
-termFromText t
-  | (s:ys) <- Text.unpack t
-  , Just (review shortened -> year) <- readMaybe ys
-  , Right season <- seasonFromChar s
-  = Right TermIdentifier{..}
-  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
-
-termToRational :: TermIdentifier -> Rational
-termToRational TermIdentifier{..} = fromInteger year + seasonOffset
-  where
-    seasonOffset
-      | Summer <- season = 0
-      | Winter <- season = 0.5
-
-termFromRational :: Rational -> TermIdentifier
-termFromRational n = TermIdentifier{..}
-  where
-    year = floor n
-    remainder = n - (fromInteger $ floor n)
-    season
-      | remainder == 0 = Summer
-      | otherwise      = Winter
-
-instance PersistField TermIdentifier where
-  toPersistValue = PersistRational . termToRational
-  fromPersistValue (PersistRational t) = Right $ termFromRational t
-  fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
-
-instance PersistFieldSql TermIdentifier where
-  sqlType _ = SqlNumeric 5 1
-
-instance ToHttpApiData TermIdentifier where
-  toUrlPiece = termToText
-
-instance FromHttpApiData TermIdentifier where
-  parseUrlPiece = termFromText
-
-instance PathPiece TermIdentifier where
-  fromPathPiece = either (const Nothing) Just . termFromText
-  toPathPiece = termToText
-
-instance ToJSON TermIdentifier where
-  toJSON = Aeson.String . termToText
-
-instance FromJSON TermIdentifier where
-  parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
-
-{- Must be defined in a later module:
-    termField :: Field (HandlerT UniWorX IO) TermIdentifier
-    termField = checkMMap (return . termFromText) termToText textField
-   See Handler.Utils.Form.termsField and termActiveField
--}
-
-
-withinTerm :: Day -> TermIdentifier -> Bool
-time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
-  where
-    timeYear = fst3 $ toGregorian time
-    termYear = year term
-
-
-data StudyFieldType = FieldPrimary | FieldSecondary
-  deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
-derivePersistField "StudyFieldType"
-
-instance PersistField UUID where
-  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
-  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
-  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
-
-instance PersistFieldSql UUID where
-  sqlType _ = SqlOther "uuid"
-
-instance DisplayAble StudyFieldType
-
-data Theme
-  = ThemeDefault
-  | ThemeLavender
-  | ThemeNeutralBlue
-  | ThemeAberdeenReds
-  | ThemeMossGreen
-  | ThemeSkyLove
-  deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = fromJust . stripPrefix "Theme"
-  } ''Theme
-
-instance Universe Theme where universe = universeDef
-instance Finite Theme
-
-nullaryPathPiece ''Theme (camelToPathPiece' 1)
-
-$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
-
-derivePersistField "Theme"
-
-
-newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
-  deriving (Show, Read, Eq, Ord, Generic, Typeable)
-
-instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
-    fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
-    toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
-
-
-data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = fromJust . stripPrefix "Corrector"
-  } ''CorrectorState
-
-instance Universe CorrectorState
-instance Finite CorrectorState
-
-instance Hashable CorrectorState
-
-nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
-
-derivePersistField "CorrectorState"
-
-
-data AuthenticationMode = AuthLDAP
-                        | AuthPWHash { authPWHash :: Text }
-  deriving (Eq, Ord, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = UntaggedValue
-  } ''AuthenticationMode
-
-derivePersistFieldJSON ''AuthenticationMode
-
-
-derivePersistFieldJSON ''Value
-
-
--- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
---
--- Could maybe be replaced with `Structure Notification` in the long term
-data NotificationTrigger = NTSubmissionRatedGraded
-                         | NTSubmissionRated
-                         | NTSheetActive
-                         | NTSheetSoonInactive
-                         | NTSheetInactive
-                         | NTCorrectionsAssigned
-                         | NTCorrectionsNotDistributed
-                         | NTUserRightsUpdate
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe NotificationTrigger
-instance Finite NotificationTrigger
-
-instance Hashable NotificationTrigger
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  } ''NotificationTrigger
-
-instance ToJSONKey NotificationTrigger where
-  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
-
-instance FromJSONKey NotificationTrigger where
-  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
-
-
-newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
-  deriving (Generic, Typeable)
-  deriving newtype (Eq, Ord, Read, Show)
-
-instance Default NotificationSettings where
-  def = NotificationSettings $ \case
-    NTSubmissionRatedGraded -> True
-    NTSubmissionRated -> False
-    NTSheetActive -> True
-    NTSheetSoonInactive -> False
-    NTSheetInactive -> True
-    NTCorrectionsAssigned -> True
-    NTCorrectionsNotDistributed -> True
-    NTUserRightsUpdate -> True
-
-instance ToJSON NotificationSettings where
-  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
-
-instance FromJSON NotificationSettings where
-  parseJSON = withObject "NotificationSettings" $ \o -> do
-    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
-    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
-      Nothing -> notificationAllowed def n
-      Just b  -> b
-
-derivePersistFieldJSON ''NotificationSettings
-
-
-instance ToBackendKey SqlBackend record => Hashable (Key record) where
-  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
-
-derivePersistFieldJSON ''MailLanguages
-
-
-type PseudonymWord   = CI Text
-
-newtype Pseudonym = Pseudonym Word24
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
-
-
-instance PersistField Pseudonym where
-  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
-  fromPersistValue v = do
-    w <- fromPersistValue v :: Either Text Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> Left "Pseudonym out of range"
-
-instance PersistFieldSql Pseudonym where
-  sqlType _ = SqlInt32
-
-instance Random Pseudonym where
-  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
-  random = randomR (minBound, maxBound)
-
-instance FromJSON Pseudonym where
-  parseJSON v@(Aeson.Number _) = do
-    w <- parseJSON v :: Aeson.Parser Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> fail "Pseudonym out auf range"
-  parseJSON (Aeson.String t)
-    = case t ^? _PseudonymText of
-        Just p -> return p
-        Nothing -> fail "Could not parse pseudonym"
-  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
-    ws' <- toList . map CI.mk <$> mapM parseJSON ws
-    case ws' ^? _PseudonymWords of
-      Just p -> return p
-      Nothing -> fail "Could not parse pseudonym words"
-
-instance ToJSON Pseudonym where
-  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
-
-pseudonymWordlist :: [PseudonymWord]
-pseudonymCharacters :: Set (CI Char)
-(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
-
-_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
-_PseudonymWords = prism' pToWords pFromWords
-  where
-    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
-    pFromWords [w1, w2]
-      | Just i1 <- elemIndex w1 pseudonymWordlist
-      , Just i2 <- elemIndex w2 pseudonymWordlist
-      , i1 <= maxWord, i2 <= maxWord
-      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
-    pFromWords _ = Nothing
-
-    pToWords :: Pseudonym -> [PseudonymWord]
-    pToWords (Pseudonym p)
-      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
-        , genericIndex pseudonymWordlist $ p .&. maxWord
-        ]
-
-    maxWord :: Num a => a
-    maxWord = 0b111111111111
-
-_PseudonymText :: Prism' Text Pseudonym
-_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
-  where
-    tFromWords :: Text -> Maybe [PseudonymWord]
-    tFromWords input
-      | [result] <- input ^.. pseudonymFragments
-      = Just result
-      | otherwise
-      = Nothing
-
-    tToWords :: [PseudonymWord] -> Text
-    tToWords = Text.unwords . map CI.original
-
-pseudonymWords :: Fold Text PseudonymWord
-pseudonymWords = folding
-  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
-  where
-    distance = damerauLevenshtein `on` CI.foldedCase
-    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
-    distanceCutoff = 2
-
-pseudonymFragments :: Fold Text [PseudonymWord]
-pseudonymFragments = folding
-  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
-
-
-data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
-  = AuthAdmin
-  | AuthLecturer
-  | AuthCorrector
-  | AuthTutor
-  | AuthCourseRegistered
-  | AuthTutorialRegistered
-  | AuthParticipant
-  | AuthTime
-  | AuthMaterials
-  | AuthOwner
-  | AuthRated
-  | AuthUserSubmissions
-  | AuthCorrectorSubmissions
-  | AuthCapacity
-  | AuthRegisterGroup
-  | AuthEmpty
-  | AuthSelf
-  | AuthAuthentication
-  | AuthNoEscalation
-  | AuthRead
-  | AuthWrite
-  | AuthToken
-  | AuthDeprecated
-  | AuthDevelopment
-  | AuthFree
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-
-instance Universe AuthTag
-instance Finite AuthTag
-instance Hashable AuthTag
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''AuthTag
-
-nullaryPathPiece ''AuthTag (camelToPathPiece' 1)
-
-instance ToJSONKey AuthTag where
-  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
-
-instance FromJSONKey AuthTag where
-  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
-
-instance Binary AuthTag
-
-
-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
-
-
-data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-instance Hashable a => Hashable (PredLiteral a)
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "val" "var"
-  } ''PredLiteral
-
-instance PathPiece a => PathPiece (PredLiteral a) where
-  toPathPiece PLVariable{..} = toPathPiece plVar
-  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
-
-  fromPathPiece t = PLVariable <$> fromPathPiece t
-                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
-
-instance Binary a => Binary (PredLiteral a)
-
-
-newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving newtype (Semigroup, Monoid)
-
-$(return [])
-
-instance ToJSON a => ToJSON (PredDNF a) where
-  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
-instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
-  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
-
-instance (Ord a, Binary a) => Binary (PredDNF a) where
-  get = PredDNF <$> Binary.get
-  put = Binary.put . dnfTerms
-
-type AuthLiteral = PredLiteral AuthTag
-
-type AuthDNF = PredDNF AuthTag
-
-
-data LecturerType = CourseLecturer | CourseAssistant
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe LecturerType
-instance Finite LecturerType
-
-nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
-deriveJSON  defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''LecturerType
-derivePersistFieldJSON ''LecturerType
-
-instance Hashable LecturerType
-
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  } ''WeekDay
-
-data OccurenceSchedule = ScheduleWeekly
-                         { scheduleDayOfWeek :: WeekDay
-                         , scheduleStart     :: TimeOfDay
-                         , scheduleEnd       :: TimeOfDay
-                         }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , tagSingleConstructors = True
-  , sumEncoding = TaggedObject "repeat" "schedule"
-  } ''OccurenceSchedule
-
-data OccurenceException = ExceptOccur
-                          { exceptDay   :: Day
-                          , exceptStart :: TimeOfDay
-                          , exceptEnd   :: TimeOfDay
-                          }
-                        | ExceptNoOccur
-                          { exceptTime  :: LocalTime
-                          }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "exception" "for"
-  } ''OccurenceException
-
-data Occurences = Occurences
-  { occurencesScheduled  :: Set OccurenceSchedule
-  , occurencesExceptions :: Set OccurenceException
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''Occurences
-derivePersistFieldJSON ''Occurences
-
-
-data HealthReport = HealthReport
-  { healthMatchingClusterConfig :: Bool
-    -- ^ Is the database-stored configuration we're running under still up to date?
-  , healthHTTPReachable :: Maybe Bool
-    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
-    --
-    -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
-  , healthLDAPAdmins :: Maybe Rational
-    -- ^ Proportion of school admins that could be found in LDAP
-    --
-    -- Is `Nothing` if LDAP is not configured or no users are school admins
-  , healthSMTPConnect :: Maybe Bool
-    -- ^ Can we connect to the SMTP server and say @NOOP@?
-  , healthWidgetMemcached :: Maybe Bool
-    -- ^ Can we store values in memcached and retrieve them via HTTP?
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , omitNothingFields  = True
-  } ''HealthReport
-
--- | `HealthReport` classified (`classifyHealthReport`) by badness
---
--- > a < b = a `worseThan` b
---
--- Currently all consumers of this type check for @(== HealthSuccess)@; this
--- needs to be adjusted on a case-by-case basis if new constructors are added
-data HealthStatus = HealthFailure | HealthSuccess
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe HealthStatus
-instance Finite HealthStatus
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''HealthStatus
-nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
-
-classifyHealthReport :: HealthReport -> HealthStatus
--- ^ Classify `HealthReport` by badness
-classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
-  unless healthMatchingClusterConfig . tell $ Min HealthFailure
-  unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
-  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
-  unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
-  unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
-
-
 -- Type synonyms
 
 type Email           = Text

src/Model/Types/DateTime.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , UndecidableInstances
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+
+module Model.Types.DateTime where
+
+
+import ClassyPrelude
+import GHC.Generics (Generic)
+import Utils
+import Control.Lens
+import Data.NonNull.Instances ()
+import Data.Typeable (Typeable)
+import Data.Universe.Instances.Reverse ()
+import Data.Binary (Binary)
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
+import Text.Read (readMaybe)
+
+import Database.Persist.Class
+import Database.Persist.Sql
+
+import Web.HttpApiData
+
+import Yesod.Core.Dispatch (PathPiece(..))
+import qualified Data.Aeson as Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+
+
+----
+--  Terms, Seaons, anything loosely related to time
+
+data Season = Summer | Winter
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
+
+instance Binary Season
+
+seasonToChar :: Season -> Char
+seasonToChar Summer = 'S'
+seasonToChar Winter = 'W'
+
+seasonFromChar :: Char -> Either Text Season
+seasonFromChar c
+  | c ~= 'S'  = Right Summer
+  | c ~= 'W'  = Right Winter
+  | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
+  where
+    (~=) = (==) `on` CI.mk
+
+-- instance DisplayAble Season
+
+data TermIdentifier = TermIdentifier
+  { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
+  , season :: Season
+  } deriving (Show, Read, Eq, Ord, Generic, Typeable)
+
+instance Binary TermIdentifier
+
+instance Enum TermIdentifier where
+  -- ^ Do not use for conversion – Enumeration only
+  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
+  fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
+
+-- Conversion TermId <-> TermIdentifier::
+-- from_TermId_to_TermIdentifier = unTermKey
+-- from_TermIdentifier_to_TermId = TermKey
+
+shortened :: Iso' Integer Integer
+shortened = iso shorten expand
+  where
+    century = ($currentYear `div` 100) * 100
+    expand year
+      | 0 <= year
+      , year < 100 = let
+          options = [ expanded | offset <- [-1, 0, 1]
+                               , let century' = century + offset * 100
+                                     expanded = century' + year
+                               , $currentYear - 50 <= expanded
+                               , expanded < $currentYear + 50
+                               ]
+          in case options of
+               [unique] -> unique
+               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
+      | otherwise = year
+    shorten year
+      | $currentYear - 50 <= year
+      , year < $currentYear + 50 = year `mod` 100
+      | otherwise = year
+
+termToText :: TermIdentifier -> Text
+termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
+
+-- also see Hander.Utils.tidFromText
+termFromText :: Text -> Either Text TermIdentifier
+termFromText t
+  | (s:ys) <- Text.unpack t
+  , Just (review shortened -> year) <- readMaybe ys
+  , Right season <- seasonFromChar s
+  = Right TermIdentifier{..}
+  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
+
+termToRational :: TermIdentifier -> Rational
+termToRational TermIdentifier{..} = fromInteger year + seasonOffset
+  where
+    seasonOffset
+      | Summer <- season = 0
+      | Winter <- season = 0.5
+
+termFromRational :: Rational -> TermIdentifier
+termFromRational n = TermIdentifier{..}
+  where
+    year = floor n
+    remainder = n - fromInteger (floor n)
+    season
+      | remainder == 0 = Summer
+      | otherwise      = Winter
+
+instance PersistField TermIdentifier where
+  toPersistValue = PersistRational . termToRational
+  fromPersistValue (PersistRational t) = Right $ termFromRational t
+  fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
+
+instance PersistFieldSql TermIdentifier where
+  sqlType _ = SqlNumeric 5 1
+
+instance ToHttpApiData TermIdentifier where
+  toUrlPiece = termToText
+
+instance FromHttpApiData TermIdentifier where
+  parseUrlPiece = termFromText
+
+instance PathPiece TermIdentifier where
+  fromPathPiece = either (const Nothing) Just . termFromText
+  toPathPiece = termToText
+
+instance ToJSON TermIdentifier where
+  toJSON = Aeson.String . termToText
+
+instance FromJSON TermIdentifier where
+  parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
+
+{- Must be defined in a later module:
+    termField :: Field (HandlerT UniWorX IO) TermIdentifier
+    termField = checkMMap (return . termFromText) termToText textField
+   See Handler.Utils.Form.termsField and termActiveField
+-}
+
+
+withinTerm :: Day -> TermIdentifier -> Bool
+time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
+  where
+    timeYear = fst3 $ toGregorian time
+    termYear = year term
+

src/Model/Types/Misc.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , UndecidableInstances
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+
+module Model.Types.Misc where
+
+
+import ClassyPrelude
+import Utils
+import Control.Lens
+
+import Data.NonNull.Instances ()
+import Data.Set (Set)
+import Data.Maybe (fromJust)
+import Data.Universe
+import Data.Universe.Helpers
+
+import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
+import Data.CaseInsensitive.Instances ()
+
+import Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
+
+import Data.Aeson (Value())
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
+
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+
+import Data.Universe.Instances.Reverse ()
+
+import Data.Time.LocalTime (LocalTime, TimeOfDay)
+import Time.Types (WeekDay(..))
+
+
+-----
+-- Miscellaneous Model.Types
+
+derivePersistFieldJSON ''Value
+
+data StudyFieldType = FieldPrimary | FieldSecondary
+  deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
+derivePersistField "StudyFieldType"
+
+-- instance DisplayAble StudyFieldType
+
+data Theme
+  = ThemeDefault
+  | ThemeLavender
+  | ThemeNeutralBlue
+  | ThemeAberdeenReds
+  | ThemeMossGreen
+  | ThemeSkyLove
+  deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = fromJust . stripPrefix "Theme"
+  } ''Theme
+
+instance Universe Theme where universe = universeDef
+instance Finite Theme
+
+nullaryPathPiece ''Theme (camelToPathPiece' 1)
+
+$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
+
+derivePersistField "Theme"
+
+
+data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = fromJust . stripPrefix "Corrector"
+  } ''CorrectorState
+
+instance Universe CorrectorState
+instance Finite CorrectorState
+
+instance Hashable CorrectorState
+
+nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
+
+derivePersistField "CorrectorState"
+
+
+data LecturerType = CourseLecturer | CourseAssistant
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe LecturerType
+instance Finite LecturerType
+
+nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''LecturerType
+derivePersistFieldJSON ''LecturerType
+
+instance Hashable LecturerType
+
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''WeekDay
+
+data OccurenceSchedule = ScheduleWeekly
+                         { scheduleDayOfWeek :: WeekDay
+                         , scheduleStart     :: TimeOfDay
+                         , scheduleEnd       :: TimeOfDay
+                         }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "repeat" "schedule"
+  } ''OccurenceSchedule
+
+data OccurenceException = ExceptOccur
+                          { exceptDay   :: Day
+                          , exceptStart :: TimeOfDay
+                          , exceptEnd   :: TimeOfDay
+                          }
+                        | ExceptNoOccur
+                          { exceptTime  :: LocalTime
+                          }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "exception" "for"
+  } ''OccurenceException
+
+data Occurences = Occurences
+  { occurencesScheduled  :: Set OccurenceSchedule
+  , occurencesExceptions :: Set OccurenceException
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''Occurences
+derivePersistFieldJSON ''Occurences
+

src/Model/Types/Security.hs

@@ -0,0 +1,411 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , UndecidableInstances
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+
+module Model.Types.Security where
+
+
+import ClassyPrelude
+import Utils
+import Control.Lens hiding (universe)
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Universe
+import Data.UUID.Types (UUID)
+import qualified Data.UUID.Types as UUID
+
+import Data.NonNull.Instances ()
+
+import Data.Default
+
+import Model.Types.JSON
+import Database.Persist.Class
+import Database.Persist.Sql
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
+
+import Yesod.Core.Dispatch (PathPiece(..))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject)
+import Data.Aeson.Types (toJSONKeyText)
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
+
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+
+import Data.Universe.Instances.Reverse ()
+
+import Mail (MailLanguages(..))
+
+import Data.Word.Word24 (Word24)
+import Data.Bits
+import Data.Ix
+import Data.List (genericIndex, elemIndex)
+import System.Random (Random(..))
+import Data.Data (Data)
+
+import Model.Types.Wordlist
+import Data.Text.Metrics (damerauLevenshtein)
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Data.Semigroup (Min(..))
+import Control.Monad.Trans.Writer (execWriter)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+
+----
+-- Security, Authentification, Notification Stuff
+
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
+  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
+
+data AuthenticationMode = AuthLDAP
+                        | AuthPWHash { authPWHash :: Text }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = UntaggedValue
+  } ''AuthenticationMode
+
+derivePersistFieldJSON ''AuthenticationMode
+
+
+
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
+--
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger = NTSubmissionRatedGraded
+                         | NTSubmissionRated
+                         | NTSheetActive
+                         | NTSheetSoonInactive
+                         | NTSheetInactive
+                         | NTCorrectionsAssigned
+                         | NTCorrectionsNotDistributed
+                         | NTUserRightsUpdate
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+    NTSheetActive -> True
+    NTSheetSoonInactive -> False
+    NTSheetInactive -> True
+    NTCorrectionsAssigned -> True
+    NTCorrectionsNotDistributed -> True
+    NTUserRightsUpdate -> True
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
+derivePersistFieldJSON ''NotificationSettings
+
+
+instance ToBackendKey SqlBackend record => Hashable (Key record) where
+  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
+
+derivePersistFieldJSON ''MailLanguages
+
+
+type PseudonymWord   = CI Text
+
+newtype Pseudonym = Pseudonym Word24
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
+
+
+instance PersistField Pseudonym where
+  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
+  fromPersistValue v = do
+    w <- fromPersistValue v :: Either Text Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> Left "Pseudonym out of range"
+
+instance PersistFieldSql Pseudonym where
+  sqlType _ = SqlInt32
+
+instance Random Pseudonym where
+  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
+  random = randomR (minBound, maxBound)
+
+instance FromJSON Pseudonym where
+  parseJSON v@(Aeson.Number _) = do
+    w <- parseJSON v :: Aeson.Parser Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> fail "Pseudonym out auf range"
+  parseJSON (Aeson.String t)
+    = case t ^? _PseudonymText of
+        Just p -> return p
+        Nothing -> fail "Could not parse pseudonym"
+  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
+    ws' <- toList . map CI.mk <$> mapM parseJSON ws
+    case ws' ^? _PseudonymWords of
+      Just p -> return p
+      Nothing -> fail "Could not parse pseudonym words"
+
+instance ToJSON Pseudonym where
+  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
+
+pseudonymWordlist :: [PseudonymWord]
+pseudonymCharacters :: Set (CI Char)
+(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
+
+_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
+_PseudonymWords = prism' pToWords pFromWords
+  where
+    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
+    pFromWords [w1, w2]
+      | Just i1 <- elemIndex w1 pseudonymWordlist
+      , Just i2 <- elemIndex w2 pseudonymWordlist
+      , i1 <= maxWord, i2 <= maxWord
+      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
+    pFromWords _ = Nothing
+
+    pToWords :: Pseudonym -> [PseudonymWord]
+    pToWords (Pseudonym p)
+      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
+        , genericIndex pseudonymWordlist $ p .&. maxWord
+        ]
+
+    maxWord :: Num a => a
+    maxWord = 0b111111111111
+
+_PseudonymText :: Prism' Text Pseudonym
+_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
+  where
+    tFromWords :: Text -> Maybe [PseudonymWord]
+    tFromWords input
+      | [result] <- input ^.. pseudonymFragments
+      = Just result
+      | otherwise
+      = Nothing
+
+    tToWords :: [PseudonymWord] -> Text
+    tToWords = Text.unwords . map CI.original
+
+pseudonymWords :: Fold Text PseudonymWord
+pseudonymWords = folding
+  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
+  where
+    distance = damerauLevenshtein `on` CI.foldedCase
+    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
+    distanceCutoff = 2
+
+pseudonymFragments :: Fold Text [PseudonymWord]
+pseudonymFragments = folding
+  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
+
+
+data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
+  = AuthAdmin
+  | AuthLecturer
+  | AuthCorrector
+  | AuthTutor
+  | AuthCourseRegistered
+  | AuthTutorialRegistered
+  | AuthParticipant
+  | AuthTime
+  | AuthMaterials
+  | AuthOwner
+  | AuthRated
+  | AuthUserSubmissions
+  | AuthCorrectorSubmissions
+  | AuthCapacity
+  | AuthRegisterGroup
+  | AuthEmpty
+  | AuthSelf
+  | AuthAuthentication
+  | AuthNoEscalation
+  | AuthRead
+  | AuthWrite
+  | AuthToken
+  | AuthDeprecated
+  | AuthDevelopment
+  | AuthFree
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe AuthTag
+instance Finite AuthTag
+instance Hashable AuthTag
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''AuthTag
+
+nullaryPathPiece ''AuthTag (camelToPathPiece' 1)
+
+instance ToJSONKey AuthTag where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey AuthTag where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+instance Binary AuthTag
+
+
+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
+
+
+data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable a => Hashable (PredLiteral a)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "val" "var"
+  } ''PredLiteral
+
+instance PathPiece a => PathPiece (PredLiteral a) where
+  toPathPiece PLVariable{..} = toPathPiece plVar
+  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
+
+  fromPathPiece t = PLVariable <$> fromPathPiece t
+                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
+
+instance Binary a => Binary (PredLiteral a)
+
+
+newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+$(return [])
+
+instance ToJSON a => ToJSON (PredDNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
+instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
+
+instance (Ord a, Binary a) => Binary (PredDNF a) where
+  get = PredDNF <$> Binary.get
+  put = Binary.put . dnfTerms
+
+type AuthLiteral = PredLiteral AuthTag
+
+type AuthDNF = PredDNF AuthTag
+
+
+data HealthReport = HealthReport
+  { healthMatchingClusterConfig :: Bool
+    -- ^ Is the database-stored configuration we're running under still up to date?
+  , healthHTTPReachable :: Maybe Bool
+    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
+    --
+    -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
+  , healthLDAPAdmins :: Maybe Rational
+    -- ^ Proportion of school admins that could be found in LDAP
+    --
+    -- Is `Nothing` if LDAP is not configured or no users are school admins
+  , healthSMTPConnect :: Maybe Bool
+    -- ^ Can we connect to the SMTP server and say @NOOP@?
+  , healthWidgetMemcached :: Maybe Bool
+    -- ^ Can we store values in memcached and retrieve them via HTTP?
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields  = True
+  } ''HealthReport
+
+-- | `HealthReport` classified (`classifyHealthReport`) by badness
+--
+-- > a < b = a `worseThan` b
+--
+-- Currently all consumers of this type check for @(== HealthSuccess)@; this
+-- needs to be adjusted on a case-by-case basis if new constructors are added
+data HealthStatus = HealthFailure | HealthSuccess
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe HealthStatus
+instance Finite HealthStatus
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''HealthStatus
+nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
+
+classifyHealthReport :: HealthReport -> HealthStatus
+-- ^ Classify `HealthReport` by badness
+classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
+  unless healthMatchingClusterConfig . tell $ Min HealthFailure
+  unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
+  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
+  unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
+  unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
+

src/Model/Types/Sheet.hs

@@ -0,0 +1,340 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , UndecidableInstances
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+
+module Model.Types.Sheet where
+
+import ClassyPrelude
+import Utils
+import Numeric.Natural
+
+import Control.Lens
+import Utils.Lens.TH
+import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+import Data.Typeable (Typeable)
+import Data.Universe
+import Data.Universe.Helpers
+import Data.Universe.Instances.Reverse ()
+
+import Data.NonNull.Instances ()
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Fixed
+import Data.Monoid (Sum(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
+
+import Data.CaseInsensitive.Instances ()
+import Text.Blaze (Markup)
+
+import Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
+import Yesod.Core.Dispatch (PathPiece(..))
+
+import Network.Mime
+
+
+
+----
+-- Sheet and Submission realted Model.Types
+
+type Count  = Sum Integer
+type Points = Centi
+
+toPoints :: Integral a => a -> Points -- deprecated
+toPoints = fromIntegral
+
+pToI :: Points -> Integer -- deprecated
+pToI = fromPoints
+
+fromPoints :: Integral a => Points -> a -- deprecated
+fromPoints = round
+
+instance DisplayAble Points
+
+instance DisplayAble a => DisplayAble (Sum a) where
+   display (Sum x) = display x
+
+data SheetGrading
+  = Points     { maxPoints :: Points }
+  | PassPoints { maxPoints, passingPoints :: Points }
+  | PassBinary -- non-zero means passed
+  deriving (Eq, Read, Show, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel
+  , sumEncoding = TaggedObject "type" "data"
+  } ''SheetGrading
+derivePersistFieldJSON ''SheetGrading
+
+makeLenses_ ''SheetGrading
+
+_passingBound :: Fold SheetGrading (Either () Points)
+_passingBound = folding passPts
+  where
+    passPts :: SheetGrading -> Maybe (Either () Points)
+    passPts Points{}                  = Nothing
+    passPts PassPoints{passingPoints} = Just $ Right passingPoints
+    passPts PassBinary                = Just $ Left ()
+
+gradingPassed :: SheetGrading -> Points -> Maybe Bool
+gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
+    where pBinary _ = pts /= 0
+          pPoints b = pts >= b
+
+
+data SheetGradeSummary = SheetGradeSummary
+  { numSheets       :: Count       -- Total number of sheets, includes all
+  , numSheetsPasses :: Count       -- Number of sheets required to pass FKA: numGradePasses
+  , numSheetsPoints :: Count       -- Number of sheets having points    FKA: sumGradePointsd
+  , sumSheetsPoints :: Sum Points  -- Total of all points in all sheets
+  -- Marking dependend
+  , numMarked       :: Count       -- Number of already marked sheets
+  , numMarkedPasses :: Count       -- Number of already marked sheets with passes
+  , numMarkedPoints :: Count       -- Number of already marked sheets with points
+  , sumMarkedPoints :: Sum Points  -- Achieveable points within marked sheets
+  --
+  , achievedPasses :: Count        -- Achieved passes (within marked sheets)
+  , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
+  } deriving (Generic, Read, Show, Eq)
+
+instance Monoid SheetGradeSummary where
+  mempty  = memptydefault
+  mappend = mappenddefault
+
+instance Semigroup SheetGradeSummary where
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
+
+makeLenses_ ''SheetGradeSummary
+
+sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
+sheetGradeSum gr Nothing  = mempty
+  { numSheets = 1
+  , numSheetsPasses = bool  mempty   1 $ has _passingBound gr
+  , numSheetsPoints = bool  mempty   1 $ has _maxPoints    gr
+  , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
+  }
+sheetGradeSum gr (Just p) =
+  let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
+  in  unmarked
+        { numMarked       = numSheets
+        , numMarkedPasses = numSheetsPasses
+        , numMarkedPoints = numSheetsPoints
+        , sumMarkedPoints = sumSheetsPoints
+        , achievedPasses  = maybe mempty (bool 0 1) (gradingPassed gr p)
+        , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
+        }
+
+
+data SheetType
+  = NotGraded
+  | Normal        { grading :: SheetGrading }
+  | Bonus         { grading :: SheetGrading }
+  | Informational { grading :: SheetGrading }
+  deriving (Eq, Read, Show, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  , fieldLabelModifier = camelToPathPiece
+  , sumEncoding = TaggedObject "type" "data"
+  } ''SheetType
+derivePersistFieldJSON ''SheetType
+
+data SheetTypeSummary = SheetTypeSummary
+  { normalSummary
+  , bonusSummary
+  , informationalSummary :: SheetGradeSummary
+  , numNotGraded :: Count
+  } deriving (Generic, Read, Show, Eq)
+
+instance Monoid SheetTypeSummary where
+  mempty  = memptydefault
+  mappend = mappenddefault
+
+instance Semigroup SheetTypeSummary where
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
+
+makeLenses_ ''SheetTypeSummary
+
+sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
+sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }
+
+data SheetGroup
+  = Arbitrary { maxParticipants :: Natural }
+  | RegisteredGroups
+  | NoGroups
+  deriving (Show, Read, Eq, Generic)
+deriveJSON defaultOptions ''SheetGroup
+derivePersistFieldJSON ''SheetGroup
+
+makeLenses_ ''SheetGroup
+
+data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+derivePersistField "SheetFileType"
+
+instance Universe SheetFileType where universe = universeDef
+instance Finite SheetFileType
+
+instance PathPiece SheetFileType where
+  toPathPiece SheetExercise = "file"
+  toPathPiece SheetHint     = "hint"
+  toPathPiece SheetSolution = "solution"
+  toPathPiece SheetMarking  = "marking"
+  fromPathPiece = finiteFromPathPiece
+
+sheetFile2markup :: SheetFileType -> Markup
+sheetFile2markup SheetExercise = iconQuestion
+sheetFile2markup SheetHint     = iconHint
+sheetFile2markup SheetSolution = iconSolution
+sheetFile2markup SheetMarking  = iconMarking
+
+-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
+-- instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
+--   display SheetExercise = "Aufgabenstellung"
+--   display SheetHint     = "Hinweise"
+--   display SheetSolution = "Musterlösung"
+--   display SheetMarking  = "Korrekturhinweise"
+
+-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
+-- partitionFileType' = groupMap
+
+partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
+partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
+
+data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+
+instance Universe SubmissionFileType
+instance Finite SubmissionFileType
+
+nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
+
+submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
+submissionFileTypeIsUpdate SubmissionOriginal  = False
+submissionFileTypeIsUpdate SubmissionCorrected = True
+
+isUpdateSubmissionFileType :: Bool -> SubmissionFileType
+isUpdateSubmissionFileType False = SubmissionOriginal
+isUpdateSubmissionFileType True  = SubmissionCorrected
+
+
+data UploadSpecificFile = UploadSpecificFile
+  { specificFileLabel :: Text
+  , specificFileName :: FileName
+  , specificFileRequired :: Bool
+  } deriving (Show, Read, Eq, Ord, Generic)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''UploadSpecificFile
+derivePersistFieldJSON ''UploadSpecificFile
+
+data UploadMode = NoUpload
+                | UploadAny
+                  { unpackZips :: Bool
+                  , extensionRestriction :: Maybe (NonNull (Set Extension))
+                  }
+                | UploadSpecific
+                  { specificFiles :: NonNull (Set UploadSpecificFile)
+                  }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
+defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  , fieldLabelModifier = camelToPathPiece
+  , sumEncoding = TaggedObject "mode" "settings"
+  , omitNothingFields = True
+  }''UploadMode
+derivePersistFieldJSON ''UploadMode
+
+data UploadModeDescr = UploadModeNone
+                     | UploadModeAny
+                     | UploadModeSpecific
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe UploadModeDescr
+instance Finite UploadModeDescr
+
+nullaryPathPiece ''UploadModeDescr $ camelToPathPiece' 2
+
+classifyUploadMode :: UploadMode -> UploadModeDescr
+classifyUploadMode NoUpload = UploadModeNone
+classifyUploadMode UploadAny{} = UploadModeAny
+classifyUploadMode UploadSpecific{} = UploadModeSpecific
+
+data SubmissionMode = SubmissionMode
+  { submissionModeCorrector :: Bool
+  , submissionModeUser :: Maybe UploadMode
+  }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''SubmissionMode
+derivePersistFieldJSON ''SubmissionMode
+
+data SubmissionModeDescr = SubmissionModeNone
+                         | SubmissionModeCorrector
+                         | SubmissionModeUser
+                         | SubmissionModeBoth
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe SubmissionModeDescr
+instance Finite SubmissionModeDescr
+
+finitePathPiece ''SubmissionModeDescr
+  [ "no-submissions"
+  , "correctors"
+  , "users"
+  , "correctors+users"
+  ]
+
+classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
+classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
+classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
+classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
+classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
+
+
+data ExamStatus = Attended | NoShow | Voided
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+derivePersistField "ExamStatus"
+
+-- | Specify a corrector's workload
+data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
+    = Load { byTutorial :: Maybe Bool  -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
+           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
+           }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveJSON defaultOptions ''Load
+derivePersistFieldJSON ''Load
+
+instance Hashable Load
+
+instance Semigroup Load where
+  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
+    where
+      byTut''
+        | Nothing <- byTut  = byTut'
+        | Nothing <- byTut' = byTut
+        | Just a <- byTut
+        , Just b <- byTut'  = Just $ a || b
+
+instance Monoid Load where
+  mempty = Load Nothing 0
+  mappend = (<>)
+
+{- Use (is _ByTutorial) instead of this unneeded definition:
+  isByTutorial :: Load -> Bool
+  isByTutorial (ByTutorial {}) = True
+  isByTutorial _               = False
+-}

src/Network/Mime/TH.hs

@@ -1,11 +1,12 @@
 module Network.Mime.TH
-  ( mimeMapFile
+  ( mimeMapFile, mimeSetFile
   ) where
 
 import ClassyPrelude.Yesod hiding (lift)
 import Language.Haskell.TH hiding (Extension)
 import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
 
+import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Data.Text (Text)
@@ -18,7 +19,7 @@ import Network.Mime
 import Instances.TH.Lift ()
 
 
-mimeMapFile :: FilePath -> ExpQ
+mimeMapFile, mimeSetFile :: FilePath -> ExpQ
 mimeMapFile file = do
   qAddDependentFile file
   
@@ -36,6 +37,15 @@ mimeMapFile file = do
 
 
   lift mimeMap
+mimeSetFile file = do
+  qAddDependentFile file
+  
+  ls <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+
+  let mimeSet :: Set MimeType
+      mimeSet = Set.fromList $ map (encodeUtf8 . Text.strip) ls
+
+  lift mimeSet
 
 isComment :: Text -> Bool
 isComment line = or

src/Settings.hs

@@ -73,6 +73,9 @@ import Handler.Utils.Submission.TH
 import Network.Mime
 import Network.Mime.TH
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -431,8 +434,17 @@ widgetFileSettings = def
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
 
+mimeMap :: MimeMap
+mimeMap = $(mimeMapFile "config/mimetypes")
+
 mimeLookup :: FileName -> MimeType
-mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType
+mimeLookup = mimeByExt mimeMap defaultMimeType
+
+mimeExtensions :: MimeType -> Set Extension
+mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
+
+archiveTypes :: Set MimeType
+archiveTypes = $(mimeSetFile "config/archive-types")
 
 -- The rest of this file contains settings which rarely need changing by a
 -- user.

src/Utils.hs

@@ -30,7 +30,7 @@ import Utils.Parameters as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
-import Data.Char (isDigit, isSpace)
+import Data.Char (isDigit, isSpace, isAscii)
 import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
 import Numeric (showFFloat)
 
@@ -249,8 +249,8 @@ class DisplayAble a where
 instance DisplayAble Text where
   display = id
 
-instance DisplayAble String where
+-- instance DisplayAble String where
-  display = pack
+--   display = pack
 
 instance DisplayAble Int
 instance DisplayAble Int64
@@ -718,6 +718,16 @@ mconcatForM = flip mconcatMapM
 findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
 findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
 
+-------------
+-- Conduit --
+-------------
+
+peekN :: (Integral n, Monad m) => n -> Consumer a m [a]
+peekN n = do
+  peeked <- catMaybes <$> replicateM (fromIntegral n) await
+  mapM_ leftover peeked
+  return peeked
+
 -----------------
 -- Alternative --
 -----------------
@@ -781,6 +791,33 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload)
 addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
 replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)
 
+------------------
+-- HTTP Headers --
+------------------
+
+data ContentDisposition = ContentInline | ContentAttachment
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ContentDisposition
+instance Finite ContentDisposition
+nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1
+
+setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m ()
+-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader`
+--
+-- Takes care of correct formatting and encoding of non-ascii filenames
+setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal
+  where
+    headerVal
+      | Just fName <- mFName
+      , Text.all isAscii fName
+      , Text.all (not . flip elem ['"', '\\']) fName
+      = [st|#{toPathPiece cd}; filename="#{fName}"|]
+      | Just fName <- mFName
+      = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName
+         in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|]
+      | otherwise
+      = toPathPiece cd
+
 ------------------
 -- Cryptography --
 ------------------

src/Utils/Form.hs

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.RWS (mapRWST)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
 
 import Data.List ((!!))
 
@@ -445,6 +446,29 @@ optionsFinite = do
 rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
 rationalField = convertField toRational fromRational doubleField
 
+data SecretJSONFieldException = SecretJSONFieldDecryptFailure
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Exception SecretJSONFieldException
+
+secretJsonField :: ( ToJSON a, FromJSON a
+                   , MonadHandler m
+                   , MonadSecretBox (ExceptT EncodedSecretBoxException m)
+                   , MonadSecretBox (WidgetT (HandlerSite m) IO)
+                   , RenderMessage (HandlerSite m) FormMessage
+                   , RenderMessage (HandlerSite m) SecretJSONFieldException
+                   )
+                => Field m a
+secretJsonField = Field{..}
+  where
+    fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val _isReq = do
+      val' <- traverse (encodedSecretBox SecretBoxShort) val
+      [whamlet|
+        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
+      |]
+    fieldEnctype = UrlEncoded
 
 -----------
 -- Forms --
@@ -522,6 +546,9 @@ idFormSectionNoinput = "form-section-noinput"
 aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
 aformSection = formToAForm . fmap (second pure) . formSection
 
+wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
+wformSection = void . aFormToWForm . aformSection
+
 formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
 formSection formSectionTitle = do
     mr <- getMessageRender

src/Utils/Lens.hs

@@ -103,6 +103,8 @@ makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse
 
+makeLenses_ ''UploadMode
+
 makeLenses_ ''SubmissionMode
 
 makePrisms ''E.Value

src/Utils/Sheet.hs

@@ -47,8 +47,8 @@ sheetOldUnassigned tid ssh csh = do
     _ -> error "SQL Query with limit 1 returned more than one result"
 
 -- | Return a specfic file from  a `Sheet`
-sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File]
+sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File)
-sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
+sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $
   \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
   -- Restrict to consistent rows that correspond to each other
   E.on (file  E.^. FileId         E.==. sFile  E.^. SheetFileFile)
@@ -66,8 +66,8 @@ sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
   return file
 
 -- | Return all files of a certain `SheetFileType` for a `Sheet`
-sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File]
+sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File)
-sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $
+sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
   \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
   -- Restrict to consistent rows that correspond to each other
   E.on (file  E.^. FileId         E.==. sFile  E.^. SheetFileFile)
@@ -89,4 +89,4 @@ hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backen
 hasSheetFileQuery sheet sft =
   E.exists $ E.from $ \sFile ->
     E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
-      E.&&.   (sFile E.^. SheetFileType  E.==. E.val sft  ))
+      E.&&.   (sFile E.^. SheetFileType  E.==. E.val sft  ))

stack.yaml

@@ -51,4 +51,6 @@ extra-deps:
 
   - systemd-1.2.0
 
+  - filepath-1.4.2
+
 resolver: lts-10.5

templates/messages/submissionFilesIgnored.hamlet

@@ -1,4 +1,4 @@
-_{MsgSubmissionFilesIgnored}
+<h2>_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
 <ul>
   $forall ident <- ignoredFiles
     $case ident

templates/widgets/massinput/uploadSpecificFiles/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/uploadSpecificFiles/form.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<td>#{csrf}^{fvInput labelView}
+<td>^{fvInput nameView}
+<td>^{fvInput reqView}

templates/widgets/massinput/uploadSpecificFiles/layout.hamlet

@@ -0,0 +1,16 @@
+$newline never
+<table>
+  <thead>
+    <th>_{MsgUploadSpecificFileLabel}
+    <th>_{MsgUploadSpecificFileName}
+    <th>_{MsgUploadSpecificFileRequired}
+    <th>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/specificFileField.hamlet

@@ -0,0 +1,8 @@
+$newline never
+<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
+$if acceptRestricted
+  <br>
+  _{MsgUploadModeExtensionRestriction}: 
+  <ul .list--inline .list--comma-separated .list--iconless>
+    $forall ext <- extensions
+      <li style="font-family: monospace">#{ext}

templates/widgets/zipFileField.hamlet

@@ -1,2 +1,8 @@
 $newline never
-<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required>
+<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
+$maybe exts <- fmap toNullable permittedExtensions
+  <br>
+  _{MsgUploadModeExtensionRestriction}: 
+  <ul .list--inline .list--comma-separated .list--iconless>
+    $forall ext <- zipExtensions <> exts
+      <li style="font-family: monospace">#{ext}

test/Database.hs

@@ -393,11 +393,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp CourseLecturer
   void . insert $ Lecturer gkleen ffp CourseAssistant
-  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now adhoc
-  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now feste
-  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
   void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
     [(fhamann   , Nothing)
@@ -484,7 +484,7 @@ fillDb = do
     ]
   sh1 <- insert Sheet
     { sheetCourse = pmo
-    , sheetName = "Blatt 1"
+    , sheetName = "Papierabgabe"
     , sheetDescription = Nothing
     , sheetType = Normal $ Points 6
     , sheetGrouping = Arbitrary 3
@@ -516,6 +516,60 @@ fillDb = do
   void . insert $ SubmissionUser maxMuster sub1
   sub1fid1 <- insertFile "AbgabeH10-1.hs"
   void . insert $ SubmissionFile sub1 sub1fid1 False False
+  sh2 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Spezifische Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False $ Just UploadSpecific
+      { specificFiles = impureNonNull $ Set.fromList
+        [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False
+        , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False
+        , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True
+        ]
+      }
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh2
+  sh3 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Dateiendung-eingeschränkte Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh3
+  sh4 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Uneingeschränkte Abgabe, einzelne Datei"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh4
   tut1 <- insert Tutorial
     { tutorialName = "Di08"
     , tutorialCourse = pmo