fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(personalised-sheet-files): participant interaction

Browse Source
This commit is contained in:
Gregor Kleen 2020-08-07 18:18:41 +02:00
parent 1fe63a23a0
commit db205f635d
17 changed files with 297 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
messages/uniworx/de-de-formal.msg
View File

@ -337,7 +337,8 @@ SheetRequireExamTip: Wenn die Anmeldung zu einer Prüfung vorausgesetzt wird, k
SheetRequiredExam: Prüfung SheetRequiredExam: Prüfung
SheetShowRequiredExam: Vorausgesetze Prüfungsanmeldung SheetShowRequiredExam: Vorausgesetze Prüfungsanmeldung
SheetSubmissionExamRegistrationRequired: Um die Angabe für dieses Übungsblatt herunterzuladen oder Abzugeben ist eine Anmeldung zur genannten Prüfung erforderlich. SheetSubmissionExamRegistrationRequired: Um die Angabe für dieses Übungsblatt herunterzuladen oder Abzugeben ist eine Anmeldung zur genannten Prüfung erforderlich.
SheetFilesExamRegistrationRequired: Um die Angabe für dieses Übungsblatt herunterzuladen oder Abzugeben ist eine Anmeldung zu der oben genannten Prüfung erforderlich. SheetFilesExamRegistrationRequired: Um die Dateien dieses Übungsblattes herunterzuladen oder Abzugeben ist eine Anmeldung zu der oben genannten Prüfung erforderlich.
SheetFilesMissingPersonalisedFiles: Um Abzugeben muss zunächst ein Kursverwalter personalisierte Übungsblatt-Dateien für Sie hinterlegen.
SheetArchiveFileTypeDirectoryExercise: aufgabenstellung SheetArchiveFileTypeDirectoryExercise: aufgabenstellung
SheetArchiveFileTypeDirectoryHint: hinweis SheetArchiveFileTypeDirectoryHint: hinweis
@ -477,6 +478,7 @@ UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben. UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben.
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionPersonalisedSheetFiles: Ihnen wurden keine personalisierten Übungsblatt-Dateien zugeteilt und die Abgabe ist ohne diese nicht gestattet.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen. UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen.
@ -1458,6 +1460,7 @@ AuthTagCapacity: Kapazität ist ausreichend
AuthTagEmpty: Kurs hat keine Teilnehmer AuthTagEmpty: Kurs hat keine Teilnehmer
AuthTagMaterials: Kursmaterialien sind freigegeben AuthTagMaterials: Kursmaterialien sind freigegeben
AuthTagOwner: Nutzer ist Besitzer AuthTagOwner: Nutzer ist Besitzer
AuthTagPersonalisedSheetFiles: Nutzer verfügt über personalisierte Übungsblatt-Dateien
AuthTagRated: Korrektur ist bewertet AuthTagRated: Korrektur ist bewertet
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
@ -2692,6 +2695,9 @@ PersonalisedSheetFilesDownloadAnonymousField: Anonymisierung
PersonalisedSheetFilesDownloadAnonymousFieldTip: Soll das Archiv von personalisierten Dateien anonymisiert werden (es enthält dann keinerlei sofort persönlich identifizierende Informationen zu den Kursteilnehmern) oder sollen die Verzeichnisnamen mit einem Merkmal versehen werden und die Metainformations-Dateien zusätzlich persönliche Daten enthalten? PersonalisedSheetFilesDownloadAnonymousFieldTip: Soll das Archiv von personalisierten Dateien anonymisiert werden (es enthält dann keinerlei sofort persönlich identifizierende Informationen zu den Kursteilnehmern) oder sollen die Verzeichnisnamen mit einem Merkmal versehen werden und die Metainformations-Dateien zusätzlich persönliche Daten enthalten?
PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"} #{count} hochgeladene #{pluralDE count "Datei" "Dateien"} ignoriert, da sie keinem Übungsblattdatei-Typ oder keinem Kursteilnehmer zugeordnet werden #{pluralDE count "konnte" "konnten"}. PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"} #{count} hochgeladene #{pluralDE count "Datei" "Dateien"} ignoriert, da sie keinem Übungsblattdatei-Typ oder keinem Kursteilnehmer zugeordnet werden #{pluralDE count "konnte" "konnten"}.
PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert: PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert:
CourseUserHasPersonalisedSheetFilesFilter: Teilnehmer hat personalisierte Übungsblatt-Dateien für
SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übungsblatt-Dateien
AdminCrontabNotGenerated: (Noch) keine Crontab generiert AdminCrontabNotGenerated: (Noch) keine Crontab generiert
CronMatchAsap: ASAP CronMatchAsap: ASAP
CronMatchNone: Nie CronMatchNone: Nie

