feat(personalised-sheet-files): restrict download by exam

messages/uniworx/de-de-formal.msg

@@ -2997,6 +2997,9 @@ PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"}
 PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert:
 CourseUserHasPersonalisedSheetFilesFilter: Teilnehmer hat personalisierte Übungsblatt-Dateien für
 SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übungsblatt-Dateien
+PersonalisedSheetFilesDownloadRestrictByExamNone: Keine Einschränkung
+PersonalisedSheetFilesDownloadRestrictByExam: Nur Prüfungsteilnehmer
+PersonalisedSheetFilesDownloadRestrictByExamTip: Sollen nur personalisierte Übungsblatt-Dateien exportiert werden, für jene Kursteilnehmer, die auch Teilnehmer einer bestimmten Prüfung sind?
 
 AdminCrontabNotGenerated: (Noch) keine Crontab generiert
 CronMatchAsap: ASAP

messages/uniworx/en-eu.msg

@@ -2998,6 +2998,9 @@ PersonalisedSheetFilesIgnored count: #{count} uploaded #{pluralEN count "file wa
 PersonalisedSheetFilesIgnoredIntro: The following files were ignored:
 CourseUserHasPersonalisedSheetFilesFilter: Participant has personalised sheet files for
 SheetPersonalisedFilesUsersList: List of course participants who have personalised sheet files
+PersonalisedSheetFilesDownloadRestrictByExamNone: No restriction
+PersonalisedSheetFilesDownloadRestrictByExam: Restrict to exam participants
+PersonalisedSheetFilesDownloadRestrictByExamTip: Only download personalised sheet files for participants also registered to a certain exam?
 
 AdminCrontabNotGenerated: Crontab not (yet) generated
 CronMatchAsap: ASAP

src/Handler/Course/Users.hs

@@ -681,7 +681,7 @@ postCUsersR tid ssh csh = do
       shId <- runDB . getKeyBy404 $ CourseSheet cid shn
       archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $
         MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand shn
-      sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode
+      sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode Set.empty
 
 
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName} #{tid}|]

src/Handler/Sheet/PersonalisedFiles.hs

@@ -60,6 +60,18 @@ data PersonalisedSheetFileUnresolved a
 makePrisms ''PersonalisedSheetFileUnresolved
 
 
+data PersonalisedSheetFilesRestriction
+  = PSFRExamRegistered { psfrExam :: ExamId }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLenses_ ''PersonalisedSheetFilesRestriction
+
+data PersonalisedSheetFilesForm = PersonalisedSheetFilesForm
+  { psffAnonymous :: PersonalisedSheetFilesDownloadAnonymous
+  , psffRestrictions :: Set PersonalisedSheetFilesRestriction
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
 personalisedSheetFileTypes :: [SheetFileType]
 personalisedSheetFileTypes = filter (/= SheetMarking) universeF
 
@@ -196,8 +208,9 @@ sourcePersonalisedSheetFiles :: forall m.
                              -> Maybe SheetId
                              -> Maybe (Set UserId)
                              -> PersonalisedSheetFilesDownloadAnonymous
+                             -> Set PersonalisedSheetFilesRestriction
                              -> ConduitT () (Either PersonalisedSheetFile DBFile) (SqlPersistT m) ()
-sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do
+sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
   (mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
   let
     genSuffixes uid = case anonMode of
@@ -229,6 +242,10 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do
       case mbuids of
         Just uids -> E.where_ $ courseParticipant E.^. CourseParticipantUser `E.in_` E.valList (Set.toList uids)
         Nothing -> E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+      forM_ restrs $ \case
+        PSFRExamRegistered{..} -> E.where_ . E.exists . E.from $ \examRegistration ->
+          E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val psfrExam
+               E.&&. examRegistration E.^. ExamRegistrationUser E.==. courseParticipant E.^. CourseParticipantUser
       return (courseParticipant, personalisedSheetFile)
 
     toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do
@@ -369,23 +386,26 @@ getPersonalFilesR cId mbsid = do
     <*> traverse get404 mbsid
   
   cRoute <- getCurrentRoute
-  ((anonRes, anonFormWdgt), anonEnctype) <- runFormGet . renderAForm FormStandard $
-    apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous)
 
-  formResult anonRes $ \anonMode -> do
+  let toRestrictions = maybe Set.empty $ Set.singleton . PSFRExamRegistered
+  ((psfRes, psfWdgt), psfEnctype) <- runFormGet . renderAForm FormStandard $ PersonalisedSheetFilesForm
+    <$> apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous)
+    <*> fmap toRestrictions (aopt (examField (Just $ SomeMessage MsgPersonalisedSheetFilesDownloadRestrictByExamNone) cId) (fslI MsgPersonalisedSheetFilesDownloadRestrictByExam & setTooltip MsgPersonalisedSheetFilesDownloadRestrictByExamTip) (Just $ mbSheet ^? _Just . _sheetType . _examPart . from _SqlKey))
+  
+  formResult psfRes $ \PersonalisedSheetFilesForm{..} -> do
     archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ case mbSheet of
       Nothing -> MsgCoursePersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand
       Just Sheet{..} -> MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand sheetName
-    sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid Nothing anonMode
+    sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid Nothing psffAnonymous psffRestrictions
   
   isModal <- hasCustomHeader HeaderIsModal
 
   fmap toTypedContent . siteLayoutMsg MsgMenuSheetPersonalisedFiles $ do
     setTitleI MsgMenuSheetPersonalisedFiles
-    wrapForm anonFormWdgt def
+    wrapForm psfWdgt def
       { formMethod = GET
       , formAction = SomeRoute <$> cRoute
-      , formEncoding = anonEnctype
+      , formEncoding = psfEnctype
       , formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal
       }