feat(personalised-sheet-files): introduce routes & work on crypto

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

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.
+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

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

package.yaml

@@ -42,6 +42,7 @@ dependencies:
   - cryptonite-conduit
   - saltine
   - base64-bytestring
+  - base32
   - memory
   - http-api-data
   - profunctors

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

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

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

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] 

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

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

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

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!

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}<br />
+            ^{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

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

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

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
+serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
-  results <- runDB . runConduit $ source .| peekN 1
+
+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,

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

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

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)
 

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
 

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)

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|]

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 }

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
+  fileReferenceTitleField    = SheetFileTitle
-  fileReferenceContentField = SheetFileContent
+  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

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)
+  deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix
-
+                   , PersistField, PersistFieldSql, Random
-
+                   )
-instance PersistField Pseudonym where
-  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
-  fromPersistValue v = do
-    w <- fromPersistValue v :: Either Text Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> Left "Pseudonym out of range"
-
-instance PersistFieldSql Pseudonym where
-  sqlType _ = SqlInt32
-
-instance Random Pseudonym where
-  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
-  random = randomR (minBound, maxBound)
 
 instance FromJSON Pseudonym where
   parseJSON v@(Aeson.Number _) = do

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

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 --
 -----------------

src/Utils/Lens.hs

@@ -233,6 +233,8 @@ makeLenses_ ''ExternalExamResult
 makeLenses_ ''Rating
 makeLenses_ ''Rating'
 
+makeLenses_ ''FallbackPersonalisedSheetFilesKey
+
 -- makeClassy_ ''Load
 
 --------------------------

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

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

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)

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

test/ModelSpec.hs

@@ -65,6 +65,7 @@ instance Arbitrary Sheet where
     <*> arbitrary
     <*> arbitrary
     <*> return Nothing
+    <*> arbitrary
   shrink = genericShrink
 
 instance Arbitrary Tutorial where

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)
+  [ ("Partial Isomorphism", property $ \(a :: a) -> decode' (encode a) === Just a)
-  , ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as))
+  , ("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