8
routes
View File

@ -152,15 +152,15 @@
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR GET POST /delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only /subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-groupANDexam-registered !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files
!/subs/own SubmissionOwnR GET !free -- just redirect !/subs/own SubmissionOwnR GET !free -- just redirect
!/subs/assign SAssignR GET POST !lecturerANDtime !/subs/assign SAssignR GET POST !lecturerANDtime
/subs/#CryptoFileNameSubmission SubmissionR: /subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registered !ownerANDread !correctorANDread / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !ownerANDread !correctorANDread
/delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registered /delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registeredANDpersonalised-sheet-files
/assign SubAssignR GET POST !lecturerANDtime /assign SubAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated /correction CorrectionR GET POST !corrector !ownerANDreadANDrated
/invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registered /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files
!/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet

7
src/Database/Esqueleto/Utils.hs
View File

@ -3,6 +3,7 @@
module Database.Esqueleto.Utils module Database.Esqueleto.Utils
( true, false ( true, false
, justVal, justValList
, isJust , isJust
, isInfixOf, hasInfix , isInfixOf, hasInfix
, or, and , or, and
@ -67,6 +68,12 @@ true = E.val True
false :: E.SqlExpr (E.Value Bool) false :: E.SqlExpr (E.Value Bool)
false = E.val False false = E.val False
justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
justVal = E.val . Just
justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
justValList = E.valList . map Just
-- | Negation of `isNothing` which is missing -- | Negation of `isNothing` which is missing
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
isJust = E.not_ . E.isNothing isJust = E.not_ . E.isNothing

15
src/Foundation.hs
View File

@ -1374,6 +1374,21 @@ tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthOwner r r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
if | sheetAllowNonPersonalisedSubmission -> return Authorized
| otherwise -> do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $
E.selectExists . E.from $ \psFile ->
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId
E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId
E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
return Authorized
r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID

20
src/Handler/Course/Users.hs
View File

@ -353,6 +353,16 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
tutorials <- selectList [ TutorialCourse ==. cid ] [] tutorials <- selectList [ TutorialCourse ==. cid ] []
exams <- selectList [ ExamCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] []
sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
personalisedSheets <- E.select . E.from $ \sheet -> do
let hasPersonalised = E.exists . E.from $ \psFile ->
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission)
E.||. hasPersonalised
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.orderBy [ E.desc $ sheet E.^. SheetActiveTo
, E.desc $ sheet E.^. SheetActiveFrom
]
return $ sheet E.^. SheetName
-- -- psValidator has default sorting and filtering -- -- psValidator has default sorting and filtering
showSex <- getShowSex showSex <- getShowSex
let dbtIdent = "courseUsers" :: Text let dbtIdent = "courseUsers" :: Text
@ -465,6 +475,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
-- , ("course-user-note", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
, single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. sheet E.^. SheetName E.==. E.val shn
)
] ]
where single = uncurry Map.singleton where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $ dbtFilterUI mPrev = mconcat $
@ -478,6 +495,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
] ++
[ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter)
| not $ null personalisedSheets
] ]
dbtParams = DBParamsForm dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST

76
src/Handler/Sheet/Download.hs
View File

