From 9ee44aa2f1aaa91c898b216f0dba58017122c75f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 28 Jul 2020 19:14:15 +0200 Subject: [PATCH 01/13] feat(personalised-sheet-files): introduce routes & work on crypto --- config/settings.yml | 3 + messages/uniworx/de-de-formal.msg | 21 +- models/sheets.model | 16 ++ package.yaml | 1 + routes | 2 + src/CryptoID.hs | 20 ++ src/CryptoID/TH.hs | 13 ++ src/Data/Word/Word24/Instances.hs | 58 ++++++ src/Foundation.hs | 29 +++ src/Handler/Course.hs | 1 + src/Handler/Sheet.hs | 1 + src/Handler/Sheet/Edit.hs | 15 +- src/Handler/Sheet/Form.hs | 30 ++- src/Handler/Sheet/New.hs | 1 + src/Handler/Sheet/PersonalisedFiles.hs | 220 +++++++++++++++++++++ src/Handler/Utils.hs | 13 +- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/Submission.hs | 4 + src/Import/NoModel.hs | 3 + src/Jobs.hs | 1 + src/Jobs/Crontab.hs | 11 ++ src/Jobs/Handler/PersonalisedSheetFiles.hs | 15 ++ src/Jobs/Types.hs | 1 + src/Model.hs | 44 ++++- src/Model/Types/Submission.hs | 25 +-- src/Settings.hs | 4 + src/Utils.hs | 3 + src/Utils/Lens.hs | 2 + stack.yaml | 2 + stack.yaml.lock | 14 ++ test/Database/Fill.hs | 5 + test/Model/TypesSpec.hs | 26 +++ test/ModelSpec.hs | 1 + test/Test/QuickCheck/Classes/Binary.hs | 9 +- 34 files changed, 578 insertions(+), 38 deletions(-) create mode 100644 src/Data/Word/Word24/Instances.hs create mode 100644 src/Handler/Sheet/PersonalisedFiles.hs create mode 100644 src/Jobs/Handler/PersonalisedSheetFiles.hs diff --git a/config/settings.yml b/config/settings.yml index 8f21d7277..647829302 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -227,3 +227,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/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index e54dde4cd..92ca768d3 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1340,6 +1340,8 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten MenuAllocationCompute: Platzvergabe berechnen MenuAllocationAccept: Platzvergabe akzeptieren MenuFaq: FAQ +MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen +MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1411,6 +1413,8 @@ BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren BreadcrumbMessageHide: Verstecken BreadcrumbFaq: FAQ +BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen +BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -2664,4 +2668,19 @@ SubmissionDoneNever: Nie SubmissionDoneByFile: Je nach Bewertungsdatei 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. \ No newline at end of file +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 Verzeichnise der Kursteilnehmer ein und laden sie das Archiv dann hier wieder hoch. +SheetPersonalisedFilesKeepExisting: Bestehende Dateien behalten +SheetPersonalisedFilesKeepExistingTip: Sollen die hier neu hochgeladenen personalisierten Dateien zu den bestehenden (sofern vorhanden) hinzugefügt werden? Ansonsten werden die bestehenden Dateien vollständig durch die neu hochgeladenen ersetzt. +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 \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index 6b6112db0..f345db612 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,18 @@ 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 + +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 b1c6e1af3..7679bf4d4 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ dependencies: - cryptonite-conduit - saltine - base64-bytestring + - base32 - memory - http-api-data - profunctors diff --git a/routes b/routes index 54e9af960..2986409bb 100644 --- a/routes +++ b/routes @@ -165,6 +165,7 @@ /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 !materials !corrector !tutor @@ -214,6 +215,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 a6cfb4d62..17b75dc85 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/Foundation.hs b/src/Foundation.hs index 284fe8ae1..cb8817de4 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2548,6 +2548,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 @@ -2560,6 +2561,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 @@ -3982,6 +3985,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/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/Sheet.hs b/src/Handler/Sheet.hs index d174152f5..6e869062b 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/Edit.hs b/src/Handler/Sheet/Edit.hs index c7cde432e..4261a5849 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 (Just 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 82a710a6f..f8dffc12b 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,6 +45,12 @@ 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 @@ -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,25 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template) where + makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) + makeSheetPersonalisedFilesForm template' = do + templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do + Sheet{..} <- MaybeT . fmap join $ traverse get msId + Course{..} <- MaybeT $ get cId + let downloadRoute = CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + guardM $ hasReadAccessTo downloadRoute + messageIconWidget Info IconFileZip + [whamlet| + $newline never + _{MsgSheetPersonalisedFilesDownloadTemplateHere}
+ ^{modal (i18n MsgMenuSheetPersonalisedFiles) (Left (SomeRoute downloadRoute))} + |] + 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/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..c335436dc --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -0,0 +1,220 @@ +{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds -Wno-error=deprecations #-} + +module Handler.Sheet.PersonalisedFiles + ( sinkPersonalisedSheetFiles + , getSPersonalFilesR, getCPersonalFilesR + , PersonalisedSheetFilesKeyException(..) + ) where + +import Import + +import Handler.Utils + +import qualified Data.Conduit.Combinators as C + +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 Text.Unidecode (unidecode) +import Data.Char (isAlphaNum) + +import GHC.Stack + + +resolvePersonalisedSheetFiles + :: forall a m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Lens' a FilePath + -> CourseId + -> Maybe SheetId + -> ConduitT a (Either a (a, FileReferenceResidual PersonalisedSheetFile)) m () +resolvePersonalisedSheetFiles fpL _cid _mbsid = do + C.mapM $ \fRef -> maybeT (return $ Left fRef) . fmap (Right . swap) . flip runStateT fRef . zoom fpL $ do + error "not implemented" :: StateT FilePath (MaybeT m) (FileReferenceResidual PersonalisedSheetFile) + + +sinkPersonalisedSheetFiles :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => CourseId + -> Maybe SheetId + -> Bool -- ^ Keep existing? + -> ConduitT FileReference Void (SqlPersistT m) () +sinkPersonalisedSheetFiles cid mbsid _keep + = resolvePersonalisedSheetFiles _fileReferenceTitle cid mbsid + .| error "not implemented" + + +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 + +sourcePersonalisedSheetFiles :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + , MonadRandom m + ) + => CourseId + -> Maybe SheetId + -> PersonalisedSheetFilesDownloadAnonymous + -> ConduitT () (Either PersonalisedSheetFile File) (SqlPersistT m) () +sourcePersonalisedSheetFiles cId mbsid 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 + return (courseParticipant, personalisedSheetFile) + + toRefs = awaitForever $ \(Entity _ 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 + } + -- TODO: meta.yml + _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 + , HasCallStack + ) + => 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 + traceM $ "newPersonalisedFilesKey: " <> prettyCallStack callStack + + let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey) + loop n = do + traceM "insertUnique" + 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 :: CourseId -> Maybe SheetId -> Maybe Word24 -> DB 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 :: FilePath -> [(Maybe Word24, CryptoFileNameUser)] +resolvePersonalisedFilesDirectory = error "not implemented" + + +getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSPersonalFilesR = error "not implemented" + +getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent +getCPersonalFilesR tid ssh csh = do + cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCoursePersonalisedSheetFilesArchiveName tid ssh csh + serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId Nothing PersonalisedSheetFilesDownloadAnonymous -- TODO: get Form for anonymisiation diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index de308ce3d..b89a997db 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 86e56b95a..39c639704 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -972,7 +972,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/Submission.hs b/src/Handler/Utils/Submission.hs index 7af8f3d57..6a4daa12f 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/Import/NoModel.hs b/src/Import/NoModel.hs index bbb67eb6b..98e18047d 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -164,6 +164,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 Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) @@ -184,6 +185,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 5faf681e0..e9e8a17c9 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -61,6 +61,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 9dcb04933..50308d717 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 7b36c2801..c2e97cf3f 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -81,6 +81,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 fcd41546b..f33d6a3ce 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -122,14 +122,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,9 +137,45 @@ instance HasFileReference SheetFile where } ) - fileReferenceTitleField = SheetFileTitle - fileReferenceContentField = SheetFileContent + fileReferenceTitleField = SheetFileTitle + fileReferenceContentField = SheetFileContent fileReferenceModifiedField = SheetFileModified + +instance HasFileReference PersonalisedSheetFile where + data FileReferenceResidual PersonalisedSheetFile = PersonalisedSheetFileResidual + { personalisedSheetFileResidualSheet :: SheetId + , personalisedSheetFileResidualUser :: UserId + , personalisedSheetFileResidualType :: SheetFileType + } + + _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 + } + ) + + fileReferenceTitleField = PersonalisedSheetFileTitle + fileReferenceContentField = PersonalisedSheetFileContent + fileReferenceModifiedField = PersonalisedSheetFileModified instance HasFileReference SubmissionFile where data FileReferenceResidual SubmissionFile = SubmissionFileResidual diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index b8ace9549..a2dd89d99 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 8a3995342..8198bd9f3 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -177,6 +177,8 @@ data AppSettings = AppSettings , appPersistentTokenBuckets :: TokenBucketIdent -> TokenBucketConf + , appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime + , appInitialInstanceID :: Maybe (Either FilePath UUID) , appRibbon :: Maybe Text } deriving Show @@ -555,6 +557,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 diff --git a/src/Utils.hs b/src/Utils.hs index 3181e52d5..42bbcf070 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -855,6 +855,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 -- ----------------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a08246da3..667b2f782 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -233,6 +233,8 @@ makeLenses_ ''ExternalExamResult makeLenses_ ''Rating makeLenses_ ''Rating' +makeLenses_ ''FallbackPersonalisedSheetFilesKey + -- makeClassy_ ''Load -------------------------- diff --git a/stack.yaml b/stack.yaml index fc8dcaefa..ea5f15523 100644 --- a/stack.yaml +++ b/stack.yaml @@ -119,6 +119,8 @@ extra-deps: - unordered-containers-0.2.11.0 - base64-bytestring-1.1.0.0 + - base32-0.2.0.0 + - ghc-byteorder-4.11.0.0.10 resolver: lts-15.12 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 2219201a5..93a33c80d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -346,6 +346,20 @@ packages: sha256: 9ade5b5911df97c37b249b84f123297049f19578cae171c647bf47683633427c original: hackage: base64-bytestring-1.1.0.0 +- completed: + hackage: base32-0.2.0.0@sha256:459f0ba6412d58adf1d6ab68d5dc68afddc9f65c69ad564c0a9643d5d8a7e96e,2608 + pantry-tree: + size: 1935 + sha256: 10c0a5a0a1d4c40b41f0190cf80b114fb527caf7458feec819d87ccfe41317cb + original: + hackage: base32-0.2.0.0 +- completed: + hackage: ghc-byteorder-4.11.0.0.10@sha256:5ee4a907279bfec27b0f9de7b8fba4cecfd34395a0235a7784494de70ad4e98f,1535 + pantry-tree: + size: 169 + sha256: 54a4636f72c3b9eff7f081714cb1a7b809fc1f3b2e239caaf0d65d79aa9cb56f + original: + hackage: ghc-byteorder-4.11.0.0.10 snapshots: - completed: size: 494635 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bd02521e3..4420fd70e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -579,6 +579,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now adhoc feste <- insert Sheet @@ -597,6 +598,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now feste keine <- insert Sheet @@ -615,6 +617,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) @@ -827,6 +830,7 @@ fillDb = do , sheetAutoDistribute = True , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } void . insert $ SheetEdit jost now shId when (submissionModeCorrector sheetSubmissionMode) $ @@ -1062,6 +1066,7 @@ fillDb = do , sheetAutoDistribute = False , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True } manyUsers' <- shuffleM $ take 1024 manyUsers groupSizes <- getRandomRs (1, 3) 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 From ed5fb6e218097250f197b7795d448bbfe460bf99 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 Aug 2020 09:57:53 +0200 Subject: [PATCH 02/13] feat(personalised-sheet-files): finish upload functionality TODO: Interaction of course participants with personalised files --- .../src/utils/form/navigate-away-prompt.js | 4 + messages/uniworx/de-de-formal.msg | 8 +- models/sheets.model | 1 + package.yaml | 1 + src/Foundation/I18n.hs | 24 ++ src/Handler/Sheet/Edit.hs | 2 +- src/Handler/Sheet/Form.hs | 6 +- src/Handler/Sheet/PersonalisedFiles.hs | 247 +++++++++++++++--- src/Handler/Sheet/PersonalisedFiles/Meta.hs | 131 ++++++++++ src/Handler/Sheet/PersonalisedFiles/Types.hs | 19 ++ src/Handler/Utils/Rating.hs | 2 - src/Handler/Utils/Table/Pagination.hs | 1 - src/Model.hs | 15 +- src/Utils.hs | 32 +++ src/Utils/Files.hs | 38 +-- src/Utils/Memo.hs | 25 ++ .../personalisedSheetFilesIgnored.hamlet | 9 + test/Handler/Sheet/PersonalisedFilesSpec.hs | 114 ++++++++ 18 files changed, 613 insertions(+), 66 deletions(-) create mode 100644 src/Handler/Sheet/PersonalisedFiles/Meta.hs create mode 100644 src/Handler/Sheet/PersonalisedFiles/Types.hs create mode 100644 src/Utils/Memo.hs create mode 100644 templates/messages/personalisedSheetFilesIgnored.hamlet create mode 100644 test/Handler/Sheet/PersonalisedFilesSpec.hs 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 716a77bb2..86d879aa0 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2686,6 +2686,12 @@ 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: Soll das Archiv von personalisierten Dateien anonymisiert werden (es enthält dann keinerlei sofort persönlich 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: AdminCrontabNotGenerated: (Noch) keine Crontab generiert CronMatchAsap: ASAP -CronMatchNone: Nie +CronMatchNone: Nie \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index f345db612..f54426040 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -53,6 +53,7 @@ PersonalisedSheetFile content FileContentReference Maybe modified UTCTime UniquePersonalisedSheetFile sheet user type title + deriving Eq Ord Read Show Generic Typeable FallbackPersonalisedSheetFilesKey course CourseId diff --git a/package.yaml b/package.yaml index ebf1a9543..5b9412b43 100644 --- a/package.yaml +++ b/package.yaml @@ -309,6 +309,7 @@ tests: - quickcheck-instances - generic-arbitrary - http-types + - yesod-persistent ghc-options: - -fno-warn-orphans - -threaded diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ce5ead5ee..3178424a9 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/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 4261a5849..ba4ba38f5 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF runConduit $ maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) - .| sinkPersonalisedSheetFiles cid (Just sid) (fromMaybe False $ spffFilesKeepExisting <$> 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 f8dffc12b..e116b784f 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -102,9 +102,11 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) makeSheetPersonalisedFilesForm template' = do templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do - Sheet{..} <- MaybeT . fmap join $ traverse get msId + mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId Course{..} <- MaybeT $ get cId - let downloadRoute = CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + let downloadRoute = case mbSheet of + Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR guardM $ hasReadAccessTo downloadRoute messageIconWidget Info IconFileZip [whamlet| diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index c335436dc..4ff2c00e4 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -1,16 +1,23 @@ -{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds -Wno-error=deprecations #-} +{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds #-} module Handler.Sheet.PersonalisedFiles ( sinkPersonalisedSheetFiles , getSPersonalFilesR, getCPersonalFilesR , PersonalisedSheetFilesKeyException(..) + , sourcePersonalisedSheetFiles, resolvePersonalisedSheetFiles + , PersonalisedSheetFileUnresolved(..) + , _PSFUnresolved, _PSFUnresolvedCollatable, _PSFUnresolvedDirectory ) where -import Import +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 @@ -31,50 +38,149 @@ 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 GHC.Stack +import qualified System.FilePath as FilePath (joinPath) + +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 a m. + :: forall m a. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m ) => Lens' a FilePath + -> (a -> Bool) -- ^ @isDirectory@ -> CourseId - -> Maybe SheetId - -> ConduitT a (Either a (a, FileReferenceResidual PersonalisedSheetFile)) m () -resolvePersonalisedSheetFiles fpL _cid _mbsid = do - C.mapM $ \fRef -> maybeT (return $ Left fRef) . fmap (Right . swap) . flip runStateT fRef . zoom fpL $ do - error "not implemented" :: StateT FilePath (MaybeT m) (FileReferenceResidual PersonalisedSheetFile) + -> 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 + if | isDirectory + -> lift $ throwE PSFUnresolvedDirectory + | otherwise + -> lift $ throwE PSFUnresolved sinkPersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m ) => CourseId - -> Maybe SheetId + -> SheetId -> Bool -- ^ Keep existing? -> ConduitT FileReference Void (SqlPersistT m) () -sinkPersonalisedSheetFiles cid mbsid _keep - = resolvePersonalisedSheetFiles _fileReferenceTitle cid mbsid - .| error "not implemented" +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') + -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 - sourcePersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -114,9 +220,10 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = 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 + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (courseParticipant, personalisedSheetFile) - toRefs = awaitForever $ \(Entity _ CourseParticipant{..}, mbPFile) -> do + toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do MsgRenderer mr <- getMsgRenderer suffix <- do sufCache <- uses _sufCache $ Map.lookup courseParticipantUser @@ -135,16 +242,20 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = do , fileModified = courseParticipantRegistration } forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType -> - yield $ Right File - { fileTitle = dirName unpack (mr $ SheetArchiveFileTypeDirectory sfType) + yield $ Right File + { fileTitle = dirName unpack (mr $ SheetArchiveFileTypeDirectory sfType) , fileContent = Nothing , fileModified = courseParticipantRegistration } - -- TODO: meta.yml + 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 + let dirName' = dirName unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType) + yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' ) pFile where _sufCache :: Lens' _ _ _sufCache = _1 @@ -167,7 +278,6 @@ newPersonalisedFilesKey :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m, MonadRandom m - , HasCallStack ) => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey) newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $ @@ -178,11 +288,9 @@ newPersonalisedFilesKey (Left cId) = do secret <- CryptoID.genKey let secret' = toStrict $ Binary.encode secret firstN <- getRandom - traceM $ "newPersonalisedFilesKey: " <> prettyCallStack callStack let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey) loop n = do - traceM "insertUnique" didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now) if | didInsert -> return (Just n, secret) @@ -195,7 +303,12 @@ newPersonalisedFilesKey (Left cId) = do -> loop $ succ n in loop firstN -getPersonalisedFilesKey :: CourseId -> Maybe SheetId -> Maybe Word24 -> DB CryptoIDKey +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 @@ -206,15 +319,73 @@ 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 :: FilePath -> [(Maybe Word24, CryptoFileNameUser)] -resolvePersonalisedFilesDirectory = error "not implemented" +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 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 = error "not implemented" +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 - archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCoursePersonalisedSheetFilesArchiveName tid ssh csh - serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId Nothing PersonalisedSheetFilesDownloadAnonymous -- TODO: get Form for anonymisiation + 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..973f18d80 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_GHC -Wno-error=redundant-constraints #-} + +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 + :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => 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/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 8ba23b315..412752087 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/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9a22aab88..5ee121828 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1094,7 +1094,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/Model.hs b/src/Model.hs index f33d6a3ce..eff1ffb82 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 @@ -84,6 +85,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 @@ -112,7 +114,7 @@ instance HasFileReference SheetFile where data FileReferenceResidual SheetFile = SheetFileResidual { sheetFileResidualSheet :: SheetId , sheetFileResidualType :: SheetFileType - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SheetFile{..} -> ( FileReference @@ -146,7 +148,7 @@ instance HasFileReference PersonalisedSheetFile where { personalisedSheetFileResidualSheet :: SheetId , personalisedSheetFileResidualUser :: UserId , personalisedSheetFileResidualType :: SheetFileType - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\PersonalisedSheetFile{..} -> ( FileReference @@ -182,7 +184,7 @@ instance HasFileReference SubmissionFile where { submissionFileResidualSubmission :: SubmissionId , submissionFileResidualIsUpdate , submissionFileResidualIsDeletion :: Bool - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SubmissionFile{..} -> ( FileReference @@ -216,6 +218,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 @@ -241,9 +244,9 @@ instance HasFileReference CourseNewsFile where 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 diff --git a/src/Utils.hs b/src/Utils.hs index 20bb69524..8a96ec3cc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -109,6 +109,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) #-} @@ -440,6 +443,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 -- ---------- @@ -1192,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 8ccf64b13..d8045f015 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 + , HasFileReference 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 + , 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 = runConduit $ transPipe liftHandler fs .| replaceFileReferences' mkFilter residual 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/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} +