diff --git a/config/archive-types b/config/archive-types new file mode 100644 index 000000000..0599971bb --- /dev/null +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 05b9b6579..70f005dfc 100644 --- a/messages/uniworx/de.msg +++ b/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 -UploadModeNoUnpack: Upload, ZIP-Archive entpacken +UploadModeAny: Upload, beliebige Datei(en) +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 diff --git a/package.yaml b/package.yaml index d0fc06ae8..098fb0bec 100644 --- a/package.yaml +++ b/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) diff --git a/routes b/routes index 45fa74da5..b1a1214bc 100644 --- a/routes +++ b/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 - /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector - /delete SubDelR GET POST !ownerANDtime + / SubShowR GET POST !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread + /delete SubDelR GET POST !ownerANDtimeANDuser-submissions /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 - /zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download/*FilePath MFileR 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: diff --git a/src/Foundation.hs b/src/Foundation.hs index 9f9d34652..a30aeddc8 100644 --- a/src/Foundation.hs +++ b/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 (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom - SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom - SZipR _ -> mzero + SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime + SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom + SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom + 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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 7a7cc36f8..6f13dba0c 100644 --- a/src/Handler/Admin.hs +++ b/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
- #{encodePrettyToTextBuilder t}
+ $case t
+ $of String t'
+ #{t'}
+ $of t'
+ #{encodePrettyToTextBuilder t'}
^{ctView'}
|]
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index d32195c58..78b5d187a 100644
--- a/src/Handler/Corrections.hs
+++ b/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, _, _) } ->
- -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
- textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
+ $ \DBRow{ dbrOutput } ->
+ textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _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)
- $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
- let tid = course ^. _3
+colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
+ let sheet = row ^. _dbrOutput . _2
+ 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)
- $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
+colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
+ 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 = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
+ DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty
+ 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 _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
+ (\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))
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 _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
+ (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
+ (\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 _ 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 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))
+
+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)
- dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
+ unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
+ 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
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index a274dbd92..5abd1e624 100644
--- a/src/Handler/Course.hs
+++ b/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
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 7ae50af56..119fa5027 100644
--- a/src/Handler/Material.hs
+++ b/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
- return material
+ E.where_ $ material E.^. MaterialCourse E.==. E.val cid
+ 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!
- $ fileCell . filesLink . materialName . row2material
+ , sortable (toNothingS "zip-archive") mempty
+ $ \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.
-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.
+-- | Serve all material-files
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)
- getMatQuery = E.select . E.from $
+ archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip"
+ 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
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 754d27a95..f315c7709 100644
--- a/src/Handler/Sheet.hs
+++ b/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")
- (sfDescription <$> template)
- <*> sheetTypeAFormReq (fslI MsgSheetType
- & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
- (sfType <$> template)
- <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
+ <* aformSection MsgSheetFormTimes
<*> 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)
- (sfSolutionFrom <$> template)
+ & setTooltip MsgSheetSolutionFromTip) (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
- & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
+ <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
+ & 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
- let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
- shn <- sheetCurrent tid ssh csh
- maybe notFound redi shn
+getSheetCurrentR tid ssh csh = do
+ mbShn <- runDB $ sheetCurrent tid ssh csh
+ case mbShn of
+ 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
- let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
- shn <- sheetOldUnassigned tid ssh csh
- maybe notFound redi shn
+
+getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getSheetOldUnassignedR tid ssh csh = do
+ mbShn <- runDB $ sheetOldUnassigned tid ssh csh
+ 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 tid ssh csh shn filename@(ZIPArchiveName sft)
- = serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
+getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
+getSZipR 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
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 3e31fb658..12c605917 100644
--- a/src/Handler/Submission.hs
+++ b/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)
- -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+ UploadAny{..}
+ -> (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))
- urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
+ let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected
+ 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
- submissionID <- submissionMatchesSheet tid ssh csh shn cID
+getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
+ (submissionID, isRating) <- runDB $ do
+ submissionID <- submissionMatchesSheet tid ssh csh shn cID
- isRating <- (== Just submissionID) <$> isRatingFile path
+ isRating <- (== Just submissionID) <$> isRatingFile path
- when (isUpdate || isRating) $
- guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
+ when (isUpdate || isRating) $
+ 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
- E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
- E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
- E.&&. f E.^. FileTitle E.==. E.val path
- E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
- E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
- -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
- return f
+ let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+ E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+ E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+ E.&&. f E.^. FileTitle E.==. E.val path
+ E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
+ E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+ -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
+ return f
- case results of
- [] -> 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."
+ serveOneFile results
-getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
-getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
+getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
+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
- | otherwise = ZIPArchiveName $ toPathPiece cID
+ | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType
+ | otherwise = toPathPiece cID
- addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
- respondSourceDB "application/zip" $ do
- submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
- rating <- lift $ getRating submissionID
+ source = do
+ submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
+ rating <- lift $ getRating submissionID
- let
- fileSelect = case sfType of
- SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
- E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
- E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
- E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
- return f
- _ -> submissionFileSource submissionID
+ case sfType of
+ SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+ E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
+ E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+ E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
+ return f
+ _ -> submissionFileSource submissionID .| Conduit.map entityVal
- fileSource' = do
- fileSelect .| Conduit.map entityVal
when (sfType == SubmissionCorrected) $
maybe (return ()) (yieldM . ratingFile cID) rating
- zipComment = Text.encodeUtf8 $ toPathPiece cID
-
- fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+ serveSomeFiles (unpack filename <.> "zip") source
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
\ No newline at end of file
+ submissionMultiArchive $ Set.fromList subs
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index 08e960581..c25ec43bb 100644
--- a/src/Handler/Term.hs
+++ b/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
diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs
index 534c7d1c1..2a98110c1 100644
--- a/src/Handler/Tutorial.hs
+++ b/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
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index ed2334d5c..e1aea383f 100644
--- a/src/Handler/Utils.hs
+++ b/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 query = do
- results <- runDB query
+serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
+serveOneFile source = do
+ 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}]
- | Just fileContent' <- fileContent -> do
- whenM downloadFiles $
- addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
- return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
- | otherwise -> sendResponseStatus noContent204 ()
- [] -> notFound
- other -> do
+ [file] -> sendThisFile file
+ [] -> 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 archiveName query = do
- results <- runDB query
+serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
+serveSomeFiles archiveName source = do
+ results <- runDB . runConduit $ source .| peekN 2
+
+ $logDebugS "serveSomeFiles" . tshow $ length results
+
case results of
- [] -> notFound
- [Entity _fileId File{fileTitle, fileContent}]
- | Just fileContent' <- fileContent -> do
- whenM downloadFiles $
- 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}"|]
+ [] -> notFound
+ [file] -> sendThisFile file
+ _moreFiles -> do
+ setContentDisposition' $ Just archiveName
respondSourceDB "application/zip" $ do
- let zipComment = T.encodeUtf8 archiveName
- yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+ let zipComment = T.encodeUtf8 $ pack archiveName
+ source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
tidFromText :: Text -> Maybe TermId
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index 843160372..042e90a52 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/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
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 92fbccf72..a9dbe1ede 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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
-uploadModeField = selectField optionsFinite
+uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
+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?
- -> Field Handler (Source Handler File)
-zipFileField doUnpack = Field{..}
+specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
+specificFileField UploadSpecificFile{..} = 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|
-
- |]
- fieldEnctype = UrlEncoded
-
boolField :: ( MonadHandler m
, HandlerSite m ~ UniWorX
)
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index cd5e4f5ac..e9121be5f 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/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
diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurences.hs
index f39ec3323..da0e7733f 100644
--- a/src/Handler/Utils/Form/Occurences.hs
+++ b/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
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index ef297bff4..09c59f6b3 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/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
- addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+ let ignoredModal = msgModal
+ [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
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 7006bd5e5..975ae3925 100644
--- a/src/Import/NoFoundation.hs
+++ b/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)
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index f55638835..9c8b1578b 100644
--- a/src/Model/Migration.hs
+++ b/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 False ) -> SubmissionMode False (Just $ Upload False)
+ ( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
+ ( 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|]
diff --git a/src/Model/Submission.hs b/src/Model/Submission.hs
index 0f931911b..24ef1bad6 100644
--- a/src/Model/Submission.hs
+++ b/src/Model/Submission.hs
@@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
| DuplicateRating
| RatingWithoutUpdate
| ForeignRating CryptoFileNameSubmission
+ | InvalidFileTitleExtension FilePath
deriving (Typeable, Show)
instance Exception SubmissionSinkException
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index aa1c91037..b1692283c 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -1,10 +1,14 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
- , UndecidableInstances
- #-}
+{-# LANGUAGE 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 Data.Text.Metrics (damerauLevenshtein)
-
-import Data.Binary (Binary)
-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(..))
+import Model.Types.Sheet
+import Model.Types.DateTime
+import Model.Types.Security
+import Model.Types.Misc
+----
+-- 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
diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs
new file mode 100644
index 000000000..cb7b2999d
--- /dev/null
+++ b/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
+
diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs
new file mode 100644
index 000000000..aa3811f9d
--- /dev/null
+++ b/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
+
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
new file mode 100644
index 000000000..27be35f81
--- /dev/null
+++ b/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
+
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
new file mode 100644
index 000000000..6ec4ae4f0
--- /dev/null
+++ b/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
+-}
diff --git a/src/Network/Mime/TH.hs b/src/Network/Mime/TH.hs
index 0fd1c2beb..486eda779 100644
--- a/src/Network/Mime/TH.hs
+++ b/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
diff --git a/src/Settings.hs b/src/Settings.hs
index 739ac5554..a60b4597b 100644
--- a/src/Settings.hs
+++ b/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.
diff --git a/src/Utils.hs b/src/Utils.hs
index 1fb39b1b6..4f9d28a25 100644
--- a/src/Utils.hs
+++ b/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
- display = pack
+-- instance DisplayAble String where
+-- 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 --
------------------
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index ad62f224f..c2797980d 100644
--- a/src/Utils/Form.hs
+++ b/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|
+
+ |]
+ 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
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index d52b852c8..51aa57fd0 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -103,6 +103,8 @@ makePrisms ''HandlerContents
makePrisms ''ErrorResponse
+makeLenses_ ''UploadMode
+
makeLenses_ ''SubmissionMode
makePrisms ''E.Value
diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs
index d2f0cf11e..0fa7da74f 100644
--- a/src/Utils/Sheet.hs
+++ b/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 tid ssh csh shn sft title = E.select $ E.from $
+sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File)
+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 tid ssh csh shn sft = E.select $ E.from $
+sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File)
+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 ))
\ No newline at end of file
+ E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
diff --git a/stack.yaml b/stack.yaml
index 7fadc6e4e..02b25ee57 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -51,4 +51,6 @@ extra-deps:
- systemd-1.2.0
+ - filepath-1.4.2
+
resolver: lts-10.5
diff --git a/templates/messages/submissionFilesIgnored.hamlet b/templates/messages/submissionFilesIgnored.hamlet
index ebb61695e..628125d9f 100644
--- a/templates/messages/submissionFilesIgnored.hamlet
+++ b/templates/messages/submissionFilesIgnored.hamlet
@@ -1,4 +1,4 @@
-_{MsgSubmissionFilesIgnored}
+_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
$forall ident <- ignoredFiles
$case ident
diff --git a/templates/widgets/massinput/uploadSpecificFiles/add.hamlet b/templates/widgets/massinput/uploadSpecificFiles/add.hamlet
new file mode 100644
index 000000000..6ef4903fb
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/add.hamlet
@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+
+ ^{fvInput submitView}
diff --git a/templates/widgets/massinput/uploadSpecificFiles/form.hamlet b/templates/widgets/massinput/uploadSpecificFiles/form.hamlet
new file mode 100644
index 000000000..46e856c46
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/form.hamlet
@@ -0,0 +1,4 @@
+$newline never
+ #{csrf}^{fvInput labelView}
+ ^{fvInput nameView}
+ ^{fvInput reqView}
diff --git a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet
new file mode 100644
index 000000000..2179c82b1
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet
@@ -0,0 +1,16 @@
+$newline never
+
+
+ _{MsgUploadSpecificFileLabel}
+ _{MsgUploadSpecificFileName}
+ _{MsgUploadSpecificFileRequired}
+
+
+ $forall coord <- review liveCoords lLength
+
+ ^{cellWdgts ! coord}
+
+ ^{fvInput (delButtons ! coord)}
+
+
+ ^{addWdgts ! (0, 0)}
diff --git a/templates/widgets/specificFileField.hamlet b/templates/widgets/specificFileField.hamlet
new file mode 100644
index 000000000..2f77bae30
--- /dev/null
+++ b/templates/widgets/specificFileField.hamlet
@@ -0,0 +1,8 @@
+$newline never
+
+$if acceptRestricted
+
+ _{MsgUploadModeExtensionRestriction}:
+
+ $forall ext <- extensions
+ - #{ext}
diff --git a/templates/widgets/zipFileField.hamlet b/templates/widgets/zipFileField.hamlet
index 4c432c524..1e39effa6 100644
--- a/templates/widgets/zipFileField.hamlet
+++ b/templates/widgets/zipFileField.hamlet
@@ -1,2 +1,8 @@
$newline never
-
+
+$maybe exts <- fmap toNullable permittedExtensions
+
+ _{MsgUploadModeExtensionRestriction}:
+
+ $forall ext <- zipExtensions <> exts
+ - #{ext}
diff --git a/test/Database.hs b/test/Database.hs
index 5f9140cb0..6332584b4 100755
--- a/test/Database.hs
+++ b/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