@ -16,6 +16,7 @@ import qualified Database.Esqueleto.Utils as E
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSArchiveR tid ssh csh shn = do getSArchiveR tid ssh csh shn = do
shId <- runDB $ fetchSheetId tid ssh csh shn shId <- runDB $ fetchSheetId tid ssh csh shn
muid <- maybeAuthId
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn
@ -23,42 +24,75 @@ getSArchiveR tid ssh csh shn = do
allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF
multipleSFTs <- if multipleSFTs <- if
| length allowedSFTs < 2 -> return False | length allowedSFTs < 2 -> return False
| otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` ((psFile1 `E.FullOuterJoin` sFile1) `E.InnerJoin` (psFile2 `E.FullOuterJoin` sFile2))) -> do
E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType E.on $ sFile2 E.?. SheetFileSheet E.==. psFile2 E.?. PersonalisedSheetFileSheet
E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle E.&&. sFile2 E.?. SheetFileType E.==. psFile2 E.?. PersonalisedSheetFileType
E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet E.&&. sFile2 E.?. SheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle
E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet E.&&. psFile2 E.?. PersonalisedSheetFileUser E.==. E.val muid
E.on $ ( sFile1 E.?. SheetFileType E.!=. sFile2 E.?. SheetFileType
E.||. psFile1 E.?. PersonalisedSheetFileType E.!=. psFile2 E.?. PersonalisedSheetFileType
E.||. sFile1 E.?. SheetFileType E.!=. psFile2 E.?. PersonalisedSheetFileType
E.||. sFile2 E.?. SheetFileType E.!=. psFile1 E.?. PersonalisedSheetFileType
)
E.&&. ( sFile1 E.?. SheetFileTitle E.==. sFile2 E.?. SheetFileTitle
E.||. psFile1 E.?. PersonalisedSheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle
E.||. sFile1 E.?. SheetFileTitle E.==. psFile2 E.?. PersonalisedSheetFileTitle
E.||. sFile2 E.?. SheetFileTitle E.==. psFile1 E.?. PersonalisedSheetFileTitle
)
E.on $ sFile1 E.?. SheetFileSheet E.==. psFile1 E.?. PersonalisedSheetFileSheet
E.&&. sFile1 E.?. SheetFileType E.==. psFile1 E.?. PersonalisedSheetFileType
E.&&. sFile1 E.?. SheetFileTitle E.==. psFile1 E.?. PersonalisedSheetFileTitle
E.&&. psFile1 E.?. PersonalisedSheetFileUser E.==. E.val muid
E.on $ (E.just (sheet E.^. SheetId) E.==. sFile1 E.?. SheetFileSheet E.||. E.just (sheet E.^. SheetId) E.==. psFile1 E.?. PersonalisedSheetFileSheet)
E.&&. (E.just (sheet E.^. SheetId) E.==. sFile2 E.?. SheetFileSheet E.||. E.just (sheet E.^. SheetId) E.==. psFile2 E.?. PersonalisedSheetFileSheet)
E.where_ $ sheet E.^. SheetId E.==. E.val shId E.where_ $ sheet E.^. SheetId E.==. E.val shId
E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs E.&&. (sFile1 E.?. SheetFileType `E.in_` E.justValList allowedSFTs E.||. psFile1 E.?. PersonalisedSheetFileType `E.in_` E.justValList allowedSFTs)
E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs E.&&. (sFile2 E.?. SheetFileType `E.in_` E.justValList allowedSFTs E.||. psFile2 E.?. PersonalisedSheetFileType `E.in_` E.justValList allowedSFTs)
let modifyTitles SheetFile{..} E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile1 E.?. PersonalisedSheetFileUser)
| not multipleSFTs = SheetFile{..} E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile2 E.?. PersonalisedSheetFileUser)
| otherwise = SheetFile
{ sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) </> sheetFileTitle let
, .. modifyTitles :: forall record. HasFileReference record => (record -> SheetFileType) -> record -> record
} modifyTitles sft f
| not multipleSFTs = f
| otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) <//>)
sftDirectories <- if sftDirectories <- if
| not multipleSFTs -> return mempty | not multipleSFTs -> return mempty
| otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do
E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet
E.&&. sFile E.^. SheetFileType E.==. E.val sft E.&&. sFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType
return . E.max_ $ sFile E.^. SheetFileModified E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle
E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
E.where_ $ (sFile E.?. SheetFileSheet E.==. E.justVal shId E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.justVal shId)
E.&&. (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft)
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
return . E.max_ $ E.unsafeCoalesce
[ sFile E.?. SheetFileModified
, psFile E.?. PersonalisedSheetFileModified
]
serveZipArchive archiveName $ do serveZipArchive archiveName $ do
forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile
{ sheetFileType = sft { sheetFileType = sft
, sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft
, sheetFileModified = mTime , sheetFileModified = mTime
, sheetFileContent = Nothing , sheetFileContent = Nothing
, sheetFileSheet = shId , sheetFileSheet = shId
} }
sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles sheetFilesSFTsQuery tid ssh csh shn muid allowedSFTs .| C.map (entityVal `bimap` entityVal) .| C.map (modifyTitles sheetFileType `bimap` modifyTitles personalisedSheetFileType)
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal getSFileR tid ssh csh shn sft file = do
muid <- maybeAuthId
serveOneFile $ sheetFileQuery tid ssh csh shn muid sft file
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
getSZipR tid ssh csh shn sft = do getSZipR tid ssh csh shn sft = do
muid <- maybeAuthId
sft' <- ap getMessageRender $ pure sft sft' <- ap getMessageRender $ pure sft
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft' archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft'
serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn muid sft

25
src/Handler/Sheet/Form.hs
View File

@ -107,12 +107,31 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
let downloadRoute = case mbSheet of let downloadRoute = case mbSheet of
Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR
downloadTrigger
= [whamlet|
$newline never
#{iconFileZip}
\ _{MsgMenuSheetPersonalisedFiles}
|]
listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl
( CourseR courseTerm courseSchool courseShorthand CUsersR
, [ ("courseUsers-has-personalised-sheet-files"
, toPathPiece shn
)
]
)
guardM $ hasReadAccessTo downloadRoute guardM $ hasReadAccessTo downloadRoute
messageIconWidget Info IconFileZip messageIconWidget Info IconFileUser
[whamlet| [whamlet|
$newline never $newline never
_{MsgSheetPersonalisedFilesDownloadTemplateHere}<br /> <div>
^{modal (i18n MsgMenuSheetPersonalisedFiles) (Left (SomeRoute downloadRoute))} _{MsgSheetPersonalisedFilesDownloadTemplateHere}
<br />
^{modal downloadTrigger (Left (SomeRoute downloadRoute))}
$maybe lRoute <- listRoute
<p .explanation>
<a href=#{lRoute} target="_blank">
_{MsgSheetPersonalisedFilesUsersList}
|] |]
return $ SheetPersonalisedFilesForm return $ SheetPersonalisedFilesForm
<$ maybe (pure ()) aformMessage templateDownloadMessage <$ maybe (pure ()) aformMessage templateDownloadMessage

8
src/Handler/Sheet/List.hs
View File

@ -117,10 +117,10 @@ getSheetListR tid ssh csh = do
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
sheetData dt sheetData dt
let existFiles = -- check whether files exist for given type let existFiles = -- check whether files exist for given type
( hasSheetFileQuery sheet SheetExercise ( hasSheetFileQuery sheet (E.val muid) SheetExercise
, hasSheetFileQuery sheet SheetHint , hasSheetFileQuery sheet (E.val muid) SheetHint
, hasSheetFileQuery sheet SheetSolution , hasSheetFileQuery sheet (E.val muid) SheetSolution
, hasSheetFileQuery sheet SheetMarking , hasSheetFileQuery sheet (E.val muid) SheetMarking
) )
return (sheet, lastSheetEdit sheet, submission, existFiles) return (sheet, lastSheetEdit sheet, submission, existFiles)
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId

44
src/Handler/Sheet/Show.hs
View File

@ -11,13 +11,14 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Map as Map import qualified Data.Map as Map
import Handler.Sheet.Pseudonym import Handler.Sheet.Pseudonym
import Utils.Sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do getSShowR tid ssh csh shn = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
muid <- maybeAuthId
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
@ -32,12 +33,20 @@ getSShowR tid ssh csh shn = do
| NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime
| otherwise = mempty | otherwise = mempty
let fileData sheetFile = do let fileData (sheetFile `E.FullOuterJoin` psFile) = do
E.on $ sheetFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle
E.&&. sheetFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType
E.&&. sheetFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet
E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
-- filter to requested file -- filter to requested file
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.where_ $ (sheetFile E.?. SheetFileSheet E.==. E.justVal sid E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.justVal sid)
E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories E.&&. E.maybe (E.isJust . E.joinV $ sheetFile E.?. SheetFileContent) E.isJust (psFile E.?. PersonalisedSheetFileContent) -- don't show directories
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
-- return desired columns -- return desired columns
return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType) return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle]
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified]
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType]
)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
let link = CSheetR tid ssh csh shn $ SZipR ftype in let link = CSheetR tid ssh csh shn $ SZipR ftype in
@ -59,7 +68,7 @@ getSShowR tid ssh csh shn = do
& forceFilter "may-access" (Any True) & forceFilter "may-access" (Any True)
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtRowKey = (E.^. SheetFileId) , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
, dbtStyle = def , dbtStyle = def
@ -72,16 +81,16 @@ getSShowR tid ssh csh shn = do
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "type" [ ( "type"
, SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.orderByEnum $ E.unsafeCoalesce [sheetFile E.?. SheetFileType, psFile E.?. PersonalisedSheetFileType]
) )
, ( "path" , ( "path"
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileTitle, psFile E.?. PersonalisedSheetFileTitle]
) )
-- , ( "visible" -- , ( "visible"
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
-- ) -- )
, ( "time" , ( "time"
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified , SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileModified, psFile E.?. PersonalisedSheetFileModified]
) )
] ]
, dbtParams = def , dbtParams = def
@ -89,8 +98,12 @@ getSShowR tid ssh csh shn = do
, dbtCsvDecode = Nothing , dbtCsvDecode = Nothing
} }
(hasHints, hasSolution) <- runDB $ do (hasHints, hasSolution) <- runDB $ do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasHints <- E.selectExists . E.from $ \sheet' ->
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetHint
E.&&. sheet' E.^. SheetId E.==. E.val sid
hasSolution <- E.selectExists . E.from $ \sheet' ->
E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetSolution
E.&&. sheet' E.^. SheetId E.==. E.val sid
return (hasHints, hasSolution) return (hasHints, hasSolution)
mPseudonym <- runMaybeT $ do mPseudonym <- runMaybeT $ do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
@ -116,6 +129,15 @@ getSShowR tid ssh csh shn = do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
lift . fmap not . runDB $ exists [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid ] lift . fmap not . runDB $ exists [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid ]
let checkPersonalisedFiles
= not (sheetAllowNonPersonalisedSubmission sheet)
&& NTop (sheetActiveFrom sheet) <= NTop (Just now)
&& NTop (sheetActiveTo sheet) >= NTop (Just now)
mMissingPersonalisedFiles <- for (guardOnM checkPersonalisedFiles muid) $ \uid -> runDB $
fmap not . E.selectExists . E.from $ \psFile ->
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. E.val uid
E.&&. psFile E.^. PersonalisedSheetFileSheet E.==. E.val sid
defaultLayout $ do defaultLayout $ do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR let zipLink = CSheetR tid ssh csh shn SArchiveR

4
src/Handler/Utils/Table/Columns.hs
View File

@ -417,10 +417,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms
where conDTCell = ifCell condition dateTimeCell $ const mempty where conDTCell = ifCell condition dateTimeCell $ const mempty
sortFilePath :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') sortFilePath :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField)) sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField))
sortFileModification :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') sortFileModification :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField)) sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField))
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x

7
src/Model.hs
View File

@ -78,6 +78,7 @@ instance HasFileReference CourseApplicationFile where
} }
) )
instance IsFileReference CourseApplicationFile where
fileReferenceTitleField = CourseApplicationFileTitle fileReferenceTitleField = CourseApplicationFileTitle
fileReferenceContentField = CourseApplicationFileContent fileReferenceContentField = CourseApplicationFileContent
fileReferenceModifiedField = CourseApplicationFileModified fileReferenceModifiedField = CourseApplicationFileModified
@ -106,6 +107,7 @@ instance HasFileReference CourseAppInstructionFile where
} }
) )
instance IsFileReference CourseAppInstructionFile where
fileReferenceTitleField = CourseAppInstructionFileTitle fileReferenceTitleField = CourseAppInstructionFileTitle
fileReferenceContentField = CourseAppInstructionFileContent fileReferenceContentField = CourseAppInstructionFileContent
fileReferenceModifiedField = CourseAppInstructionFileModified fileReferenceModifiedField = CourseAppInstructionFileModified
@ -139,6 +141,7 @@ instance HasFileReference SheetFile where
} }
) )
instance IsFileReference SheetFile where
fileReferenceTitleField = SheetFileTitle fileReferenceTitleField = SheetFileTitle
fileReferenceContentField = SheetFileContent fileReferenceContentField = SheetFileContent
fileReferenceModifiedField = SheetFileModified fileReferenceModifiedField = SheetFileModified
@ -175,6 +178,7 @@ instance HasFileReference PersonalisedSheetFile where
} }
) )
instance IsFileReference PersonalisedSheetFile where
fileReferenceTitleField = PersonalisedSheetFileTitle fileReferenceTitleField = PersonalisedSheetFileTitle
fileReferenceContentField = PersonalisedSheetFileContent fileReferenceContentField = PersonalisedSheetFileContent
fileReferenceModifiedField = PersonalisedSheetFileModified fileReferenceModifiedField = PersonalisedSheetFileModified
@ -211,6 +215,7 @@ instance HasFileReference SubmissionFile where
} }
) )
instance IsFileReference SubmissionFile where
fileReferenceTitleField = SubmissionFileTitle fileReferenceTitleField = SubmissionFileTitle
fileReferenceContentField = SubmissionFileContent fileReferenceContentField = SubmissionFileContent
fileReferenceModifiedField = SubmissionFileModified fileReferenceModifiedField = SubmissionFileModified
@ -239,6 +244,7 @@ instance HasFileReference CourseNewsFile where
} }
) )
instance IsFileReference CourseNewsFile where
fileReferenceTitleField = CourseNewsFileTitle fileReferenceTitleField = CourseNewsFileTitle
fileReferenceContentField = CourseNewsFileContent fileReferenceContentField = CourseNewsFileContent
fileReferenceModifiedField = CourseNewsFileModified fileReferenceModifiedField = CourseNewsFileModified
@ -269,6 +275,7 @@ instance HasFileReference MaterialFile where
} }
) )
instance IsFileReference MaterialFile where
fileReferenceTitleField = MaterialFileTitle fileReferenceTitleField = MaterialFileTitle
fileReferenceContentField = MaterialFileContent fileReferenceContentField = MaterialFileContent
fileReferenceModifiedField = MaterialFileModified fileReferenceModifiedField = MaterialFileModified

27
src/Model/Types/File.hs
View File

@ -1,7 +1,7 @@
module Model.Types.File module Model.Types.File
( File(..), _fileTitle, _fileContent, _fileModified ( File(..), _fileTitle, _fileContent, _fileModified
, FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
, HasFileReference(..) , HasFileReference(..), IsFileReference(..), FileReferenceResidual(..)
) where ) where
import Import.NoModel import Import.NoModel
@ -27,11 +27,34 @@ data FileReference = FileReference
makeLenses_ ''FileReference makeLenses_ ''FileReference
class PersistEntity record => HasFileReference record where class HasFileReference record where
data FileReferenceResidual record :: * data FileReferenceResidual record :: *
_FileReference :: Iso' record (FileReference, FileReferenceResidual record) _FileReference :: Iso' record (FileReference, FileReferenceResidual record)
instance HasFileReference FileReference where
data FileReferenceResidual FileReference = FileReferenceResidual
_FileReference = iso (, FileReferenceResidual) $ view _1
instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where
newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) }
_FileReference = iso doSplit doJoin
where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference
doSplit (Left r) = over _2 (FileReferenceResidualEither . Left ) $ r ^. _FileReference
doJoin (fRef, FileReferenceResidualEither (Right res)) = Right $ _FileReference # (fRef, res)
doJoin (fRef, FileReferenceResidualEither (Left res)) = Left $ _FileReference # (fRef, res)
instance HasFileReference record => HasFileReference (Entity record) where
data FileReferenceResidual (Entity record) = FileReferenceResidualEntity
{ fileReferenceResidualEntityKey :: Key record
, fileReferenceResidualEntityResidual :: FileReferenceResidual record
}
_FileReference = iso doSplit doJoin
where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res)
where (fRef, res) = entityVal ^. _FileReference
doJoin (fRef, FileReferenceResidualEntity entityKey res) = Entity{ entityVal = _FileReference # (fRef, res), .. }
class (PersistEntity record, HasFileReference record) => IsFileReference record where
fileReferenceTitleField :: EntityField record FilePath fileReferenceTitleField :: EntityField record FilePath
fileReferenceContentField :: EntityField record (Maybe FileContentReference) fileReferenceContentField :: EntityField record (Maybe FileContentReference)
fileReferenceModifiedField :: EntityField record UTCTime fileReferenceModifiedField :: EntityField record UTCTime

1
src/Model/Types/Security.hs
View File

@ -68,6 +68,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthAllocationTime | AuthAllocationTime
| AuthMaterials | AuthMaterials
| AuthOwner | AuthOwner
| AuthPersonalisedSheetFiles
| AuthRated | AuthRated
| AuthUserSubmissions | AuthUserSubmissions
| AuthCorrectorSubmissions | AuthCorrectorSubmissions

4
src/Utils/Files.hs
View File

@ -81,7 +81,7 @@ sinkFile' file residual = do
type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) () type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) ()
replaceFileReferences' :: ( MonadIO m, MonadThrow m replaceFileReferences' :: ( MonadIO m, MonadThrow m
, HasFileReference record , IsFileReference record
, PersistEntityBackend record ~ SqlBackend , PersistEntityBackend record ~ SqlBackend
) )
=> (FileReferenceResidual record -> [Filter record]) => (FileReferenceResidual record -> [Filter record])
@ -116,7 +116,7 @@ replaceFileReferences' mkFilter residual = do
replaceFileReferences :: ( MonadHandler m, MonadThrow m replaceFileReferences :: ( MonadHandler m, MonadThrow m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, HasFileReference record , IsFileReference record
, PersistEntityBackend record ~ SqlBackend , PersistEntityBackend record ~ SqlBackend
) )
=> (FileReferenceResidual record -> [Filter record]) => (FileReferenceResidual record -> [Filter record])

2
src/Utils/Icon.hs
View File

@ -85,6 +85,7 @@ data Icon
| IconMissingAllocationPriority | IconMissingAllocationPriority
| IconFileUploadSession | IconFileUploadSession
| IconStandaloneFieldError | IconStandaloneFieldError
| IconFileUser
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
iconText :: Icon -> Text iconText :: Icon -> Text
@ -148,6 +149,7 @@ iconText = \case
IconMissingAllocationPriority -> "empty-set" IconMissingAllocationPriority -> "empty-set"
IconFileUploadSession -> "file-upload" IconFileUploadSession -> "file-upload"
IconStandaloneFieldError -> "exclamation" IconStandaloneFieldError -> "exclamation"
IconFileUser -> "file-user"
instance Universe Icon instance Universe Icon
instance Finite Icon instance Finite Icon

135
src/Utils/Sheet.hs
View File

@ -4,6 +4,8 @@ import Import.NoFoundation
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Data.Conduit.Combinators as C
-- DB Queries for Sheets that are used in several places -- DB Queries for Sheets that are used in several places
sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName) sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName)
@ -46,60 +48,91 @@ sheetOldUnassigned tid ssh csh = do
_ -> error "SQL Query with limit 1 returned more than one result" _ -> error "SQL Query with limit 1 returned more than one result"
-- | Return a specfic file from a `Sheet` -- | Return a specfic file from a `Sheet`
sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> SheetFileType -> FilePath -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) ()
sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ sheetFileQuery tid ssh csh shn muid sft title = sqlSelect .| C.map toEither
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do where
-- Restrict to consistent rows that correspond to each other sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) -- Restrict to consistent rows that correspond to each other
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType
-- filter to requested file E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle
E.where_ ((sFile E.^. SheetFileTitle E.==. E.val title) E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.&&. (course E.^. CourseTerm E.==. E.val tid ) -- filter to requested file
) E.where_ $ (sFile E.?. SheetFileTitle E.==. E.justVal title E.||. psFile E.?. PersonalisedSheetFileTitle E.==. E.justVal title)
-- return file entity E.&&. (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft)
return sFile E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
-- return file entity
return (sFile, psFile)
toEither (_, Just psFile) = Right psFile
toEither (Just sFile, _) = Left sFile
toEither _ = error "sqlSelect returned incoherent result"
-- | Return all files of a certain `SheetFileType` for a `Sheet` -- | Return all files of a certain `SheetFileType` for a `Sheet`
sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> SheetFileType -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) ()
sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ sheetFilesAllQuery tid ssh csh shn muid sft = sqlSelect .| C.map toEither
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do where
-- Restrict to consistent rows that correspond to each other sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) -- Restrict to consistent rows that correspond to each other
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType
-- filter to requested file E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle
E.where_ ((sheet E.^. SheetName E.==. E.val shn ) E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
) -- filter to requested file
-- return file entity E.where_ $ (sFile E.?. SheetFileType E.==. E.justVal sft E.||. psFile E.?. PersonalisedSheetFileType E.==. E.justVal sft)
return sFile E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
-- return file entity
return (sFile, psFile)
toEither (_, Just psFile) = Right psFile
toEither (Just sFile, _) = Left sFile
toEither _ = error "sqlSelect returned incoherent result"
-- | Return all files of certain `SheetFileTypes` for a `Sheet` -- | Return all files of certain `SheetFileTypes` for a `Sheet`
sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe UserId -> [SheetFileType] -> ConduitT () (Either (Entity SheetFile) (Entity PersonalisedSheetFile)) (SqlPersistT m) ()
sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $ sheetFilesSFTsQuery tid ssh csh shn muid sfts = sqlSelect .| C.map toEither
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do where
-- Restrict to consistent rows that correspond to each other sqlSelect = E.selectSource . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` (sFile `E.FullOuterJoin` psFile)) -> do
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) -- Restrict to consistent rows that correspond to each other
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on $ psFile E.?. PersonalisedSheetFileType E.==. sFile E.?. SheetFileType
-- filter to requested file E.&&. psFile E.?. PersonalisedSheetFileTitle E.==. sFile E.?. SheetFileTitle
E.where_ ((sheet E.^. SheetName E.==. E.val shn ) E.&&. psFile E.?. PersonalisedSheetFileSheet E.==. sFile E.?. SheetFileSheet
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.on $ sFile E.?. SheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.just (sheet E.^. SheetId)
E.&&. (sFile E.^. SheetFileType `E.in_` E.valList sfts ) E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
) -- filter to requested file
-- return file entity E.where_ $ (sFile E.?. SheetFileType `E.in_` E.justValList sfts E.||. psFile E.?. PersonalisedSheetFileType `E.in_` E.justValList sfts)
return sFile E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
-- return file entity
return (sFile, psFile)
toEither (_, Just psFile) = Right psFile
toEither (Just sFile, _) = Left sFile
toEither _ = error "sqlSelect returned incoherent result"
-- | Check whether a sheet has any files for a given file type -- | Check whether a sheet has any files for a given file type
hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> SheetFileType -> E.SqlExpr (E.Value Bool) hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> E.SqlExpr (E.Value (Maybe UserId)) -> SheetFileType -> E.SqlExpr (E.Value Bool)
hasSheetFileQuery sheet sft = hasSheetFileQuery sheet muid sft = sheetFile E.||. personalisedSheetFile
E.exists $ E.from $ \sFile -> where sheetFile = E.exists . E.from $ \sFile ->
E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.where_ $ sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId
E.&&. (sFile E.^. SheetFileType E.==. E.val sft )) E.&&. sFile E.^. SheetFileType E.==. E.val sft
personalisedSheetFile = E.exists . E.from $ \psFile ->
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
E.&&. psFile E.^. PersonalisedSheetFileType E.==. E.val sft
E.&&. E.just (psFile E.^. PersonalisedSheetFileUser) E.==. muid

10
templates/sheetShow.hamlet
View File

@ -71,10 +71,14 @@ $maybe marktxt <- markingText
<p> <p>
#{marktxt} #{marktxt}
$if fromMaybe False mMissingPersonalisedFiles
<section>
^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesMissingPersonalisedFiles)}
$elseif fromMaybe False mMissingExamRegistration
<section>
^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesExamRegistrationRequired)}
$if hasFiles $if hasFiles
<section> <section>
<h2>^{simpleLinkI (SomeMessage MsgSheetFiles) zipLink} <h2>^{simpleLinkI (SomeMessage MsgSheetFiles) zipLink}
^{fileTable} ^{fileTable}
$elseif fromMaybe False mMissingExamRegistration
<section>
^{notificationWidget NotificationBroad Warning (i18n MsgSheetFilesExamRegistrationRequired)}