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