Merge branch 'master' into http-client-html-helpers
This commit is contained in:
Felix Hamann
commit
39da7d40ec
40
config/archive-types
Normal file
40
config/archive-types
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
17
routes
17
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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.Admin where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Jobs
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
|
||||
@ -261,7 +260,11 @@ postAdminErrMsgR = do
|
||||
[whamlet|
|
||||
$maybe t <- plaintext
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
#{encodePrettyToTextBuilder t}
|
||||
$case t
|
||||
$of String t'
|
||||
#{t'}
|
||||
$of t'
|
||||
#{encodePrettyToTextBuilder t'}
|
||||
|
||||
^{ctView'}
|
||||
|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
submissionMultiArchive $ Set.fromList subs
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -9,7 +9,6 @@ module Handler.Utils.Communication
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Utils.Lens
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
@ -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|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
|
||||
| DuplicateRating
|
||||
| RatingWithoutUpdate
|
||||
| ForeignRating CryptoFileNameSubmission
|
||||
| InvalidFileTitleExtension FilePath
|
||||
deriving (Typeable, Show)
|
||||
|
||||
instance Exception SubmissionSinkException
|
||||
|
||||
@ -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
|
||||
|
||||
158
src/Model/Types/DateTime.hs
Normal file
158
src/Model/Types/DateTime.hs
Normal file
@ -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
|
||||
|
||||
147
src/Model/Types/Misc.hs
Normal file
147
src/Model/Types/Misc.hs
Normal file
@ -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
|
||||
|
||||
411
src/Model/Types/Security.hs
Normal file
411
src/Model/Types/Security.hs
Normal file
@ -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
|
||||
|
||||
340
src/Model/Types/Sheet.hs
Normal file
340
src/Model/Types/Sheet.hs
Normal file
@ -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
|
||||
-}
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
43
src/Utils.hs
43
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 --
|
||||
------------------
|
||||
|
||||
@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Trans.RWS (mapRWST)
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
@ -445,6 +446,29 @@ optionsFinite = do
|
||||
rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
|
||||
rationalField = convertField toRational fromRational doubleField
|
||||
|
||||
data SecretJSONFieldException = SecretJSONFieldDecryptFailure
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Exception SecretJSONFieldException
|
||||
|
||||
secretJsonField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, MonadSecretBox (ExceptT EncodedSecretBoxException m)
|
||||
, MonadSecretBox (WidgetT (HandlerSite m) IO)
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) SecretJSONFieldException
|
||||
)
|
||||
=> Field m a
|
||||
secretJsonField = Field{..}
|
||||
where
|
||||
fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
||||
fieldParse [] [] = return $ Right Nothing
|
||||
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||
fieldView theId name attrs val _isReq = do
|
||||
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
||||
[whamlet|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
@ -522,6 +546,9 @@ idFormSectionNoinput = "form-section-noinput"
|
||||
aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
|
||||
aformSection = formToAForm . fmap (second pure) . formSection
|
||||
|
||||
wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
|
||||
wformSection = void . aFormToWForm . aformSection
|
||||
|
||||
formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
|
||||
formSection formSectionTitle = do
|
||||
mr <- getMessageRender
|
||||
|
||||
@ -103,6 +103,8 @@ makePrisms ''HandlerContents
|
||||
|
||||
makePrisms ''ErrorResponse
|
||||
|
||||
makeLenses_ ''UploadMode
|
||||
|
||||
makeLenses_ ''SubmissionMode
|
||||
|
||||
makePrisms ''E.Value
|
||||
|
||||
@ -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 ))
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
|
||||
|
||||
@ -51,4 +51,6 @@ extra-deps:
|
||||
|
||||
- systemd-1.2.0
|
||||
|
||||
- filepath-1.4.2
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
_{MsgSubmissionFilesIgnored}
|
||||
<h2>_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
|
||||
<ul>
|
||||
$forall ident <- ignoredFiles
|
||||
$case ident
|
||||
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
^{formWidget}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
<td>#{csrf}^{fvInput labelView}
|
||||
<td>^{fvInput nameView}
|
||||
<td>^{fvInput reqView}
|
||||
@ -0,0 +1,16 @@
|
||||
$newline never
|
||||
<table>
|
||||
<thead>
|
||||
<th>_{MsgUploadSpecificFileLabel}
|
||||
<th>_{MsgUploadSpecificFileName}
|
||||
<th>_{MsgUploadSpecificFileRequired}
|
||||
<th>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
8
templates/widgets/specificFileField.hamlet
Normal file
8
templates/widgets/specificFileField.hamlet
Normal file
@ -0,0 +1,8 @@
|
||||
$newline never
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
|
||||
$if acceptRestricted
|
||||
<br>
|
||||
_{MsgUploadModeExtensionRestriction}:
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- extensions
|
||||
<li style="font-family: monospace">#{ext}
|
||||
@ -1,2 +1,8 @@
|
||||
$newline never
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required>
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
|
||||
$maybe exts <- fmap toNullable permittedExtensions
|
||||
<br>
|
||||
_{MsgUploadModeExtensionRestriction}:
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- zipExtensions <> exts
|
||||
<li style="font-family: monospace">#{ext}
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user