diff --git a/config/personalised-sheet-files-collate b/config/personalised-sheet-files-collate new file mode 100644 index 000000000..a068bc5a1 --- /dev/null +++ b/config/personalised-sheet-files-collate @@ -0,0 +1,21 @@ +$# Syntax: +$# - Leere zeilen werden ignoriert +$# - Zeilen, die mit '$#' beginnen, werden ignoriert +$# - Verbleibende Zeilen werden jeweils als `Glob`-Pattern kompiliert + +$# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt +**/__MACOSX +**/__MACOSX/* +**/__MACOSX/**/* + +$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS) +**/.DS_Store + +$# Ignoriere VI-Style-Backup-Files +**/*~ +$# Ignoriere Emacs-Style-Backup-Files +**/.#*# + +$# Ignoriere exportierte meta-informationen.yaml +**/meta-informationen_*.yaml +**/meta-information_*.yaml \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 5a120e906..3824a9f2b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -229,3 +229,6 @@ token-buckets: depth: 1572864000 # 1500MiB inv-rate: 1.9e-6 # 2MiB/s initial-value: 0 + + +fallback-personalised-sheet-files-keys-expire: 2419200 diff --git a/frontend/src/utils/form/navigate-away-prompt.js b/frontend/src/utils/form/navigate-away-prompt.js index e063809ee..fdb92fa79 100644 --- a/frontend/src/utils/form/navigate-away-prompt.js +++ b/frontend/src/utils/form/navigate-away-prompt.js @@ -48,6 +48,10 @@ export class NavigateAwayPrompt { return; } + if (this._element.attributes.target === '_blank') { + return; + } + // mark initialized this._element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS); } diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ae182100e..c189e8b5f 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -347,7 +347,8 @@ SheetRequireExamTip: Wenn die Anmeldung zu einer Prüfung vorausgesetzt wird, k SheetRequiredExam: Prüfung SheetShowRequiredExam: Vorausgesetze Prüfungsanmeldung SheetSubmissionExamRegistrationRequired: Um die Angabe für dieses Übungsblatt herunterzuladen oder Abzugeben ist eine Anmeldung zur genannten Prüfung erforderlich. -SheetFilesExamRegistrationRequired: Um die Angabe für dieses Übungsblatt herunterzuladen oder Abzugeben ist eine Anmeldung zu der oben genannten Prüfung erforderlich. +SheetFilesExamRegistrationRequired: Um die Dateien dieses Übungsblattes herunterzuladen oder Abzugeben ist eine Anmeldung zu der oben genannten Prüfung erforderlich. +SheetFilesMissingPersonalisedFiles: Um abzugeben muss zunächst ein Kursverwalter personalisierte Übungsblatt-Dateien für Sie hinterlegen. SheetArchiveFileTypeDirectoryExercise: aufgabenstellung SheetArchiveFileTypeDirectoryHint: hinweis @@ -488,6 +489,7 @@ UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. +UnauthorizedSubmissionPersonalisedSheetFiles: Ihnen wurden keine personalisierten Übungsblatt-Dateien zugeteilt und die Abgabe ist ohne diese nicht gestattet. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen. @@ -1351,6 +1353,8 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten MenuAllocationCompute: Platzvergabe berechnen MenuAllocationAccept: Platzvergabe akzeptieren MenuFaq: FAQ +MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen +MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen MenuAdminCrontab: Crontab BreadcrumbSubmissionFile: Datei @@ -1423,6 +1427,8 @@ BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren BreadcrumbMessageHide: Verstecken BreadcrumbFaq: FAQ +BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen +BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen BreadcrumbAdminCrontab: Crontab ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} @@ -1466,6 +1472,7 @@ AuthTagCapacity: Kapazität ist ausreichend AuthTagEmpty: Kurs hat keine Teilnehmer AuthTagMaterials: Kursmaterialien sind freigegeben AuthTagOwner: Nutzer ist Besitzer +AuthTagPersonalisedSheetFiles: Nutzer verfügt über personalisierte Übungsblatt-Dateien AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren @@ -2654,6 +2661,7 @@ CourseParticipantInactive: Abgemeldet CourseParticipantNoShow: Nicht erschienen CourseUserState: Zustand CourseUserSheets: Übungsblätter +CourseUserDownloadPersonalisedSheetFiles: Personalisierte Übungsblatt-Dateien herunterladen TestDownload: Download-Test TestDownloadMaxSize: Maximale Dateigröße @@ -2681,6 +2689,29 @@ SubmissionDoneAlways: Immer CorrUploadSubmissionDoneMode: Bewertung abgeschlossen CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind. +SheetPersonalisedFiles: Personalisierte Dateien +SheetPersonalisedFilesTip: Sollen zusätzlich zu den oben angegebenen Dateien noch pro Kursteilnehmer personalisierte Dateien hinterlegt werden? Nur die jeweiligen Kursteilnehmer können ihre jeweiligen personalisierten Dateien einsehen. +SheetPersonalisedFilesUpload: Personalisierte Dateien +SheetPersonalisedFilesUploadTip: Laden Sie das Vorlage-Archiv herunter, sortieren Sie darin die personalisierten Dateien in die jeweiligen Verzeichnisse der Kursteilnehmer ein und laden sie das Archiv dann hier wieder hoch. Wenn es eine personalisierte und eine nicht-personalisierte Datei mit dem gleichen Namen gibt, so ersetzt die personalisierte Datei aus Sicht des jeweiligen Teilnehmers die nicht-personalisierte Datei. +SheetPersonalisedFilesKeepExisting: Bestehende Dateien behalten +SheetPersonalisedFilesKeepExistingTip: Sollen die hier neu hochgeladenen zu den bestehenden personalisierten Dateien (sofern vorhanden) hinzugefügt werden? Ansonsten ersetzt das neu hochgeladene Archiv vollständig die bestehenden Dateien. +SheetPersonalisedFilesAllowNonPersonalisedSubmission: Nicht-personalisierte Abgabe erlauben +SheetPersonalisedFilesAllowNonPersonalisedSubmissionTip: Sollen auch Kursteilnehmer abgeben dürfen, für die keine personalisierten Dateien hinterlegt wurden? +SheetPersonalisedFilesDownloadTemplateHere: Sie können hier ein Vorlage-Archiv für die vom System erwartete Verzeichnisstruktur für personalisierte Übungsblatt-Dateien herunterladen: +PersonalisedSheetFilesDownloadAnonymous: Anonymisiert +PersonalisedSheetFilesDownloadSurnames: Mit Nachnamen +PersonalisedSheetFilesDownloadMatriculations: Mit Matrikelnummern +PersonalisedSheetFilesDownloadGroups: Mit festen Abgabegruppen +CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien +PersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-personalisierte_dateien +PersonalisedSheetFilesMetaFilename uid@CryptoFileNameUser: meta-informationen_#{toPathPiece uid}.yaml +PersonalisedSheetFilesDownloadAnonymousField: Anonymisierung +PersonalisedSheetFilesDownloadAnonymousFieldTip: Sollen Verzeichnisnamen innerhalb des Archivs von personalisierten Dateien anonymisiert werden (sie enthalten dann keinerlei unmittelbar identifizierende Informationen zu den Kursteilnehmern), oder sollen die Verzeichnisnamen mit einem Merkmal versehen werden und die Metainformations-Dateien zusätzlich persönliche Daten enthalten? +PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"} #{count} hochgeladene #{pluralDE count "Datei" "Dateien"} ignoriert, da sie keinem Übungsblattdatei-Typ oder keinem Kursteilnehmer zugeordnet werden #{pluralDE count "konnte" "konnten"}. +PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert: +CourseUserHasPersonalisedSheetFilesFilter: Teilnehmer hat personalisierte Übungsblatt-Dateien für +SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übungsblatt-Dateien + AdminCrontabNotGenerated: (Noch) keine Crontab generiert CronMatchAsap: ASAP CronMatchNone: Nie diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 6a41d64b5..0c443642b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -347,6 +347,7 @@ SheetRequiredExam: Exam SheetShowRequiredExam: Required exam registration SheetSubmissionExamRegistrationRequired: Registration for the specified exam is required to download files associated with this exercise sheet and to submit. SheetFilesExamRegistrationRequired: To download files for this exercise sheet or to submit you must first register for the exam mentioned above. +SheetFilesMissingPersonalisedFiles: To submit a course administrator has to first assign you some personalised exercise sheet files. SheetArchiveFileTypeDirectoryExercise: exercise SheetArchiveFileTypeDirectoryHint: hint @@ -486,6 +487,7 @@ UnauthorizedTutorialTime: This tutorial does not currently allow registration. UnauthorizedCourseNewsTime: This news item is not currently available. UnauthorizedExamTime: This exam is not currently available. UnauthorizedSubmissionOwner: You are no submittor for this submission. +UnauthorizedSubmissionPersonalisedSheetFiles: You were not assigned any personalised exercise sheet files and submission is not permitted without them. UnauthorizedSubmissionRated: This submission is not yet marked. UnauthorizedSubmissionCorrector: You are no corrector for this submission. UnauthorizedUserSubmission: Users may not directly submit for this exercise sheet. @@ -1351,6 +1353,8 @@ MenuAllocationPriorities: Central priorities MenuAllocationCompute: Compute allocation MenuAllocationAccept: Accept allocation MenuFaq: FAQ +MenuSheetPersonalisedFiles: Download personalised sheet files +MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files MenuAdminCrontab: Crontab BreadcrumbSubmissionFile: File @@ -1423,6 +1427,8 @@ BreadcrumbAllocationCompute: Compute allocation BreadcrumbAllocationAccept: Accept allocation BreadcrumbMessageHide: Hide BreadcrumbFaq: FAQ +BreadcrumbSheetPersonalisedFiles: Download personalised sheet files +BreadcrumbCourseSheetPersonalisedFiles: Download template for personalised sheet files BreadcrumbAdminCrontab: Crontab ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} @@ -1466,6 +1472,7 @@ AuthTagCapacity: Capacity is sufficient AuthTagEmpty: Course is empty AuthTagMaterials: Course material is publicly accessable AuthTagOwner: User is owner +AuthTagPersonalisedSheetFiles: User has been assigned personalised sheet files AuthTagRated: Submission is marked AuthTagUserSubmissions: Submissions are made by course participants AuthTagCorrectorSubmissions: Submissions are registered by correctors @@ -2654,6 +2661,7 @@ CourseParticipantInactive: Deregistered CourseParticipantNoShow: No show CourseUserState: State CourseUserSheets: Exercise sheets +CourseUserDownloadPersonalisedSheetFiles: Download personalised sheet files TestDownload: Download test TestDownloadMaxSize: Maximum filesize @@ -2681,6 +2689,30 @@ SubmissionDoneAlways: Always CorrUploadSubmissionDoneMode: Rating finished CorrUploadSubmissionDoneModeTip: Should uploaded corrections be marked as finished? The rating is only visible to the submittors and considered for any exam bonuses if it is finished. +SheetPersonalisedFiles: Personalised sheet files +SheetPersonalisedFilesTip: Should course participants be assigned personalised sheet files in addition to the files configured above? Only the user to which a file has been assigned may view it. +SheetPersonalisedFilesUpload: Personalised sheet files +SheetPersonalisedFilesUploadTip: Download the template for a ZIP-archive of personalised sheet files, move files into the directories corresponding to the desired users and upload the archive again. If the name of a personalised file matches the name of an unpersonalised file, the personalised file replaces the unpersonalised one from the respective participants' point of view. +SheetPersonalisedFilesKeepExisting: Keep existing files +SheetPersonalisedFilesKeepExistingTip: Should the personalised files you upload be added to the already existing ones, if applicable? Otherwise the files you upload will completely replace any existing files. +SheetPersonalisedFilesAllowNonPersonalisedSubmission: Allow non-personalised submission +SheetPersonalisedFilesAllowNonPersonalisedSubmissionTip: Should course participants with no assigned personalised files be allowed to submit anyway? +SheetPersonalisedFilesDownloadTemplateHere: You can download a template for a ZIP-archive of personalised sheet files with the structure that Uni2work expects here: +PersonalisedSheetFilesDownloadAnonymous: Anonymised +PersonalisedSheetFilesDownloadSurnames: With surnames +PersonalisedSheetFilesDownloadMatriculations: With matriculation numbers +PersonalisedSheetFilesDownloadGroups: With registered submission groups +CoursePersonalisedSheetFilesArchiveName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalised_files +PersonalisedSheetFilesArchiveName tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-personalised_files + +PersonalisedSheetFilesMetaFilename uid: meta-information_#{toPathPiece uid}.yaml +PersonalisedSheetFilesDownloadAnonymousField: Anonymisation +PersonalisedSheetFilesDownloadAnonymousFieldTip: Should the ZIP-archive of personalised files be anonymised (it would then contain no immediately identifiable information regard the course participants) or should directory names be decorated with an identifiable feature of the user and the files of meta information contain additional personal data? +PersonalisedSheetFilesIgnored count: #{count} uploaded #{pluralEN count "file was" "files were"} ignored because #{pluralEN count "it" "they"} could not be associated with both a sheet file type and a course participant. +PersonalisedSheetFilesIgnoredIntro: The following files were ignored: +CourseUserHasPersonalisedSheetFilesFilter: Participant has personalised sheet files for +SheetPersonalisedFilesUsersList: List of course participants who have personalised sheet files + AdminCrontabNotGenerated: Crontab not (yet) generated CronMatchAsap: ASAP CronMatchNone: Never diff --git a/models/sheets.model b/models/sheets.model index 6b6112db0..f54426040 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -14,6 +14,7 @@ Sheet -- exercise sheet for a given course autoDistribute Bool default=false -- Should correctors be assigned submissions automagically? anonymousCorrection Bool default=true requireExamRegistration ExamId Maybe -- Students may only submit if they are registered for the given exam + allowNonPersonalisedSubmission Bool default=true CourseSheet course name deriving Generic SheetEdit -- who edited when a row in table "Course", kept indefinitely @@ -44,3 +45,19 @@ SheetFile -- a file that is part of an exercise sheet content FileContentReference Maybe modified UTCTime UniqueSheetFile sheet type title +PersonalisedSheetFile + sheet SheetId + user UserId + type SheetFileType + title FilePath + content FileContentReference Maybe + modified UTCTime + UniquePersonalisedSheetFile sheet user type title + deriving Eq Ord Read Show Generic Typeable + +FallbackPersonalisedSheetFilesKey + course CourseId + index Word24 + secret ByteString + generated UTCTime + UniqueFallbackPersonalisedSheetFilesKey course index \ No newline at end of file diff --git a/package.yaml b/package.yaml index 3d326017f..7cb2afde6 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ dependencies: - cryptonite-conduit - saltine - base64-bytestring + - base32 - memory - http-api-data - profunctors @@ -308,6 +309,7 @@ tests: - quickcheck-instances - generic-arbitrary - http-types + - yesod-persistent ghc-options: - -fno-warn-orphans - -threaded diff --git a/routes b/routes index d8ae9561b..0b790ae36 100644 --- a/routes +++ b/routes @@ -152,20 +152,21 @@ /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only - !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-groupANDexam-registered + !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !/subs/own SubmissionOwnR GET !free !/subs/assign SAssignR GET POST !lecturerANDtime /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registered !ownerANDread !correctorANDread - /delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registered + / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !ownerANDread !correctorANDread + /delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registeredANDpersonalised-sheet-files /assign SubAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated - /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registered + /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissionsANDexam-registered /corrector-invite/ SCorrInviteR GET POST + /personalised-files SPersonalFilesR GET !/#SheetFileType SZipR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor /file MaterialListR GET !course-registered !materialsANDcourse-time !corrector !tutor @@ -215,6 +216,7 @@ /events/#CryptoUUIDCourseEvent CourseEventR: /edit CEvEditR GET POST /delete CEvDeleteR GET POST + /personalised-sheet-files CPersonalFilesR GET /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/CryptoID.hs b/src/CryptoID.hs index cc2f9a2ff..21099306f 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -74,6 +74,8 @@ decCryptoIDs [ ''SubmissionId , ''TutorialId ] +decCryptoIDKeySize + -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (CI FilePath)) where fromPathPiece (Text.unpack -> piece) = do @@ -91,3 +93,21 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) wh fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where toMarkup = toMarkup . toPathPiece + +-- CryptoIDNamespace (CI FilePath) UserId ~ "User" +instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where + fromPathPiece (Text.unpack -> piece) = do + piece' <- (stripPrefix `on` map CI.mk) "uwb" piece + return . CryptoID . CI.mk $ map CI.original piece' + toPathPiece = Text.pack . ("uwb" <>) . CI.foldedCase . ciphertext + +instance {-# OVERLAPS #-} ToJSON (E.CryptoID "User" (CI FilePath)) where + toJSON = String . toPathPiece +instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "User" (CI FilePath)) where + toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece) +instance {-# OVERLAPS #-} FromJSON (E.CryptoID "User" (CI FilePath)) where + parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece +instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where + fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece +instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where + toMarkup = toMarkup . toPathPiece diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 0e1065a27..755b5f83c 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -15,6 +15,9 @@ import qualified Data.Binary as Binary import Database.Persist.Sql +import qualified Data.CryptoID.ByteString as CryptoID.BS +import Crypto.Cipher.Types (cipherKeySize, KeySizeSpecifier(..)) + decCryptoIDs :: [Name] -> DecsQ decCryptoIDs = fmap concat . mapM decCryptoID @@ -45,3 +48,13 @@ decCryptoIDs = fmap concat . mapM decCryptoID where ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t + +decCryptoIDKeySize :: DecsQ +decCryptoIDKeySize = sequence + [ tySynD (mkName "CryptoIDCipherKeySize") [] . litT . numTyLit $ fromIntegral cryptoIDKeySize + ] + where + cryptoIDKeySize = case cipherKeySize (error "Cipher inspected during cipherKeySize" :: CryptoID.BS.CryptoCipher) of + KeySizeRange mins maxs -> max mins maxs + KeySizeEnum ss -> maximumEx ss + KeySizeFixed s -> s diff --git a/src/Data/Word/Word24/Instances.hs b/src/Data/Word/Word24/Instances.hs new file mode 100644 index 000000000..e1d6add1a --- /dev/null +++ b/src/Data/Word/Word24/Instances.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Word.Word24.Instances + ( + ) where + +import ClassyPrelude +import Database.Persist +import Database.Persist.Sql +import System.Random (Random(..)) + +import Data.Aeson (FromJSON(..), ToJSON(..)) +import qualified Data.Aeson.Types as Aeson + +import Data.Word.Word24 + +import Control.Lens + +import Control.Monad.Fail + +import qualified Data.Scientific as Scientific + +import Data.Binary +import Data.Bits + + +instance PersistField Word24 where + toPersistValue p = toPersistValue (fromIntegral p :: Word32) + fromPersistValue v = do + w <- fromPersistValue v :: Either Text Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Word24) + -> return $ fromIntegral w + | otherwise + -> Left "Word24 out of range" + +instance PersistFieldSql Word24 where + sqlType _ = SqlInt32 + +instance Random Word24 where + randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Word24) $ randomR (fromIntegral lo, fromIntegral hi) gen + random = randomR (minBound, maxBound) + +instance FromJSON Word24 where + parseJSON (Aeson.Number n) = case Scientific.toBoundedInteger n of + Just n' -> return n' + Nothing -> fail "parsing Word24 failed, out of range or not integral" + parseJSON _ = fail "parsing Word24 failed, expected Number" + +instance ToJSON Word24 where + toJSON = Aeson.Number . fromIntegral + + +-- | Big Endian +instance Binary Word24 where + put w = forM_ [2,1..0] $ putWord8 . fromIntegral . shiftR w . (* 8) + get = foldlM (\w i -> (.|. w) . flip shiftL (8 * i) . fromIntegral <$> getWord8) 0 [2,1..0] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 43f48be7b..b31708c48 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -3,6 +3,7 @@ module Database.Esqueleto.Utils ( true, false + , justVal, justValList , isJust , isInfixOf, hasInfix , or, and @@ -67,6 +68,12 @@ true = E.val True false :: E.SqlExpr (E.Value Bool) false = E.val False +justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ)) +justVal = E.val . Just + +justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) +justValList = E.valList . map Just + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing diff --git a/src/Foundation.hs b/src/Foundation.hs index 439368913..489587bff 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1396,6 +1396,21 @@ tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r +tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of + CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do + Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh + MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn + if | sheetAllowNonPersonalisedSubmission -> return Authorized + | otherwise -> do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $ + E.selectExists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId + E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId + E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count + return Authorized + r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID @@ -1579,13 +1594,23 @@ evalAccessFor mAuthId route isWrite = do evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB = evalAccessFor -evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult -evalAccess route isWrite = do +evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult +evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated + let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf + case dnf' of + Nothing -> return Authorized + Just dnf'' -> do + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite + result <$ tellSessionJson SessionInactiveAuthTags deactivated + +evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessWithDB = evalAccessWith + +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess = evalAccessWith [] evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessDB = evalAccess @@ -1605,6 +1630,29 @@ hasReadAccessTo = flip hasAccessTo False hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True +wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> Bool + -> m Bool +wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite + +wouldHaveReadAccessTo, wouldHaveWriteAccessTo + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False +wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True + +wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessToIff assumptions route = and2M (fmap not $ hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route +wouldHaveWriteAccessToIff assumptions route = and2M (fmap not $ hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route + -- | Conditional redirect that hides the URL if the user is not authorized for the route redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do @@ -2582,6 +2630,7 @@ instance YesodBreadcrumbs UniWorX where SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR + SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR @@ -2594,6 +2643,8 @@ instance YesodBreadcrumbs UniWorX where MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR + breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR + breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR @@ -4023,6 +4074,32 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do , navSubmissions ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++ [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetPersonalisedFiles + , navRoute = CSheetR tid ssh csh shn SPersonalFilesR + , navAccess' = + let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_$ sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ sheet E.^. SheetAllowNonPersonalisedSubmission + hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do + E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_$ sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + in runDB $ or2M onlyPersonalised hasPersonalised + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetEdit , navRoute = CSheetR tid ssh csh shn SEditR diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 3da033964..57eebfeaa 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -16,6 +16,7 @@ module Foundation.I18n , ErrorResponseTitle(..) , UniWorXMessages(..) , uniworxMessages + , unRenderMessage, unRenderMessage', unRenderMessageLenient ) where import Foundation.Type @@ -38,6 +39,11 @@ import GHC.Exts (IsList(..)) import Yesod.Form.I18n.German import Yesod.Form.I18n.English +import qualified Data.Foldable as F +import qualified Data.Char as Char +import Text.Unidecode (unidecode) +import Data.Text.Lens (packed) + appLanguages :: NonEmpty Lang appLanguages = "de-de-formal" :| ["en-eu"] @@ -214,6 +220,8 @@ newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Enum, Bounded, Universe, Finite) embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel instance RenderMessage UniWorX SheetType where @@ -355,3 +363,19 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where label = mr label' mr :: forall msg. RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls + + +unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a] +unRenderMessage' cmp foundation inp = nub $ do + l <- appLanguages' + x <- universeF + guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp + return x + where appLanguages' = F.toList appLanguages + +unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessage = unRenderMessage' (==) + +unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessageLenient = unRenderMessage' cmp + where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 9ba6ea9a1..b9186f509 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -19,6 +19,7 @@ import Handler.Course.Application as Handler.Course import Handler.ExamOffice.Course as Handler.Course import Handler.Course.News as Handler.Course import Handler.Course.Events as Handler.Course +import Handler.Sheet.PersonalisedFiles as Handler.Course (getCPersonalFilesR) getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c685164e2..f12e7993d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -32,6 +32,8 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql (updateWhereCount) +import Handler.Sheet.PersonalisedFiles + type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) @@ -305,11 +307,12 @@ userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ data CourseUserAction = CourseUserSendMail - | CourseUserDeregister | CourseUserRegisterTutorial | CourseUserRegisterExam | CourseUserSetSubmissionGroup | CourseUserReRegister + | CourseUserDeregister + | CourseUserDownloadPersonalisedSheetFiles deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction @@ -331,6 +334,10 @@ data CourseUserActionData = CourseUserSendMailData { setSubmissionGroup :: Maybe SubmissionGroupName } | CourseUserReRegisterData + | CourseUserDownloadPersonalisedSheetFilesData + { downloadPersonalisedFilesForSheet :: SheetName + , downloadPersonalisedFilesAnonMode :: PersonalisedSheetFilesDownloadAnonymous + } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -353,6 +360,16 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do tutorials <- selectList [ TutorialCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] [] sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] + personalisedSheets <- E.select . E.from $ \sheet -> do + let hasPersonalised = E.exists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission) + E.||. hasPersonalised + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.orderBy [ E.desc $ sheet E.^. SheetActiveTo + , E.desc $ sheet E.^. SheetActiveFrom + ] + return $ sheet E.^. SheetName -- -- psValidator has default sorting and filtering showSex <- getShowSex let dbtIdent = "courseUsers" :: Text @@ -461,10 +478,17 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId ) - - + -- , ("course-registration", error "TODO") -- TODO + -- , ("course-user-note", error "TODO") -- TODO , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) + , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn + -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do + E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.&&. sheet E.^. SheetName E.==. E.val shn + ) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ @@ -478,6 +502,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) + ] ++ + [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) + | not $ null personalisedSheets ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -578,7 +605,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do showSex <- getShowSex - (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do + (Entity cid Course{..}, numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh hasTutorials <- exists [TutorialCourse ==. cid] @@ -592,6 +619,16 @@ postCUsersR tid ssh csh = do E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] + personalisedSheets <- E.select . E.from $ \sheet -> do + let hasPersonalised = E.exists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission) + E.||. hasPersonalised + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.orderBy [ E.desc $ sheet E.^. SheetActiveTo + , E.desc $ sheet E.^. SheetActiveFrom + ] + return $ sheet E.^. SheetName let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1 let colChoices = mconcat $ catMaybes [ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) @@ -639,6 +676,7 @@ postCUsersR tid ssh csh = do optionDisplay = CI.original $ examName entityVal return Option{..} submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) + acts :: Map CourseUserAction (AForm Handler CourseUserActionData) acts = mconcat $ catMaybes [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData @@ -651,6 +689,10 @@ postCUsersR tid ssh csh = do <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData + , guardOn (not $ null personalisedSheets) . singletonMap CourseUserDownloadPersonalisedSheetFiles $ + CourseUserDownloadPersonalisedSheetFilesData + <$> apopt (selectField' Nothing . optionsF $ map E.unValue personalisedSheets) (fslI MsgExerciseSheet) Nothing + <*> apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField) (Just PersonalisedSheetFilesDownloadAnonymous) ] numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) @@ -733,8 +775,14 @@ postCUsersR tid ssh csh = do return $ Sum didUpdate addMessageI Success $ MsgCourseUsersStateSet nrSet redirect $ CourseR tid ssh csh CUsersR + (CourseUserDownloadPersonalisedSheetFilesData shn anonMode, selectedUsers) -> do + shId <- runDB . getKeyBy404 $ CourseSheet cid shn + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ + MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand shn + sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode - let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] + + let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName} #{tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do setTitleI headingShort diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1d8270e8d..1642e13e6 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -18,6 +18,7 @@ import Handler.Sheet.Current as Handler.Sheet import Handler.Sheet.Download as Handler.Sheet import Handler.Sheet.New as Handler.Sheet import Handler.Sheet.Show as Handler.Sheet +import Handler.Sheet.PersonalisedFiles as Handler.Sheet (getSPersonalFilesR) getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 866718d3d..75a0cbf44 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -16,6 +16,7 @@ import qualified Database.Esqueleto.Utils as E getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSArchiveR tid ssh csh shn = do shId <- runDB $ fetchSheetId tid ssh csh shn + muid <- maybeAuthId MsgRenderer mr <- getMsgRenderer let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn @@ -23,42 +24,75 @@ getSArchiveR tid ssh csh shn = do allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF multipleSFTs <- if | length allowedSFTs < 2 -> return False - | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do - E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType - E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle - E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet - E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet + | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` ((psFile1 `E.FullOuterJoin` sFile1) `E.InnerJoin` (psFile2 `E.FullOuterJoin` sFile2))) -> do + E.on $ sFile2 E.?. SheetFileSheet E.==. psFile2 E.?. PersonalisedSheetFileSheet + E.&&. sFile2 E.?. SheetFileType E.==. psFile2 E.?. PersonalisedSheetFileType + E.&&. sFile2 E.?. SheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle + E.&&. psFile2 E.?. PersonalisedSheetFileUser E.==. E.val muid + + E.on $ ( sFile1 E.?. SheetFileType E.!=. sFile2 E.?. SheetFileType + E.||. psFile1 E.?. PersonalisedSheetFileType E.!=. psFile2 E.?. PersonalisedSheetFileType + E.||. sFile1 E.?. SheetFileType E.!=. psFile2 E.?. PersonalisedSheetFileType + E.||. sFile2 E.?. SheetFileType E.!=. psFile1 E.?. PersonalisedSheetFileType + ) + E.&&. ( sFile1 E.?. SheetFileTitle E.==. sFile2 E.?. SheetFileTitle + E.||. psFile1 E.?. PersonalisedSheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle + E.||. sFile1 E.?. SheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle + E.||. sFile2 E.?. SheetFileTitle E.==. psFile1 E.?. PersonalisedSheetFileTitle + ) + + E.on $ sFile1 E.?. SheetFileSheet E.==. psFile1 E.?. PersonalisedSheetFileSheet + E.&&. sFile1 E.?. SheetFileType E.==. psFile1 E.?. PersonalisedSheetFileType + E.&&. sFile1 E.?. SheetFileTitle E.==. psFile1 E.?. PersonalisedSheetFileTitle + E.&&. psFile1 E.?. PersonalisedSheetFileUser E.==. E.val muid + + + E.on $ (E.just (sheet E.^. SheetId) E.==. sFile1 E.?. SheetFileSheet E.||. E.just (sheet E.^. SheetId) E.==. psFile1 E.?. PersonalisedSheetFileSheet) + E.&&. (E.just (sheet E.^. SheetId) E.==. sFile2 E.?. SheetFileSheet E.||. E.just (sheet E.^. SheetId) E.==. psFile2 E.?. PersonalisedSheetFileSheet) E.where_ $ sheet E.^. SheetId E.==. E.val shId - E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs - E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs - let modifyTitles SheetFile{..} - | not multipleSFTs = SheetFile{..} - | otherwise = SheetFile - { sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) sheetFileTitle - , .. - } + E.&&. (sFile1 E.?. SheetFileType `E.in_` E.justValList allowedSFTs E.||. psFile1 E.?. PersonalisedSheetFileType `E.in_` E.justValList allowedSFTs) + E.&&. (sFile2 E.?. SheetFileType `E.in_` E.justValList allowedSFTs E.||. psFile2 E.?. PersonalisedSheetFileType `E.in_` E.justValList allowedSFTs) + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile1 E.?. PersonalisedSheetFileUser) + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile2 E.?. PersonalisedSheetFileUser) + + let + modifyTitles :: forall record. HasFileReference record => (record -> SheetFileType) -> record -> record + modifyTitles sft f + | not multipleSFTs = f + | otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) ) sftDirectories <- if | not multipleSFTs -> return mempty - | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do - E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId - E.&&. sFile E.^. SheetFileType E.==. E.val sft - return . E.max_ $ sFile E.^. SheetFileModified - + | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do + E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet + E.&&. sFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType + E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle + E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid + E.where_ $ (sFile E.?. SheetFileSheet E.==. E.justVal shId E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.justVal shId) + E.&&. (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft) + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser) + return . E.max_ $ E.unsafeCoalesce + [ sFile E.?. SheetFileModified + , psFile E.?. PersonalisedSheetFileModified + ] + serveZipArchive archiveName $ do - forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile + forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile { sheetFileType = sft , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft , sheetFileModified = mTime , sheetFileContent = Nothing , sheetFileSheet = shId } - sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles + sheetFilesSFTsQuery tid ssh csh shn muid allowedSFTs .| C.map (entityVal `bimap` entityVal) .| C.map (modifyTitles sheetFileType `bimap` modifyTitles personalisedSheetFileType) getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal +getSFileR tid ssh csh shn sft file = do + muid <- maybeAuthId + serveOneFile $ sheetFileQuery tid ssh csh shn muid sft file getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent getSZipR tid ssh csh shn sft = do + muid <- maybeAuthId sft' <- ap getMessageRender $ pure sft archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft' - serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal + serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn muid sft diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index addbde42a..9d128c4f8 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -16,18 +16,20 @@ import qualified Data.Map as Map import Handler.Sheet.Form import Handler.Sheet.CorrectorInvite +import Handler.Sheet.PersonalisedFiles getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSEditR = postSEditR postSEditR tid ssh csh shn = do - (Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do + (Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles) <- runDB $ do ent@(Entity sid _) <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent cLoads <- Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] []) <*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid) - return (ent, fti, cLoads) + hasPersonalisedFiles <- exists [ PersonalisedSheetFileSheet ==. sid ] + return (ent, fti, cLoads, hasPersonalisedFiles) let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription @@ -48,6 +50,11 @@ postSEditR tid ssh csh shn = do , sfAnonymousCorrection = sheetAnonymousCorrection , sfCorrectors = currentLoads , sfRequireExamRegistration = sheetRequireExamRegistration + , sfPersonalF = guardOn (hasPersonalisedFiles || not sheetAllowNonPersonalisedSubmission) SheetPersonalisedFilesForm + { spffFilesKeepExisting = hasPersonalisedFiles + , spffAllowNonPersonalisedSubmission = sheetAllowNonPersonalisedSubmission + , spffFiles = Nothing + } } let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead @@ -79,6 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetAutoDistribute = sfAutoDistribute , sheetAnonymousCorrection = sfAnonymousCorrection , sheetRequireExamRegistration = sfRequireExamRegistration + , sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF } mbsid <- dbAction newSheet case mbsid of @@ -88,6 +96,9 @@ handleSheetEdit tid ssh csh msId template dbAction = do insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF + runConduit $ + maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) + .| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF) insert_ $ SheetEdit aid actTime sid addMessageI Success $ MsgSheetEditOk tid ssh csh sfName -- Sanity checks generating warnings only, but not errors! diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 0f60181c0..2705f7762 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -1,5 +1,5 @@ module Handler.Sheet.Form - ( SheetForm(..), Loads + ( SheetForm(..), SheetPersonalisedFilesForm(..), Loads , makeSheetForm , getFtIdMap ) where @@ -29,6 +29,7 @@ data SheetForm = SheetForm , sfDescription :: Maybe Html , sfRequireExamRegistration :: Maybe ExamId , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads + , sfPersonalF :: Maybe SheetPersonalisedFilesForm , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: Maybe UTCTime , sfActiveTo :: Maybe UTCTime @@ -44,7 +45,13 @@ data SheetForm = SheetForm -- Keine SheetId im Formular! } +data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm + { spffFiles :: Maybe FileUploads + , spffFilesKeepExisting :: Bool + , spffAllowNonPersonalisedSubmission :: Bool + } + getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) getFtIdMap sId = do allSheetFiles <- E.select . E.from $ \sheetFile -> do @@ -59,6 +66,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS (Just sId) -> liftHandler $ runDB $ getFtIdMap sId MsgRenderer mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime + sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF flip (renderAForm FormStandard) html $ SheetForm <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) @@ -69,6 +77,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) + <*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template) <* aformSection MsgSheetFormTimes <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) @@ -90,6 +99,46 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) <*> correctorForm (maybe mempty sfCorrectors template) where + makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) + makeSheetPersonalisedFilesForm template' = do + templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do + mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId + Course{..} <- MaybeT $ get cId + let downloadRoute = case mbSheet of + Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR + downloadTrigger + = [whamlet| + $newline never + #{iconFileZip} + \ _{MsgMenuSheetPersonalisedFiles} + |] + listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl + ( CourseR courseTerm courseSchool courseShorthand CUsersR + , [ ("courseUsers-has-personalised-sheet-files" + , toPathPiece shn + ) + ] + ) + guardM $ hasReadAccessTo downloadRoute + messageIconWidget Info IconFileUser + [whamlet| + $newline never +
+ _{MsgSheetPersonalisedFilesDownloadTemplateHere} +
+ ^{modal downloadTrigger (Left (SomeRoute downloadRoute))} + $maybe lRoute <- listRoute +

+ + _{MsgSheetPersonalisedFilesUsersList} + |] + return $ SheetPersonalisedFilesForm + <$ maybe (pure ()) aformMessage templateDownloadMessage + <*> aopt (zipFileField True Nothing) (fslI MsgSheetPersonalisedFilesUpload & setTooltip MsgSheetPersonalisedFilesUploadTip) Nothing + <*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesKeepExisting & setTooltip MsgSheetPersonalisedFilesKeepExistingTip) (fmap spffFilesKeepExisting template' <|> Just True) + <*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesAllowNonPersonalisedSubmission & setTooltip MsgSheetPersonalisedFilesAllowNonPersonalisedSubmissionTip) (fmap spffAllowNonPersonalisedSubmission template' <|> Just True) + validateSheet :: FormValidator SheetForm Handler () validateSheet = do SheetForm{..} <- State.get diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index e616e81ab..bd7afe47a 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -117,10 +117,10 @@ getSheetListR tid ssh csh = do , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do sheetData dt let existFiles = -- check whether files exist for given type - ( hasSheetFileQuery sheet SheetExercise - , hasSheetFileQuery sheet SheetHint - , hasSheetFileQuery sheet SheetSolution - , hasSheetFileQuery sheet SheetMarking + ( hasSheetFileQuery sheet (E.val muid) SheetExercise + , hasSheetFileQuery sheet (E.val muid) SheetHint + , hasSheetFileQuery sheet (E.val muid) SheetSolution + , hasSheetFileQuery sheet (E.val muid) SheetMarking ) return (sheet, lastSheetEdit sheet, submission, existFiles) , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs index cf0c7cb3e..f3dba58c2 100644 --- a/src/Handler/Sheet/New.hs +++ b/src/Handler/Sheet/New.hs @@ -65,6 +65,7 @@ postSheetNewR tid ssh csh = do , sfCorrectors = loads , sfAnonymousCorrection = sheetAnonymousCorrection , sfRequireExamRegistration = Nothing + , sfPersonalF = Nothing } _other -> Nothing let action = -- More specific error message for new sheet could go here, if insertUnique returns Nothing diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs new file mode 100644 index 000000000..362c73d29 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -0,0 +1,398 @@ +module Handler.Sheet.PersonalisedFiles + ( sinkPersonalisedSheetFiles + , getSPersonalFilesR, getCPersonalFilesR + , PersonalisedSheetFilesKeyException(..) + , sourcePersonalisedSheetFiles, resolvePersonalisedSheetFiles + , PersonalisedSheetFilesDownloadAnonymous(..) + , PersonalisedSheetFileUnresolved(..) + , _PSFUnresolved, _PSFUnresolvedCollatable, _PSFUnresolvedDirectory + ) where + +import Import hiding (StateT(..)) + +import Handler.Utils +import Handler.Sheet.PersonalisedFiles.Meta +import Handler.Sheet.PersonalisedFiles.Types + +import qualified Data.Conduit.Combinators as C +import qualified Data.Conduit.List as C (mapMaybeM) +import Data.Conduit.ResumableSink + +import qualified Crypto.MAC.KMAC as Crypto +import qualified Data.ByteArray as BA +import qualified Data.Binary as Binary +import Crypto.Hash.Algorithms (SHAKE256) + +import Data.ByteString.Lazy.Base32 + +import qualified Data.CaseInsensitive as CI + +import Language.Haskell.TH (nameBase) + +import qualified Data.CryptoID.ByteString as CryptoID +import qualified Data.CryptoID.Class.ImplicitNamespace as I + +import qualified Database.Esqueleto as E + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.List (inits, tails) + +import Text.Unidecode (unidecode) +import Data.Char (isAlphaNum) + +import qualified System.FilePath as FilePath (joinPath) +import System.FilePath.Glob + +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import qualified Control.Monad.State as State +import Control.Monad.Memo (MemoStateT, MonadMemo(..), for2) +import Utils.Memo + + +data PersonalisedSheetFileUnresolved a + = PSFUnresolvedDirectory a + | PSFUnresolvedCollatable Text a + | PSFUnresolved a + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makePrisms ''PersonalisedSheetFileUnresolved + + +personalisedSheetFileTypes :: [SheetFileType] +personalisedSheetFileTypes = filter (/= SheetMarking) universeF + + +resolvePersonalisedSheetFiles + :: forall m a. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m + ) + => Lens' a FilePath + -> (a -> Bool) -- ^ @isDirectory@ + -> CourseId + -> SheetId + -> ConduitT a (Either (PersonalisedSheetFileUnresolved a) (a, FileReferenceResidual PersonalisedSheetFile)) (SqlPersistT m) () +resolvePersonalisedSheetFiles fpL isDir cid sid = do + app <- getYesod + C.mapM $ \fRef -> exceptT (return . Left . ($ fRef)) (return . Right . swap) . flip runStateT fRef $ do + let + genRefOptions :: ConduitT () (UserId, SheetFileType, FilePath) (StateT FilePath (ExceptT _ (SqlPersistT m))) () + genRefOptions = evalMemoStateC Map.empty $ + transPipe lift (yieldMany <=< State.gets $ resolvePersonalisedFilesDirectory app) + .| C.mapMaybeM (runMaybeT . filterRefOption) + where + filterRefOption :: _ -> MaybeT (MemoStateT _ _ _ (StateT FilePath (ExceptT _ (SqlPersistT m)))) (UserId, SheetFileType, FilePath) + filterRefOption (mbIdx, cID, sfType, fPath) = hoist (hoistStateCache $ lift . lift) $ do + let + getUid :: _ -> _ -> MemoStateT _ _ _ (SqlPersistT m) (Maybe UserId) + getUid mbIdx' cID' = runMaybeT $ do + cIDKey <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx' + uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID' + guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid] + return uid + + fmap (, sfType, fPath) . hoistMaybeM . lift $ for2 memo getUid mbIdx cID + + mbRef <- zoom fpL . runConduit $ genRefOptions .| C.head + case mbRef of + Just (uid, sfType, fPath) -> PersonalisedSheetFileResidual sid uid sfType <$ (fpL .= fPath) + Nothing -> do + isDirectory <- State.gets isDir + fPath <- use fpL + if | isDirectory + -> lift $ throwE PSFUnresolvedDirectory + | lstPtn : _ <- Map.keys $ Map.filter (`match'` fPath) personalisedSheetFilesCollatable + -> lift . throwE $ PSFUnresolvedCollatable lstPtn + | otherwise + -> lift $ throwE PSFUnresolved + where match' = matchWith $ matchDefault { matchDotsImplicitly = True } + + +sinkPersonalisedSheetFiles :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m + ) + => CourseId + -> SheetId + -> Bool -- ^ Keep existing? + -> ConduitT FileReference Void (SqlPersistT m) () +sinkPersonalisedSheetFiles cid sid keep + = resolvePersonalisedSheetFiles _fileReferenceTitle (hasn't $ _fileReferenceContent . _Just) cid sid + .| evalRWSC () Map.empty fanoutReferences >>= msgUnreferenced + where + fanoutReferences = do + C.mapM_ $ \case + Left unresolved -> tell $ Set.singleton unresolved + Right (fRef, residual) -> do + let PersonalisedSheetFileResidual{..} = residual + redResidual = (personalisedSheetFileResidualSheet, personalisedSheetFileResidualUser) + mSinks <- State.gets $ Map.lookup redResidual + let mkSinks + | Just sinks' <- mSinks + = Left sinks' + | keep + = Right $ \residual' -> newResumableSink $ sinkFileReferences residual' + | otherwise + = Right $ \residual' -> newResumableSink . void $ replaceFileReferences' mkFilter residual' + sinks = case mkSinks of + Left sinks' -> sinks' + Right mkSinks' -> Map.fromList + [ (residual', mkSinks' residual') + | sfType <- personalisedSheetFileTypes + , let residual' = PersonalisedSheetFileResidual{ personalisedSheetFileResidualType = sfType, .. } + ] + sink = Map.findWithDefault (error "No sink for SheetFileType") residual sinks + sink' <- lift $ yield fRef ++$$ sink + case sink' of + Left _ -> error "sinkFileReferences/replaceFileReferences returned prematurely" + Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks + openSinks <- State.get + lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded + let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks + lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets + , PersonalisedSheetFileUser /<-. sinkUsers + ] + + msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $ + addMessageModal msgStatus msgTrigger $ Right msgWidget + where collated = Map.fromListWith (<>) + [ (ptn, Sum 1) + | PSFUnresolvedCollatable ptn _fRef <- Set.toList unreferenced + ] + collatedL = Map.toList collated + uncollated = [ fileReferenceTitle | PSFUnresolved FileReference{..} <- Set.toList unreferenced ] + + Sum c = Sum (fromIntegral $ length uncollated) <> fold collated + + msgStatus | null uncollated = Info + | otherwise = Warning + + msgTrigger = i18n $ MsgPersonalisedSheetFilesIgnored c + msgWidget = $(widgetFile "messages/personalisedSheetFilesIgnored") + + mkFilter :: FileReferenceResidual PersonalisedSheetFile -> [Filter PersonalisedSheetFile] + mkFilter PersonalisedSheetFileResidual{..} = [ PersonalisedSheetFileSheet ==. personalisedSheetFileResidualSheet + , PersonalisedSheetFileUser ==. personalisedSheetFileResidualUser + , PersonalisedSheetFileType ==. personalisedSheetFileResidualType + ] + + sinkFileReferences :: FileReferenceResidual PersonalisedSheetFile -> ConduitT FileReference Void (SqlPersistT m) () + sinkFileReferences residual' = C.mapM_ $ \fRef -> void . put $ _FileReference # (fRef, residual') + + + +sourcePersonalisedSheetFiles :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + , MonadRandom m + ) + => CourseId + -> Maybe SheetId + -> Maybe (Set UserId) + -> PersonalisedSheetFilesDownloadAnonymous + -> ConduitT () (Either PersonalisedSheetFile File) (SqlPersistT m) () +sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do + (mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid + let + genSuffixes uid = case anonMode of + PersonalisedSheetFilesDownloadGroups -> do + subGroups <- E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cId + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + return $ submissionGroup E.^. SubmissionGroupName + return . nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups + otherAnon + | Just f <- userFeature otherAnon -> do + features <- E.select . E.from $ \user -> do + E.where_ $ user E.^. UserId E.==. E.val uid + return $ f user + return . sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features + _other -> return mempty + where userFeature PersonalisedSheetFilesDownloadSurnames + = Just $ E.just . (E.^. UserSurname) + userFeature PersonalisedSheetFilesDownloadMatriculations + = Just $ E.castString . (E.^. UserMatrikelnummer) + userFeature _ + = Nothing + + sqlSource = E.selectSource . E.from $ \(courseParticipant `E.LeftOuterJoin` personalisedSheetFile) -> do + E.on $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. personalisedSheetFile E.?. PersonalisedSheetFileUser + E.&&. E.val mbsid E.==. personalisedSheetFile E.?. PersonalisedSheetFileSheet + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cId + case mbuids of + Just uids -> E.where_ $ courseParticipant E.^. CourseParticipantUser `E.in_` E.valList (Set.toList uids) + Nothing -> E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + return (courseParticipant, personalisedSheetFile) + + toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do + MsgRenderer mr <- getMsgRenderer + suffix <- do + sufCache <- uses _sufCache $ Map.lookup courseParticipantUser + case sufCache of + Just suf -> return suf + Nothing -> do + suf <- lift . lift $ genSuffixes courseParticipantUser + _sufCache %= Map.insert courseParticipantUser suf + return suf + cID <- either throwM return . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser + let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID + unlessM (uses _dirCache $ Set.member dirName) $ do + yield $ Right File + { fileTitle = dirName + , fileContent = Nothing + , fileModified = courseParticipantRegistration + } + forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType -> + yield $ Right File + { fileTitle = dirName unpack (mr $ SheetArchiveFileTypeDirectory sfType) + , fileContent = Nothing + , fileModified = courseParticipantRegistration + } + yieldM . fmap Right $ do + fileContent <- lift $ Just . toStrict <$> formatPersonalisedSheetFilesMeta anonMode cPart cID + let fileTitle = (dirName ) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID + fileModified = courseParticipantRegistration + return File{..} + _dirCache %= Set.insert dirName + whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do + let dirName' = dirName unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType) + yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' ) pFile + where + _sufCache :: Lens' _ _ + _sufCache = _1 + _dirCache :: Lens' _ _ + _dirCache = _2 + + + sqlSource .| evalStateC (Map.empty, Set.empty) toRefs + + +data PersonalisedSheetFilesKeyException + = PersonalisedSheetFilesKeyCouldNotDecodeRandom + | FallbackPersonalisedSheetFilesKeysExhausted + | PersonalisedSheetFilesKeyInsufficientContext + | PersonalisedSheetFilesKeyNotFound + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + +newPersonalisedFilesKey :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m, MonadRandom m + ) + => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey) +newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $ + either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $ + Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey +newPersonalisedFilesKey (Left cId) = do + now <- liftIO getCurrentTime + secret <- CryptoID.genKey + let secret' = toStrict $ Binary.encode secret + firstN <- getRandom + + let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey) + loop n = do + didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now) + if | didInsert + -> return (Just n, secret) + | (firstN == minBound && n == maxBound) + || n == pred firstN + -> throwM FallbackPersonalisedSheetFilesKeysExhausted + | n == maxBound + -> loop minBound + | otherwise + -> loop $ succ n + in loop firstN + +getPersonalisedFilesKey :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m, MonadRandom m + ) + => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey +getPersonalisedFilesKey _ Nothing Nothing = throwM PersonalisedSheetFilesKeyInsufficientContext +getPersonalisedFilesKey _ (Just shId) Nothing = view _2 <$> newPersonalisedFilesKey (Right shId) +getPersonalisedFilesKey cId _ (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do + Entity _ FallbackPersonalisedSheetFilesKey{..} <- MaybeT . getBy $ UniqueFallbackPersonalisedSheetFilesKey cId idx + either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict $ BA.convert fallbackPersonalisedSheetFilesKeySecret + +mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath +mkPersonalisedFilesDirectory Nothing cID = unpack $ toPathPiece cID +mkPersonalisedFilesDirectory (Just idx) cID = unpack $ toPathPiece cID <> "-" <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode idx) + +resolvePersonalisedFilesDirectory :: forall master. + RenderMessage master SheetArchiveFileTypeDirectory + => master + -> FilePath + -> [(Maybe Word24, CryptoFileNameUser, SheetFileType, FilePath)] +resolvePersonalisedFilesDirectory foundation (splitPath -> fPath) = do + (fPath', remFPath) <- inits fPath `zip` tails fPath + guard . not $ null remFPath + (SheetArchiveFileTypeDirectory sfType, fPath'') <- foldMap (\(seg, rest) -> (, rest) <$> unRenderMessageLenient foundation (pack seg)) $ foci fPath' + guard $ sfType `elem` personalisedSheetFileTypes + let cryptSegments = foldMap (filter (not . Text.null) . Text.split (flip Set.notMember cryptChars . CI.mk) . Text.pack) fPath'' + (mIdx, cryptSegments') <- foldMap (\(inp, rest) -> (, rest) . Just <$> hoistMaybe (decodeIdx inp)) (foci cryptSegments) <|> pure (Nothing, cryptSegments) + cID <- foldMap (hoistMaybe . fromPathPiece) cryptSegments' + return (mIdx, cID, sfType, FilePath.joinPath remFPath) + where + foci :: forall a. [a] -> [(a, [a])] + foci [] = [] + foci (x:xs) = (x, xs) : map (over _2 (x:)) (foci xs) + + cryptoIdChars, base32Chars, cryptChars :: Set (CI Char) + cryptChars = base32Chars <> cryptoIdChars + cryptoIdChars = mappend base32Chars . Set.fromList $ map CI.mk "uwb" + base32Chars = Set.fromList $ map CI.mk "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" + + decodeIdx :: Text -> Maybe Word24 + decodeIdx inp + | Right inp' <- decodeBase32Unpadded . fromStrict $ encodeUtf8 inp + , Right (remInp, _, idx) <- Binary.decodeOrFail inp' + , null remInp + = Just idx + | otherwise = Nothing + + + +getPersonalFilesR :: CourseId -> Maybe SheetId -> Handler TypedContent +getPersonalFilesR cId mbsid = do + (Course{..}, mbSheet) <- runDB $ (,) + <$> get404 cId + <*> traverse get404 mbsid + + cRoute <- getCurrentRoute + ((anonRes, anonFormWdgt), anonEnctype) <- runFormGet . renderAForm FormStandard $ + apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous) + + formResult anonRes $ \anonMode -> do + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ case mbSheet of + Nothing -> MsgCoursePersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand + Just Sheet{..} -> MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand sheetName + sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid Nothing anonMode + + isModal <- hasCustomHeader HeaderIsModal + + fmap toTypedContent . siteLayoutMsg MsgMenuSheetPersonalisedFiles $ do + setTitleI MsgMenuSheetPersonalisedFiles + wrapForm anonFormWdgt def + { formMethod = GET + , formAction = SomeRoute <$> cRoute + , formEncoding = anonEnctype + , formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal + } + +getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSPersonalFilesR tid ssh csh shn = do + Entity shId Sheet{..} <- runDB $ fetchSheet tid ssh csh shn + getPersonalFilesR sheetCourse $ Just shId + +getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent +getCPersonalFilesR tid ssh csh = do + cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + getPersonalFilesR cId Nothing diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs new file mode 100644 index 000000000..dbbf5f7b2 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs @@ -0,0 +1,127 @@ +module Handler.Sheet.PersonalisedFiles.Meta + ( formatPersonalisedSheetFilesMeta + ) where + +import Import + +import Handler.Sheet.PersonalisedFiles.Types + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString + +import qualified Data.YAML as YAML +import qualified Data.YAML.Event as YAML (untagged) +import qualified Data.YAML.Event as YAML.Event +import qualified Data.YAML.Token as YAML (Encoding(..)) + +import Control.Monad.Trans.State.Lazy (evalState) + +import qualified Database.Esqueleto as E + +import qualified Data.CaseInsensitive as CI + + +data PrettifyState + = PrettifyInitial + | PrettifyFlowSequence PrettifyState + | PrettifyBlockSequence PrettifyState + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +formatPersonalisedSheetFilesMeta + :: MonadIO m + => PersonalisedSheetFilesDownloadAnonymous + -> CourseParticipant + -> CryptoFileNameUser + -> SqlPersistT m Lazy.ByteString +formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do + User{..} <- getJust courseParticipantUser + exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.where_ $ exam E.^. ExamCourse E.==. E.val courseParticipantCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val courseParticipantUser + return $ exam E.^. ExamName + + let uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat + [ [ YAML.Event.StreamStart + , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2 + , YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block + ] + , mapEvents (str' "user") (str $ toPathPiece cID) + , guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat + [ mapEvents (str' "display_name") (str userDisplayName) + , mapEvents (str' "surname") (str userSurname) + , mapEvents (str' "first_names") (str userFirstName) + , case userMatrikelnummer of + Just matr -> mapEvents (str' "matriculation") (str matr) + Nothing -> mzero + , mapEvents (str' "email") (str $ CI.original userEmail) + ] + , map flowStyle $ mapEvents (str' "languages") . YAML.Sequence () YAML.untagged $ maybe [] (views _Wrapped $ map str) userLanguages + , mapEvents (str' "registered_exams") . YAML.Sequence () YAML.untagged $ map (str . CI.original . E.unValue) exams + , [ YAML.Event.MappingEnd + , YAML.Event.DocumentEnd False + , YAML.Event.StreamEnd + ] + ] + where + str :: forall t. Textual t => t -> YAML.Node () + str = YAML.Scalar () . YAML.SStr . repack + str' :: Text -> YAML.Node () + str' = str + + mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event] + mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v + where filterEvs ((YAML.Event.MappingStart{} : inner) :> YAML.Event.MappingEnd) = inner + filterEvs _other = error "Could not strip Mapping" + + nodeEvents :: YAML.Node () -> [YAML.Event.Event] + nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc + where filterEvs = filter $ \case + YAML.Event.StreamStart -> False + YAML.Event.StreamEnd -> False + YAML.Event.DocumentStart _ -> False + YAML.Event.DocumentEnd _ -> False + _other -> True + + flowStyle :: YAML.Event.Event -> YAML.Event.Event + flowStyle = \case + YAML.Event.SequenceStart a t _ -> YAML.Event.SequenceStart a t YAML.Event.Flow + YAML.Event.MappingStart a t _ -> YAML.Event.MappingStart a t YAML.Event.Flow + other -> other + + prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML + where + transduce' (Left _ : _) = error "Parse error on uglyYAML" + transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _)) + = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (`transduce` eEvent)) <*> transduce' es + transduce' (Right YAML.Event.EvPos{..} : es) + = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`transduce` eEvent)) <*> transduce' es + transduce' [] = return [] + + annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse + where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann3, ann2)) + = let (before', after) = Lazy.ByteString.splitAt pos2' dat + (before, event) = Lazy.ByteString.splitAt pos1' before' + event' = decodeUtf8 $ toStrict event + ws = Text.takeWhileEnd Char.isSpace event' + event'' = Text.dropWhileEnd Char.isSpace event' + pos1' = min pos1 mLength + pos2' = min pos2 mLength + in (before <> ann1 <> fromStrict (encodeUtf8 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1') + + transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState) + transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState) + transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState) + transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState) + where f str | ']' `elem` str = filter (/= '\n') str + | otherwise = str + -- transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial) + transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Block) = ((" ", id, id), PrettifyBlockSequence cState) + transduce (PrettifyBlockSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState) + transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n -", id), cState) + transduce cState _ = ((mempty, id, id), cState) + -- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO + return prettyYAML diff --git a/src/Handler/Sheet/PersonalisedFiles/Types.hs b/src/Handler/Sheet/PersonalisedFiles/Types.hs new file mode 100644 index 000000000..c3f5a5ca8 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles/Types.hs @@ -0,0 +1,19 @@ +module Handler.Sheet.PersonalisedFiles.Types + ( PersonalisedSheetFilesDownloadAnonymous(..) + , _PersonalisedSheetFilesDownloadAnonymous, _PersonalisedSheetFilesDownloadSurnames, _PersonalisedSheetFilesDownloadMatriculations, _PersonalisedSheetFilesDownloadGroups + ) where + +import Import + + +data PersonalisedSheetFilesDownloadAnonymous + = PersonalisedSheetFilesDownloadAnonymous + | PersonalisedSheetFilesDownloadSurnames + | PersonalisedSheetFilesDownloadMatriculations + | PersonalisedSheetFilesDownloadGroups + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4 +embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id + +makePrisms ''PersonalisedSheetFilesDownloadAnonymous diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 4ce503dbc..00f38c092 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -11,13 +11,14 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map - import Handler.Sheet.Pseudonym +import Utils.Sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do now <- liftIO getCurrentTime + muid <- maybeAuthId Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility @@ -32,12 +33,20 @@ getSShowR tid ssh csh shn = do | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime | otherwise = mempty - let fileData sheetFile = do + let fileData (sheetFile `E.FullOuterJoin` psFile) = do + E.on $ sheetFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle + E.&&. sheetFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType + E.&&. sheetFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet + E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid -- filter to requested file - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories + E.where_ $ (sheetFile E.?. SheetFileSheet E.==. E.justVal sid E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.justVal sid) + E.&&. E.maybe (E.isJust . E.joinV $ sheetFile E.?. SheetFileContent) E.isJust (psFile E.?. PersonalisedSheetFileContent) -- don't show directories + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser) -- return desired columns - return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType) + return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle] + , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified] + , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType] + ) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> let link = CSheetR tid ssh csh shn $ SZipR ftype in @@ -59,7 +68,7 @@ getSShowR tid ssh csh shn = do & forceFilter "may-access" (Any True) (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData - , dbtRowKey = (E.^. SheetFileId) + , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId) , dbtColonnade = colonnadeFiles , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) , dbtStyle = def @@ -72,16 +81,16 @@ getSShowR tid ssh csh shn = do , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" - , SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType + , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.orderByEnum $ E.unsafeCoalesce [sheetFile E.?. SheetFileType, psFile E.?. PersonalisedSheetFileType] ) , ( "path" - , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle + , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileTitle, psFile E.?. PersonalisedSheetFileTitle] ) -- , ( "visible" -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet -- ) , ( "time" - , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified + , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileModified, psFile E.?. PersonalisedSheetFileModified] ) ] , dbtParams = def @@ -89,8 +98,12 @@ getSShowR tid ssh csh shn = do , dbtCsvDecode = Nothing } (hasHints, hasSolution) <- runDB $ do - hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] - hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] + hasHints <- E.selectExists . E.from $ \sheet' -> + E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetHint + E.&&. sheet' E.^. SheetId E.==. E.val sid + hasSolution <- E.selectExists . E.from $ \sheet' -> + E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetSolution + E.&&. sheet' E.^. SheetId E.==. E.val sid return (hasHints, hasSolution) mPseudonym <- runMaybeT $ do uid <- MaybeT maybeAuthId @@ -103,7 +116,11 @@ getSShowR tid ssh csh shn = do , formEncoding = generateEnctype , formSubmit = FormNoSubmit } - mRequiredExam <- fmap join . for (sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do + checkExamRegistration <- orM + [ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR + , wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR + ] + mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ exam E.^. ExamId E.==. E.val eId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName) @@ -112,10 +129,20 @@ getSShowR tid ssh csh shn = do let eUrl = CExamR etid essh ecsh examn EShowR guardM $ hasReadAccessTo eUrl return eUrl - mMissingExamRegistration <- for (sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do + mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do uid <- MaybeT maybeAuthId lift . fmap not . runDB $ exists [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid ] + checkPersonalisedFiles <- andM + [ return . not $ sheetAllowNonPersonalisedSubmission sheet + , return $ NTop (sheetActiveFrom sheet) <= NTop (Just now), return $ NTop (Just now) <= NTop (sheetActiveTo sheet) + , wouldHaveWriteAccessToIff [(AuthPersonalisedSheetFiles, True)] $ CSheetR tid ssh csh shn SubmissionNewR + ] + mMissingPersonalisedFiles <- for (guardOnM checkPersonalisedFiles muid) $ \uid -> runDB $ + fmap not . E.selectExists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. E.val uid + E.&&. psFile E.^. PersonalisedSheetFileSheet E.==. E.val sid + defaultLayout $ do setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn let zipLink = CSheetR tid ssh csh shn SArchiveR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b8a9f9375..95a919e72 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -60,7 +60,7 @@ serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.ma serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent serveSomeFiles' archiveName source = do - results <- runDB . runConduit $ source .| peekN 2 + (source', results) <- runDB $ runPeekN 2 source $logDebugS "serveSomeFiles" . tshow $ length results @@ -71,14 +71,17 @@ serveSomeFiles' archiveName source = do setContentDisposition' $ Just archiveName respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName - source .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder -- | Serve any number of files as a zip-archive of files, identified through a given DB query -- -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent -serveZipArchive archiveName source = do - results <- runDB . runConduit $ source .| peekN 1 +serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left + +serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent +serveZipArchive' archiveName source = do + (source', results) <- runDB $ runPeekN 1 source $logDebugS "serveZipArchive" . tshow $ length results @@ -88,7 +91,7 @@ serveZipArchive archiveName source = do setContentDisposition' $ Just archiveName respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName - source .| sourceFiles' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder -- | Prefix a message with a short course id, diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ae8828d40..88a8e6070 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -973,7 +973,7 @@ genericFileField mkOpts = Field{..} ) .| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..}) mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent) - (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2 + (fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc $logDebugS "genericFileField.fieldParse" $ tshow nFiles if | nFiles <= 0 -> return Nothing diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 4a2d5615b..5a82c8921 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -101,7 +101,6 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating return File{..} - where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName type SubmissionContent = Either FileReference (SubmissionId, Rating') @@ -162,4 +161,3 @@ isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do let canonExtension = Set.singleton $ CI.mk (pack extensionRating) validExtensions = foldMap (Set.map CI.mk . mimeExtensions) ["application/json", "text/vnd.yaml"] guard $ extension `Set.member` Set.union canonExtension validExtensions - where ensureExtension ext fName' = bool (`addExtension` ext) id (ext `isExtensionOf` fName') fName' diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index a63686f84..13ac4d067 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -339,6 +339,10 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups + E.where_ . E.exists . E.from $ \(submission `E.InnerJoin` sheet) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID + E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse return $ submissionGroup E.^. SubmissionGroupName let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups return . intercalate "_" $ asciiGroups `snoc` fp diff --git a/src/Handler/Utils/Submission/TH.hs b/src/Handler/Utils/Submission/TH.hs deleted file mode 100644 index 14504b6cf..000000000 --- a/src/Handler/Utils/Submission/TH.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Handler.Utils.Submission.TH - ( patternFile - ) where - -import ClassyPrelude.Yesod -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..)) - -import System.FilePath.Glob - -import qualified Data.Text as Text -import qualified Data.Text.IO as Text - -deriving instance Lift CompOptions - --- $(patternFile compDefault file) :: [System.FilePath.Glob.Pattern] -patternFile :: CompOptions -> FilePath -> ExpQ -patternFile opts file = do - qAddDependentFile file - patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file - listE $ map (\(Text.unpack -> pat) -> [|compileWith opts pat|]) patternStrings - -isComment :: Text -> Bool -isComment line = or - [ commentSymbol `Text.isPrefixOf` Text.stripStart line - , Text.null $ Text.strip line - ] - where - commentSymbol = "$#" diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index df7916e2c..b3329f0c5 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -417,10 +417,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms where conDTCell = ifCell condition dateTimeCell $ const mempty -sortFilePath :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFilePath :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField)) -sortFileModification :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFileModification :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField)) defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7b20b4bc0..c5c534b1f 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1100,7 +1100,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exportData <- fromDynamic dbCsvExportData -> do hdr <- dbtCsvHeader $ Just exportData - let ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName dbtCsvName' <- timestampCsv <*> pure dbtCsvName setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName' sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 846bb5c00..80b95ad55 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -168,6 +168,7 @@ import Network.HTTP.Types.Method.Instances as Import () import Crypto.Random.Instances as Import () import Network.Minio.Instances as Import () import System.Clock.Instances as Import () +import Data.Word.Word24.Instances as Import () import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache) import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) @@ -189,6 +190,8 @@ import Data.Encoding.UTF8 as Import (UTF8(UTF8)) import GHC.TypeLits as Import (KnownSymbol) +import Data.Word.Word24 as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs.hs b/src/Jobs.hs index 314e68679..320b9f56a 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -59,6 +59,7 @@ import Jobs.Handler.SynchroniseLdap import Jobs.Handler.PruneInvitations import Jobs.Handler.ChangeUserDisplayEmail import Jobs.Handler.Files +import Jobs.Handler.PersonalisedSheetFiles import Jobs.HealthReport diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 4a9b269a4..77c0419d0 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -78,6 +78,17 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + oldestFallbackPersonalisedSheetFilesKey <- lift $ preview (_head . _entityVal . _fallbackPersonalisedSheetFilesKeyGenerated) <$> selectList [] [Asc FallbackPersonalisedSheetFilesKeyGenerated, LimitTo 1] + whenIsJust oldestFallbackPersonalisedSheetFilesKey $ \oldest -> tell $ HashMap.singleton + (JobCtlQueue JobPruneFallbackPersonalisedSheetFilesKeys) + Cron + { cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appFallbackPersonalisedSheetFilesKeysExpire oldest + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appFallbackPersonalisedSheetFilesKeysExpire / 2 + , cronNotAfter = Right CronNotScheduled + } + + whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval -> tell $ HashMap.singleton (JobCtlQueue JobInjectFiles) diff --git a/src/Jobs/Handler/PersonalisedSheetFiles.hs b/src/Jobs/Handler/PersonalisedSheetFiles.hs new file mode 100644 index 000000000..35bd8cd61 --- /dev/null +++ b/src/Jobs/Handler/PersonalisedSheetFiles.hs @@ -0,0 +1,15 @@ +module Jobs.Handler.PersonalisedSheetFiles + ( dispatchJobPruneFallbackPersonalisedSheetFilesKeys + ) where + +import Import + +import Database.Persist.Sql (deleteWhereCount) + + +dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX +dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomic . hoist lift $ do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire + n <- deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] + $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index c587bf9b8..cfee776fb 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -85,6 +85,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobPruneSessionFiles | JobPruneUnreferencedFiles | JobInjectFiles + | JobPruneFallbackPersonalisedSheetFilesKeys deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Model.hs b/src/Model.hs index 301846972..b450990ec 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -57,6 +57,7 @@ instance ToMessage (Key Term) where instance HasFileReference CourseApplicationFile where newtype FileReferenceResidual CourseApplicationFile = CourseApplicationFileResidual { courseApplicationFileResidualApplication :: CourseApplicationId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseApplicationFile{..} -> ( FileReference @@ -77,6 +78,7 @@ instance HasFileReference CourseApplicationFile where } ) +instance IsFileReference CourseApplicationFile where fileReferenceTitleField = CourseApplicationFileTitle fileReferenceContentField = CourseApplicationFileContent fileReferenceModifiedField = CourseApplicationFileModified @@ -84,6 +86,7 @@ instance HasFileReference CourseApplicationFile where instance HasFileReference CourseAppInstructionFile where newtype FileReferenceResidual CourseAppInstructionFile = CourseAppInstructionFileResidual { courseAppInstructionFileResidualCourse :: CourseId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseAppInstructionFile{..} -> ( FileReference @@ -104,6 +107,7 @@ instance HasFileReference CourseAppInstructionFile where } ) +instance IsFileReference CourseAppInstructionFile where fileReferenceTitleField = CourseAppInstructionFileTitle fileReferenceContentField = CourseAppInstructionFileContent fileReferenceModifiedField = CourseAppInstructionFileModified @@ -112,7 +116,7 @@ instance HasFileReference SheetFile where data FileReferenceResidual SheetFile = SheetFileResidual { sheetFileResidualSheet :: SheetId , sheetFileResidualType :: SheetFileType - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SheetFile{..} -> ( FileReference @@ -122,14 +126,14 @@ instance HasFileReference SheetFile where } , SheetFileResidual { sheetFileResidualSheet = sheetFileSheet - , sheetFileResidualType = sheetFileType + , sheetFileResidualType = sheetFileType } ) ) (\( FileReference{..} , SheetFileResidual{..} ) -> SheetFile - { sheetFileSheet = sheetFileResidualSheet + { sheetFileSheet = sheetFileResidualSheet , sheetFileType = sheetFileResidualType , sheetFileTitle = fileReferenceTitle , sheetFileContent = fileReferenceContent @@ -137,16 +141,54 @@ instance HasFileReference SheetFile where } ) - fileReferenceTitleField = SheetFileTitle - fileReferenceContentField = SheetFileContent +instance IsFileReference SheetFile where + fileReferenceTitleField = SheetFileTitle + fileReferenceContentField = SheetFileContent fileReferenceModifiedField = SheetFileModified +instance HasFileReference PersonalisedSheetFile where + data FileReferenceResidual PersonalisedSheetFile = PersonalisedSheetFileResidual + { personalisedSheetFileResidualSheet :: SheetId + , personalisedSheetFileResidualUser :: UserId + , personalisedSheetFileResidualType :: SheetFileType + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _FileReference + = iso (\PersonalisedSheetFile{..} -> ( FileReference + { fileReferenceTitle = personalisedSheetFileTitle + , fileReferenceContent = personalisedSheetFileContent + , fileReferenceModified = personalisedSheetFileModified + } + , PersonalisedSheetFileResidual + { personalisedSheetFileResidualSheet = personalisedSheetFileSheet + , personalisedSheetFileResidualUser = personalisedSheetFileUser + , personalisedSheetFileResidualType = personalisedSheetFileType + } + ) + ) + (\( FileReference{..} + , PersonalisedSheetFileResidual{..} + ) -> PersonalisedSheetFile + { personalisedSheetFileSheet = personalisedSheetFileResidualSheet + , personalisedSheetFileUser = personalisedSheetFileResidualUser + , personalisedSheetFileType = personalisedSheetFileResidualType + , personalisedSheetFileTitle = fileReferenceTitle + , personalisedSheetFileContent = fileReferenceContent + , personalisedSheetFileModified = fileReferenceModified + } + ) + +instance IsFileReference PersonalisedSheetFile where + fileReferenceTitleField = PersonalisedSheetFileTitle + fileReferenceContentField = PersonalisedSheetFileContent + fileReferenceModifiedField = PersonalisedSheetFileModified + instance HasFileReference SubmissionFile where data FileReferenceResidual SubmissionFile = SubmissionFileResidual { submissionFileResidualSubmission :: SubmissionId , submissionFileResidualIsUpdate , submissionFileResidualIsDeletion :: Bool - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SubmissionFile{..} -> ( FileReference @@ -173,6 +215,7 @@ instance HasFileReference SubmissionFile where } ) +instance IsFileReference SubmissionFile where fileReferenceTitleField = SubmissionFileTitle fileReferenceContentField = SubmissionFileContent fileReferenceModifiedField = SubmissionFileModified @@ -180,6 +223,7 @@ instance HasFileReference SubmissionFile where instance HasFileReference CourseNewsFile where newtype FileReferenceResidual CourseNewsFile = CourseNewsFileResidual { courseNewsFileResidualNews :: CourseNewsId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseNewsFile{..} -> ( FileReference @@ -200,14 +244,15 @@ instance HasFileReference CourseNewsFile where } ) +instance IsFileReference CourseNewsFile where fileReferenceTitleField = CourseNewsFileTitle fileReferenceContentField = CourseNewsFileContent fileReferenceModifiedField = CourseNewsFileModified instance HasFileReference MaterialFile where - data FileReferenceResidual MaterialFile = MaterialFileResidual - { materialFileResidualMaterial :: MaterialId - } + newtype FileReferenceResidual MaterialFile + = MaterialFileResidual { materialFileResidualMaterial :: MaterialId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\MaterialFile{..} -> ( FileReference @@ -230,6 +275,7 @@ instance HasFileReference MaterialFile where } ) +instance IsFileReference MaterialFile where fileReferenceTitleField = MaterialFileTitle fileReferenceContentField = MaterialFileContent fileReferenceModifiedField = MaterialFileModified diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 23993e85e..fbbff7c5b 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -1,7 +1,7 @@ module Model.Types.File ( File(..), _fileTitle, _fileContent, _fileModified , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified - , HasFileReference(..) + , HasFileReference(..), IsFileReference(..), FileReferenceResidual(..) ) where import Import.NoModel @@ -27,11 +27,34 @@ data FileReference = FileReference makeLenses_ ''FileReference -class PersistEntity record => HasFileReference record where +class HasFileReference record where data FileReferenceResidual record :: * _FileReference :: Iso' record (FileReference, FileReferenceResidual record) +instance HasFileReference FileReference where + data FileReferenceResidual FileReference = FileReferenceResidual + _FileReference = iso (, FileReferenceResidual) $ view _1 + +instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where + newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } + _FileReference = iso doSplit doJoin + where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference + doSplit (Left r) = over _2 (FileReferenceResidualEither . Left ) $ r ^. _FileReference + doJoin (fRef, FileReferenceResidualEither (Right res)) = Right $ _FileReference # (fRef, res) + doJoin (fRef, FileReferenceResidualEither (Left res)) = Left $ _FileReference # (fRef, res) + +instance HasFileReference record => HasFileReference (Entity record) where + data FileReferenceResidual (Entity record) = FileReferenceResidualEntity + { fileReferenceResidualEntityKey :: Key record + , fileReferenceResidualEntityResidual :: FileReferenceResidual record + } + _FileReference = iso doSplit doJoin + where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) + where (fRef, res) = entityVal ^. _FileReference + doJoin (fRef, FileReferenceResidualEntity entityKey res) = Entity{ entityVal = _FileReference # (fRef, res), .. } + +class (PersistEntity record, HasFileReference record) => IsFileReference record where fileReferenceTitleField :: EntityField record FilePath fileReferenceContentField :: EntityField record (Maybe FileContentReference) fileReferenceModifiedField :: EntityField record UTCTime diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 27490f784..5ab120c3a 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -69,6 +69,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthCourseTime | AuthMaterials | AuthOwner + | AuthPersonalisedSheetFiles | AuthRated | AuthUserSubmissions | AuthCorrectorSubmissions @@ -130,6 +131,8 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (Hashable, Binary) +makeLenses_ ''PredLiteral + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "val" "var" @@ -148,6 +151,8 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving newtype (Semigroup, Monoid) deriving anyclass (Binary, Hashable) +makeLenses_ ''PredDNF + $(return []) instance ToJSON a => ToJSON (PredDNF a) where @@ -164,6 +169,20 @@ type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag +dnfAssumeValue :: forall a. Ord a => a -> Bool -> PredDNF a -> Maybe (PredDNF a) +-- ^ `Nothing` corresponds to @⊤@ +dnfAssumeValue var val + = fmap (PredDNF . Set.fromList) . sequence + . foldMapOf (_dnfTerms . folded) (pure @[] . fromNullable . Set.filter (not . agrees) . toNullable) + . over _dnfTerms (Set.filter $ none disagrees . toNullable) + where + agrees, disagrees :: PredLiteral a -> Bool + agrees PLVariable{..} = plVar == var && val + agrees PLNegated{..} = plVar == var && not val + disagrees PLNegated{..} = plVar == var && val + disagrees PLVariable{..} = plVar == var && not val + + data UserGroupName = UserGroupMetrics | UserGroupCustom { userGroupCustomName :: CI Text } diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 162952d2e..8abaec90a 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -15,8 +15,6 @@ import qualified Data.Aeson.Types as Aeson import Database.Persist.Sql -import Data.Word.Word24 - import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text @@ -55,26 +53,9 @@ 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) + deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix + , PersistField, PersistFieldSql, Random + ) instance FromJSON Pseudonym where parseJSON v@(Aeson.Number _) = do diff --git a/src/Settings.hs b/src/Settings.hs index cd37a38c5..e88fbbdc7 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -61,7 +61,7 @@ import qualified System.FilePath as FilePath import Jose.Jwt (JwtEncoding(..)) import System.FilePath.Glob -import Handler.Utils.Submission.TH +import System.FilePath.Glob.TH import qualified Web.ServerSession.Core as ServerSession @@ -180,6 +180,8 @@ data AppSettings = AppSettings , appPersistentTokenBuckets :: TokenBucketIdent -> TokenBucketConf + , appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime + , appInitialInstanceID :: Maybe (Either FilePath UUID) , appRibbon :: Maybe Text } deriving Show @@ -524,6 +526,8 @@ instance FromJSON AppSettings where appUploadCacheConf <- assertM (not . null . Minio.connectHost) <$> o .:? "upload-cache" appUploadCacheBucket <- o .: "upload-cache-bucket" + appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire" + return AppSettings{..} makeClassy_ ''AppSettings @@ -539,7 +543,10 @@ widgetFileSettings = def submissionBlacklist :: [Pattern] -submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") +submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist") + +personalisedSheetFilesCollatable :: Map Text Pattern +personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate") -- The rest of this file contains settings which rarely need changing by a -- user. diff --git a/src/System/FilePath/Glob/TH.hs b/src/System/FilePath/Glob/TH.hs new file mode 100644 index 000000000..6df102254 --- /dev/null +++ b/src/System/FilePath/Glob/TH.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module System.FilePath.Glob.TH + ( patternFile, patternFile' + ) where + +import ClassyPrelude.Yesod +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..), unsafeTExpCoerce) + +import System.FilePath.Glob + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import qualified Data.Map.Strict as Map + +deriving instance Lift CompOptions + +patternFile' :: CompOptions -> FilePath -> TExpQ (Map Text Pattern) +patternFile' opts file = do + qAddDependentFile file + patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file + unsafeTExpCoerce . appE [e|Map.fromList|] . listE $ map (\pat'@(Text.unpack -> pat) -> [e|(pat', compileWith opts pat)|]) patternStrings + +patternFile :: CompOptions -> FilePath -> TExpQ [Pattern] +patternFile opts file = [||Map.elems $$(patternFile' opts file)||] + +isComment :: Text -> Bool +isComment line = or + [ commentSymbol `Text.isPrefixOf` Text.stripStart line + , Text.null $ Text.strip line + ] + where + commentSymbol = "$#" diff --git a/src/Utils.hs b/src/Utils.hs index 4a6d66df4..2b7fe291b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -110,6 +110,9 @@ import qualified Data.Text.Lazy.Builder as Builder import Unsafe.Coerce +import System.FilePath as Utils (addExtension, isExtensionOf) +import System.FilePath (dropDrive) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -441,6 +444,23 @@ dropWhileM p xs' = bool (return xs') (dropWhileM p xs) =<< p x | otherwise = return xs' + +isSubsequenceOfBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +isSubsequenceOfBy _ [] _ = True +isSubsequenceOfBy _ _ [] = False +isSubsequenceOfBy cmp a@(x:a') (y:b) + | x `cmp` y = isSubsequenceOfBy cmp a' b + | otherwise = isSubsequenceOfBy cmp a b + +withoutSubsequenceBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b] +withoutSubsequenceBy cmp = go [] + where go acc [] b = Just $ reverse acc ++ b + go _ _ [] = Nothing + go acc a@(x:a') (y:b) + | x `cmp` y = go acc a' b + | otherwise = go (y:acc) a b + + ---------- -- Sets -- ---------- @@ -859,6 +879,9 @@ takeWhileTime maxT = do let tDelta = now `diffUTCTime` sTime return $ tDelta < maxT +runPeekN :: forall o m n. (Integral n, Monad m) => n -> ConduitT () o m () -> m (ConduitT () o m (), [o]) +runPeekN n src = over (mapped . _1) unsealConduitT $ src $$+ peekN n + ----------------- -- Alternative -- ----------------- @@ -1189,3 +1212,15 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson. Aeson.Index idx + +-------------- +-- FilePath -- +-------------- + +ensureExtension :: String -> FilePath -> FilePath +ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName + +infixr 4 + +() :: FilePath -> FilePath -> FilePath +dir file = dir dropDrive file diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 284a4a890..0138a93c4 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -2,7 +2,7 @@ module Utils.Files ( sinkFile, sinkFiles , sinkFile', sinkFiles' , FileUploads - , replaceFileReferences + , replaceFileReferences, replaceFileReferences' ) where import Import.NoFoundation @@ -19,7 +19,6 @@ import qualified Data.ByteArray as ByteArray import qualified Data.Map.Lazy as Map import qualified Data.Set as Set -import Control.Monad.Trans.State.Lazy (execStateT) import Control.Monad.State.Class (modify) import Database.Persist.Sql (deleteWhereCount) @@ -81,19 +80,17 @@ sinkFile' file residual = do type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) () -replaceFileReferences :: ( MonadHandler m, MonadThrow m - , HandlerSite m ~ UniWorX - , HasFileReference record - , PersistEntityBackend record ~ SqlBackend - ) - => (FileReferenceResidual record -> [Filter record]) - -> FileReferenceResidual record - -> FileUploads - -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ -replaceFileReferences mkFilter residual fs = do +replaceFileReferences' :: ( MonadIO m, MonadThrow m + , IsFileReference record + , PersistEntityBackend record ~ SqlBackend + ) + => (FileReferenceResidual record -> [Filter record]) + -> FileReferenceResidual record + -> ConduitT FileReference Void (SqlPersistT m) (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ +replaceFileReferences' mkFilter residual = do let resFilter = mkFilter residual - oldFiles <- Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter [] + oldFiles <- lift $ Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter [] let oldFiles' = setOf (folded . folded) oldFiles let @@ -111,8 +108,19 @@ replaceFileReferences mkFilter residual fs = do fId <- lift $ insert fRef' modify $ Map.alter (Just . maybe (Set.singleton fId) (Set.insert fId)) fRef - changes <- fmap (setOf $ folded . folded) . flip execStateT oldFiles . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert + changes <- fmap (setOf $ folded . folded) . execStateC oldFiles $ C.mapM_ finsert - deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ] + lift . deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ] return (oldFiles', changes) + +replaceFileReferences :: ( MonadHandler m, MonadThrow m + , HandlerSite m ~ UniWorX + , IsFileReference record + , PersistEntityBackend record ~ SqlBackend + ) + => (FileReferenceResidual record -> [Filter record]) + -> FileReferenceResidual record + -> FileUploads + -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ +replaceFileReferences mkFilter residual fs = runConduit $ transPipe liftHandler fs .| replaceFileReferences' mkFilter residual diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e6cb66f9b..e401f2db7 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -85,6 +85,7 @@ data Icon | IconMissingAllocationPriority | IconFileUploadSession | IconStandaloneFieldError + | IconFileUser deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text @@ -148,6 +149,7 @@ iconText = \case IconMissingAllocationPriority -> "empty-set" IconFileUploadSession -> "file-upload" IconStandaloneFieldError -> "exclamation" + IconFileUser -> "file-user" instance Universe Icon instance Finite Icon diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 4dae872f8..8edf94784 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -180,8 +180,6 @@ makePrisms ''OccurrenceException makeLenses_ ''Occurrences -makeLenses_ ''PredDNF - makeLenses_ ''Invitation makeLenses_ ''ExamBonusRule @@ -233,6 +231,8 @@ makeLenses_ ''ExternalExamResult makeLenses_ ''Rating makeLenses_ ''Rating' +makeLenses_ ''FallbackPersonalisedSheetFilesKey + -- makeClassy_ ''Load -------------------------- diff --git a/src/Utils/Memo.hs b/src/Utils/Memo.hs new file mode 100644 index 000000000..2c5af621c --- /dev/null +++ b/src/Utils/Memo.hs @@ -0,0 +1,25 @@ +module Utils.Memo + ( evalMemoStateC + ) where + +import ClassyPrelude +import Data.Conduit +import Data.Conduit.Lift (evalStateC) + +import Control.Monad.Memo +import Control.Monad.Trans.State.Strict (StateT) +import qualified Control.Monad.State.Class as State + + +evalMemoStateC :: forall m s k v i o r. + Monad m + => s -> ConduitT i o (MemoStateT s k v m) r -> ConduitT i o m r +evalMemoStateC initSt = evalStateC initSt . transPipe runMemoStateT' + where + runMemoStateT' :: forall a. + MemoStateT s k v m a + -> StateT s m a + runMemoStateT' act = do + cache <- State.get + (res, cache') <- lift $ runMemoStateT act cache + res <$ State.put cache' diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index d6baeeaf6..2b082d6b9 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -4,6 +4,8 @@ import Import.NoFoundation import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Data.Conduit.Combinators as C + -- DB Queries for Sheets that are used in several places sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName) @@ -46,60 +48,91 @@ sheetOldUnassigned tid ssh csh = do _ -> error "SQL Query with limit 1 returned more than one result" -- | Return a specfic file from a `Sheet` -sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity SheetFile) (SqlPersistT m) () -sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do - -- Restrict to consistent rows that correspond to each other - E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) - -- filter to requested file - E.where_ ((sFile E.^. SheetFileTitle E.==. E.val title) - E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) - E.&&. (sheet E.^. SheetName E.==. E.val shn ) - E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseSchool E.==. E.val ssh ) - E.&&. (course E.^. CourseTerm E.==. E.val tid ) - ) - -- return file entity - return sFile +sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> SheetFileType -> FilePath -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) () +sheetFileQuery tid ssh csh shn muid sft title = sqlSelect .| C.map toEither + where + sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do + -- Restrict to consistent rows that correspond to each other + E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType + E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle + E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet + E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid + E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + -- filter to requested file + E.where_ $ (sFile E.?. SheetFileTitle E.==. E.justVal title E.||. psFile E.?. PersonalisedSheetFileTitle E.==. E.justVal title) + E.&&. (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft) + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser) + -- return file entity + return (sFile, psFile) + toEither (_, Just psFile) = Right psFile + toEither (Just sFile, _) = Left sFile + toEither _ = error "sqlSelect returned incoherent result" -- | Return all files of a certain `SheetFileType` for a `Sheet` -sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity SheetFile) (SqlPersistT m) () -sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do - -- Restrict to consistent rows that correspond to each other - E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) - -- filter to requested file - E.where_ ((sheet E.^. SheetName E.==. E.val shn ) - E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseSchool E.==. E.val ssh ) - E.&&. (course E.^. CourseTerm E.==. E.val tid ) - E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) - ) - -- return file entity - return sFile +sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> SheetFileType -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) () +sheetFilesAllQuery tid ssh csh shn muid sft = sqlSelect .| C.map toEither + where + sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do + -- Restrict to consistent rows that correspond to each other + E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType + E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle + E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet + E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid + E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + -- filter to requested file + E.where_ $ (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft) + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser) + -- return file entity + return (sFile, psFile) + toEither (_, Just psFile) = Right psFile + toEither (Just sFile, _) = Left sFile + toEither _ = error "sqlSelect returned incoherent result" -- | Return all files of certain `SheetFileTypes` for a `Sheet` -sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity SheetFile) (SqlPersistT m) () -sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do - -- Restrict to consistent rows that correspond to each other - E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) - -- filter to requested file - E.where_ ((sheet E.^. SheetName E.==. E.val shn ) - E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseSchool E.==. E.val ssh ) - E.&&. (course E.^. CourseTerm E.==. E.val tid ) - E.&&. (sFile E.^. SheetFileType `E.in_` E.valList sfts ) - ) - -- return file entity - return sFile +sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> [SheetFileType] -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) () +sheetFilesSFTsQuery tid ssh csh shn muid sfts = sqlSelect .| C.map toEither + where + sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do + -- Restrict to consistent rows that correspond to each other + E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType + E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle + E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet + E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid + E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId) + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + -- filter to requested file + E.where_ $ (sFile E.?. SheetFileType `E.in_` E.justValList sfts E.||. psFile E.?. PersonalisedSheetFileType `E.in_` E.justValList sfts) + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser) + -- return file entity + return (sFile, psFile) + toEither (_, Just psFile) = Right psFile + toEither (Just sFile, _) = Left sFile + toEither _ = error "sqlSelect returned incoherent result" -- | Check whether a sheet has any files for a given file type -hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> SheetFileType -> E.SqlExpr (E.Value Bool) -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 )) +hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> E.SqlExpr (E.Value (Maybe UserId)) -> SheetFileType -> E.SqlExpr (E.Value Bool) +hasSheetFileQuery sheet muid sft = sheetFile E.||. personalisedSheetFile + where sheetFile = E.exists . E.from $ \sFile -> + E.where_ $ sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId + E.&&. sFile E.^. SheetFileType E.==. E.val sft + personalisedSheetFile = E.exists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.&&. psFile E.^. PersonalisedSheetFileType E.==. E.val sft + E.&&. E.just (psFile E.^. PersonalisedSheetFileUser) E.==. muid diff --git a/templates/course-participants.hamlet b/templates/course-participants.hamlet index 53460bdda..963e9fe54 100644 --- a/templates/course-participants.hamlet +++ b/templates/course-participants.hamlet @@ -4,4 +4,4 @@ $# $# participantTable : widget table ^{participantTable} -_{MsgCourseMembersCountOf numParticipants (courseCapacity course)}. +_{MsgCourseMembersCountOf numParticipants courseCapacity}. diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index 258cfa00d..ea82247c6 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -4,6 +4,8 @@ $newline never ^{formatGregorianW 2020 08 10}

    +
  • + Kursverwalter können pro Teilnehmer personalisierte Übungsblatt-Dateien hinterlegen.
  • Kurse haben nun einen Sichtbarkeitszeitraum. diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index 778bd712d..fb9f04bbe 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -4,6 +4,8 @@ $newline never ^{formatGregorianW 2020 08 10}
      +
    • + Course administrators can now assign personalised exercise sheet files to course participants.
    • Courses now have a visibility period. diff --git a/templates/messages/personalisedSheetFilesIgnored.hamlet b/templates/messages/personalisedSheetFilesIgnored.hamlet new file mode 100644 index 000000000..c24725cec --- /dev/null +++ b/templates/messages/personalisedSheetFilesIgnored.hamlet @@ -0,0 +1,9 @@ +$newline never +_{MsgPersonalisedSheetFilesIgnoredIntro} +
        + $forall fPath <- uncollated +
      • + #{fPath} + $forall (ptn, Sum count) <- toList collatedL +
      • + #{count} × #{ptn} diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 9d76945de..a6868a364 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -71,10 +71,14 @@ $maybe marktxt <- markingText

        #{marktxt} +$if fromMaybe False mMissingPersonalisedFiles +

        + ^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesMissingPersonalisedFiles)} +$elseif fromMaybe False mMissingExamRegistration +
        + ^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesExamRegistrationRequired)} + $if hasFiles

        ^{simpleLinkI (SomeMessage MsgSheetFiles) zipLink} ^{fileTable} -$elseif fromMaybe False mMissingExamRegistration -
        - ^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesExamRegistrationRequired)} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9e38ef8e2..de309a787 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -581,6 +581,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now adhoc feste <- insert Sheet @@ -599,6 +600,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now feste keine <- insert Sheet @@ -617,6 +619,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now keine void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing CourseParticipantActive) @@ -837,6 +840,7 @@ fillDb = do , sheetAutoDistribute = True , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } void . insert $ SheetEdit jost now shId when (submissionModeCorrector sheetSubmissionMode) $ @@ -1076,6 +1080,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } manyUsers' <- shuffleM $ take 1024 manyUsers groupSizes <- getRandomRs (1, 3) diff --git a/test/Handler/Sheet/PersonalisedFilesSpec.hs b/test/Handler/Sheet/PersonalisedFilesSpec.hs new file mode 100644 index 000000000..64b5e1dc1 --- /dev/null +++ b/test/Handler/Sheet/PersonalisedFilesSpec.hs @@ -0,0 +1,113 @@ +module Handler.Sheet.PersonalisedFilesSpec where + +import TestImport + +import Utils.Files +import Handler.Sheet.PersonalisedFiles + +import qualified Yesod.Persist as Yesod + +import ModelSpec () + +import Data.Universe.Class + +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Control.Lens.Extras +import Control.Monad.Trans.Maybe + +import qualified Crypto.Hash as Crypto (hash) + +import System.FilePath (dropDrive) + +import Data.Time.Clock (diffUTCTime) +import Data.Char (chr) + +import Database.Persist.Sql (transactionUndo) + + +instance Arbitrary (FileReferenceResidual PersonalisedSheetFile) where + arbitrary = PersonalisedSheetFileResidual + <$> arbitrary + <*> arbitrary + <*> elements [ sfType | sfType <- universeF, sfType /= SheetMarking ] + +instance Arbitrary PersonalisedSheetFilesDownloadAnonymous where + arbitrary = elements universeF + + +spec :: Spec +spec = withApp . describe "Personalised sheet file zip encoding" $ do + it "roundtrips" . replicateM_ 10 . runHandler . Yesod.runDB $ do + term <- liftIO $ generate arbitrary + tid <- insert term + school <- liftIO $ generate arbitrary + ssh <- insert school + course <- liftIO $ generate arbitrary <&> \c -> c { courseTerm = tid, courseSchool = ssh } + cid <- insert course + sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid } + shid <- insert sheet + + sheetFiles' <- liftIO . generate . listOf $ scale (`div` 2) arbitrary + sheetFiles <- fmap catMaybes . forM sheetFiles' $ \(f', res') -> runMaybeT $ do + let f = f' { fileTitle = filter (/= chr 0) $ fileTitle f' } -- PostgreSQL doesn't like to store NUL-bytes in text + guard . not . null . dropDrive $ fileTitle f + + uid <- + let userLoop = do + user <- liftIO $ generate arbitrary + lift (insertUnique user) >>= maybe userLoop return + in userLoop + let res = res' { personalisedSheetFileResidualSheet = shid, personalisedSheetFileResidualUser = uid } + fRef <- lift (sinkFile f :: DB FileReference) + now <- liftIO getCurrentTime + void . lift . insert $ CourseParticipant cid (personalisedSheetFileResidualUser res) now Nothing Nothing CourseParticipantActive + void . lift . insert $ _FileReference # (fRef, res) + return (f, res) + + anonMode <- liftIO $ generate arbitrary + + let + fpL :: Lens' (Either PersonalisedSheetFile File) FilePath + fpL = lens (either personalisedSheetFileTitle fileTitle) $ \f' path -> case f' of + Left pf -> Left pf { personalisedSheetFileTitle = path } + Right f -> Right f { fileTitle = path } + isDirectory = either (is _Nothing . personalisedSheetFileContent) (is _Nothing . fileContent) + + recoveredFiles <- runConduit $ + sourcePersonalisedSheetFiles cid (Just shid) Nothing anonMode + .| resolvePersonalisedSheetFiles fpL isDirectory cid shid + .| C.foldMap pure + + let + checkFile :: Either (PersonalisedSheetFileUnresolved (Either PersonalisedSheetFile File)) (Either PersonalisedSheetFile File, FileReferenceResidual PersonalisedSheetFile) + -> (File, FileReferenceResidual PersonalisedSheetFile) + -> Bool + checkFile (Left _) _ + = False + checkFile (Right (recFile, recResidual)) (file, residual) + = recResidual == residual + && case recFile of + Right f -> file == f + Left pf -> dropDrive (fileTitle file) == dropDrive (personalisedSheetFileTitle pf) + && abs (fileModified file `diffUTCTime` personalisedSheetFileModified pf) < 1e-6 -- Precision is a PostgreSQL limitation + && fmap Crypto.hash (fileContent file) == personalisedSheetFileContent pf + + errors = go [] sheetFiles recoveredFiles + where go acc xs [] = reverse acc ++ map Left xs + go acc [] ys = reverse acc ++ map Right ys + go acc xs (y:ys) + | (xs', _ : xs'') <- break (checkFile y) xs + = go acc (xs' ++ xs'') ys + | is (_Left . _PSFUnresolved) y + , fromMaybe False $ previews (_Left . _PSFUnresolved . _Right . _fileTitle) ("meta-informationen" `isInfixOf`) y -- DEBUG; remove once _PSFUnresolvedCollatable works + = go acc xs ys + | isn't (_Left . _PSFUnresolved) y + , isn't _Right y + = go acc xs ys + | otherwise = go (Right y : acc) xs ys + + unless (null errors) . liftIO $ + expectationFailure $ show recoveredFiles ++ " does not match " ++ show sheetFiles ++ ": " ++ show errors + + transactionUndo diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 50edc02e6..d8d1cf5a4 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -32,6 +32,10 @@ import Data.Scientific import Utils.Lens hiding (elements) import qualified Data.Char as Char +import Data.Word.Word24 + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Lazy as LBS instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where @@ -280,6 +284,9 @@ instance Arbitrary CsvPreset where instance Arbitrary Sex where arbitrary = genericArbitrary +instance Arbitrary Word24 where + arbitrary = arbitraryBoundedRandom + spec :: Spec @@ -371,6 +378,8 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @CsvPreset) [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] + lawsCheckHspec (Proxy @Word24) + [ persistFieldLaws, jsonLaws, binaryLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -405,6 +414,23 @@ spec = do describe "CsvOptions" $ it "json-decodes from empty object" . example $ Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions) + describe "Word24" $ do + it "encodes to the expected length" . property $ + \w -> olength (Binary.encode (w :: Word24)) == 3 + it "encodes some examples correctly" $ do + let decode' inp = case Binary.decodeOrFail inp of + Right (unc, _, res) + | null unc -> Just res + _other + -> Nothing + encEx w str = example $ do + Binary.encode (w :: Word24) `shouldBe` LBS.pack str + decode' (LBS.pack str) `shouldBe` Just w + encEx 1 [0, 0, 1] + encEx 256 [0, 1, 0] + encEx 65536 [1, 0, 0] + encEx 65537 [1, 0, 1] + encEx 197121 [3, 2, 1] termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 148c8c064..13d36e312 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -65,6 +65,7 @@ instance Arbitrary Sheet where <*> arbitrary <*> arbitrary <*> return Nothing + <*> arbitrary shrink = genericShrink instance Arbitrary Tutorial where diff --git a/test/Test/QuickCheck/Classes/Binary.hs b/test/Test/QuickCheck/Classes/Binary.hs index 1261ce44b..54021a4d1 100644 --- a/test/Test/QuickCheck/Classes/Binary.hs +++ b/test/Test/QuickCheck/Classes/Binary.hs @@ -12,6 +12,11 @@ import Data.Binary.Put binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws binaryLaws _ = Laws "Binary" - [ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a) - , ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as)) + [ ("Partial Isomorphism", property $ \(a :: a) -> decode' (encode a) === Just a) + , ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) === runPut (put as)) ] + where decode' inp = case decodeOrFail inp of + Right (unc, _, res) + | null unc -> Just res + _other + -> Nothing