Merge branch 'master' into stundenplan
This commit is contained in:
Sarah Vaupel
commit
d0fe60b951
14
CHANGELOG.md
14
CHANGELOG.md
@ -2,6 +2,20 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [21.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.3...v21.1.0) (2020-11-05)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **sheets:** upload-empty-ok ([ab1940c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab1940cb09e824fbba03264b5451fa8b17c5c804))
|
||||
|
||||
### [21.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.2...v21.0.3) (2020-11-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **mails:** prevent emails being resent to due archiving errors ([8cf39dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8cf39dcbe68cefcc50691ae8a7194315d18420d6))
|
||||
|
||||
### [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04)
|
||||
|
||||
|
||||
|
||||
@ -558,6 +558,7 @@ UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
|
||||
UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen.
|
||||
UnauthorizedCorrectorSubmission: Korrektoren dürfen für dieses Übungsblatt keine Abgaben erstellen.
|
||||
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
|
||||
UploadAtLeastOneNonemptyFile: Bitte mindestens eine nichtleere Datei hochladen.
|
||||
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
|
||||
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
|
||||
MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
|
||||
@ -932,6 +933,8 @@ UploadModeExtensionRestriction: Zulässige Dateiendungen
|
||||
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung. Bei Upload mehrerer Dateien erfolgt die Einschränkung von Dateiendungen für alle hochegladenen Dateien, auch innerhalb von ZIP-Archiven.
|
||||
UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
|
||||
UploadModeExtensionRestrictionMultipleTip: Einschränkung von Dateiendungen erfolgt für alle hochgeladenen Dateien, auch innerhalb von ZIP-Archiven.
|
||||
UploadAnyEmptyOk: Leere Uploads erlauben?
|
||||
UploadAnyEmptyOkTip: Sollen, statt einen Fehler auszugeben, Uploads, die nur aus leeren Dateien und/oder Verzeichnissen bestehen, erlaubt werden?
|
||||
|
||||
GenericFileFieldFileTooLarge file@FilePath: „#{file}“ ist zu groß
|
||||
GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
|
||||
@ -948,6 +951,7 @@ UploadSpecificFileName: Dateiname
|
||||
UploadSpecificFileRequired: Zur Abgabe erforderlich
|
||||
UploadSpecificFileMaxSize: Maximale Dateigröße (Bytes)
|
||||
UploadSpecificFileMaxSizeNegative: Maximale Dateigröße darf nicht negativ sein
|
||||
UploadSpecificFileEmptyOk: Leere Uploads erlauben
|
||||
|
||||
NoSubmissions: Keine Abgabe
|
||||
CorrectorSubmissions: Abgabe extern mit Pseudonym
|
||||
|
||||
@ -556,6 +556,7 @@ UnauthorizedSubmissionCorrector: You are no corrector for this submission.
|
||||
UnauthorizedUserSubmission: Users may not directly submit for this exercise sheet.
|
||||
UnauthorizedCorrectorSubmission: Correctors may not create submissions for this exercise sheet.
|
||||
OnlyUploadOneFile: Please only upload one file
|
||||
UploadAtLeastOneNonemptyFile: Please upload at least one nonempty file.
|
||||
DeprecatedRoute: This view is deprecated and will be removed.
|
||||
UnfreeMaterials: Course material are not publicly accessable.
|
||||
MaterialFree: Course material is publicly available.
|
||||
@ -930,6 +931,8 @@ UploadModeExtensionRestriction: Allowed file extensions
|
||||
UploadModeExtensionRestrictionTip: Comma-separated. If no file extensions are specified, uploads are not restricted.
|
||||
UploadModeExtensionRestrictionEmpty: List of permitted file extensions may not be empty
|
||||
UploadModeExtensionRestrictionMultipleTip: Checks for valid file extension are performed for all uploaded files, including those packed within zip-archives.
|
||||
UploadAnyEmptyOk: Allow empty uploads?
|
||||
UploadAnyEmptyOkTip: Should, instead of emitting an error, uploads be allowed, that consist solely of empty files and/or directories?
|
||||
|
||||
GenericFileFieldFileTooLarge file: “#{file}” is too large
|
||||
GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension
|
||||
@ -946,6 +949,7 @@ UploadSpecificFileName: Filename
|
||||
UploadSpecificFileRequired: Required for submission
|
||||
UploadSpecificFileMaxSize: Maximum filesize (bytes)
|
||||
UploadSpecificFileMaxSizeNegative: Maximum filesize may not be negative
|
||||
UploadSpecificFileEmptyOk: Allow empty uploads
|
||||
|
||||
NoSubmissions: No submission
|
||||
CorrectorSubmissions: External submission via pseudonym
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "21.0.2",
|
||||
"version": "21.1.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "21.0.2",
|
||||
"version": "21.1.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 21.0.2
|
||||
version: 21.1.0
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
|
||||
@ -256,7 +256,7 @@ instance YesodMail UniWorX where
|
||||
return mRes
|
||||
|
||||
(smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
|
||||
liftHandler . runDB . setSerializable $ do
|
||||
void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging
|
||||
sentMailRecipient <- if
|
||||
| [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
|
||||
recipUsers <- E.select . E.from $ \user -> do
|
||||
@ -276,11 +276,14 @@ instance YesodMail UniWorX where
|
||||
| otherwise -> Nothing
|
||||
| otherwise -> return Nothing
|
||||
|
||||
void $ insertUnique SentMailContent{ sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
|
||||
, sentMailContentContent
|
||||
}
|
||||
-- @insertUnique@ _does not_ work here
|
||||
unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $
|
||||
insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
|
||||
, sentMailContentContent
|
||||
}
|
||||
insert_ sentMail{ sentMailRecipient }
|
||||
wait mailProcess
|
||||
wait mailProcess -- Abort transaction if sending failed
|
||||
wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
|
||||
@ -91,7 +91,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
|
||||
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
|
||||
<* aformSection MsgSheetFormType
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False))
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
@ -135,7 +135,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
|]
|
||||
return $ SheetPersonalisedFilesForm
|
||||
<$ maybe (pure ()) aformMessage templateDownloadMessage
|
||||
<*> aopt (zipFileField True Nothing) (fslI MsgSheetPersonalisedFilesUpload & setTooltip MsgSheetPersonalisedFilesUploadTip) Nothing
|
||||
<*> aopt (zipFileField True Nothing True) (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)
|
||||
|
||||
|
||||
@ -98,7 +98,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
}
|
||||
|
||||
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
||||
apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
|
||||
apopt (zipFileField True Nothing True) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
|
||||
let uploadForm = wrapForm uploadForm' def
|
||||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
, formEncoding = uploadEncoding
|
||||
|
||||
@ -312,7 +312,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
-- Therefore we do not restrict upload behaviour in any way in that case
|
||||
((res,formWidget'), formEnctype) <- do
|
||||
(Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
|
||||
runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
||||
runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
@ -391,84 +391,82 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
| otherwise -> return $ FormSuccess res'
|
||||
|
||||
|
||||
case res' of
|
||||
(FormSuccess (mFiles, adhocMembers)) -> do
|
||||
smid <- do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
-> return smid
|
||||
(Just files, _) -> -- new files
|
||||
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> do
|
||||
sid <- insert Submission
|
||||
{ submissionSheet = shid
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingAssigned = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
audit $ TransactionSubmissionEdit sid shid
|
||||
return sid
|
||||
formResultMaybe res' $ \(mFiles, adhocMembers) -> do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
-> return smid
|
||||
(Just files, _) -> -- new files
|
||||
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> do
|
||||
sid <- insert Submission
|
||||
{ submissionSheet = shid
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingAssigned = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
audit $ TransactionSubmissionEdit sid shid
|
||||
|
||||
-- Determine new submission users
|
||||
subUsers <- if
|
||||
| isLecturer -> return adhocMembers
|
||||
| RegisteredGroups <- sheetGrouping -> do
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ SubmissionEdit muid now sid
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
||||
return sid
|
||||
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
return $ maybe id (Set.insert . Right) muid groupUids
|
||||
| otherwise -> return adhocMembers
|
||||
-- Determine new submission users
|
||||
subUsers <- if
|
||||
| isLecturer -> return adhocMembers
|
||||
| RegisteredGroups <- sheetGrouping -> do
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
|
||||
-- Since invitations carry no data we only need to consider changes to
|
||||
-- the set of users/invited emails
|
||||
-- Otherwise we would have to update old invitations (via
|
||||
-- `sinkInvitationsF`) because their associated @DBData@ might have
|
||||
-- changed
|
||||
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
||||
|
||||
forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if
|
||||
-- change is a new user being added to the submission users => send invitation / insert
|
||||
| change `Set.member` subUsers -> case change of
|
||||
Left subEmail -> do
|
||||
-- user does not exist yet => send invitation
|
||||
sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))]
|
||||
return ()
|
||||
Right subUid -> do
|
||||
-- user exists and has an id => insert as SubmissionUser and audit
|
||||
insert_ $ SubmissionUser subUid smid
|
||||
audit $ TransactionSubmissionUserEdit smid subUid
|
||||
unless (Just subUid == muid) $
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid
|
||||
-- change is an old user that is not a submission user anymore => delete invitation / delete
|
||||
| otherwise -> case change of
|
||||
Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
|
||||
Right subUid -> do
|
||||
deleteBy $ UniqueSubmissionUser subUid smid
|
||||
audit $ TransactionSubmissionUserDelete smid subUid
|
||||
unless (Just subUid == muid) $
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
return $ maybe id (Set.insert . Right) muid groupUids
|
||||
| otherwise -> return adhocMembers
|
||||
|
||||
addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated
|
||||
| otherwise -> MsgSubmissionUpdated
|
||||
return smid
|
||||
cID <- encrypt smid
|
||||
return $ Just cID
|
||||
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
|
||||
_other -> return Nothing
|
||||
-- Since invitations carry no data we only need to consider changes to
|
||||
-- the set of users/invited emails
|
||||
-- Otherwise we would have to update old invitations (via
|
||||
-- `sinkInvitationsF`) because their associated @DBData@ might have
|
||||
-- changed
|
||||
|
||||
forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if
|
||||
-- change is a new user being added to the submission users => send invitation / insert
|
||||
| change `Set.member` subUsers -> case change of
|
||||
Left subEmail -> do
|
||||
-- user does not exist yet => send invitation
|
||||
sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))]
|
||||
return ()
|
||||
Right subUid -> do
|
||||
-- user exists and has an id => insert as SubmissionUser and audit
|
||||
insert_ $ SubmissionUser subUid smid
|
||||
audit $ TransactionSubmissionUserEdit smid subUid
|
||||
unless (Just subUid == muid) $
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid
|
||||
-- change is an old user that is not a submission user anymore => delete invitation / delete
|
||||
| otherwise -> case change of
|
||||
Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
|
||||
Right subUid -> do
|
||||
deleteBy $ UniqueSubmissionUser subUid smid
|
||||
audit $ TransactionSubmissionUserDelete smid subUid
|
||||
unless (Just subUid == muid) $
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
|
||||
|
||||
addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated
|
||||
| otherwise -> MsgSubmissionUpdated
|
||||
Just <$> encrypt smid
|
||||
|
||||
case mCID of
|
||||
Just cID -> do
|
||||
|
||||
@ -36,7 +36,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||
getCorrectionsUploadR = postCorrectionsUploadR
|
||||
postCorrectionsUploadR = do
|
||||
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ (,)
|
||||
<$> areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
|
||||
<$> areq (zipFileField True Nothing True) (fslI MsgCorrUploadField) Nothing
|
||||
<*> apopt (explainedSelectionField Nothing $ explainOptionList optionsFinite explainSubmissionDoneMode) (fslI MsgCorrUploadSubmissionDoneMode & setTooltip MsgCorrUploadSubmissionDoneModeTip) (Just SubmissionDoneByFile)
|
||||
|
||||
formResult uploadRes $ \(files, doneMode) -> do
|
||||
|
||||
@ -589,8 +589,9 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
[ ( UploadModeNone, pure NoUpload)
|
||||
, ( UploadModeAny
|
||||
, UploadAny
|
||||
<$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _unpackZips))
|
||||
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
<$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _uploadUnpackZips))
|
||||
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _uploadExtensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
<*> apopt checkBoxField (fslI MsgUploadAnyEmptyOk & setTooltip MsgUploadAnyEmptyOkTip) (preview (_Just . _uploadEmptyOk) prev <|> Just False)
|
||||
)
|
||||
, ( UploadModeSpecific
|
||||
, UploadSpecific <$> specificFileForm
|
||||
@ -613,7 +614,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
currentRoute <- currentRoute'
|
||||
return . SomeRoute $ currentRoute :#: frag
|
||||
miIdent <- ("specific-files--" <>) <$> newIdent
|
||||
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles) True (preProcess <$> prev ^? _Just . _specificFiles)
|
||||
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles) True (preProcess <$> prev ^? _Just . _uploadSpecificFiles)
|
||||
where
|
||||
preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
|
||||
preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
|
||||
@ -640,10 +641,11 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
sFileForm nudge mPrevUF csrf = do
|
||||
(labelRes, labelView) <- mpreq textField (fslI MsgUploadSpecificFileLabel & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
|
||||
(nameRes, nameView) <- mpreq textField (fslI MsgUploadSpecificFileName & addName (nudge "name")) $ specificFileName <$> mPrevUF
|
||||
(emptyOkRes, emptyOkView) <- mpopt checkBoxField (fslI MsgUploadSpecificFileEmptyOk & addName (nudge "empty-ok")) $ fmap specificFileEmptyOk mPrevUF <|> Just False
|
||||
(maxSizeRes, maxSizeView) <- mopt (natFieldI MsgUploadSpecificFileMaxSizeNegative) (fslI MsgUploadSpecificFileMaxSize & addName (nudge "max-size")) $ specificFileMaxSize <$> mPrevUF
|
||||
(reqRes, reqView) <- mpreq checkBoxField (fslI MsgUploadSpecificFileRequired & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
|
||||
|
||||
return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes <*> maxSizeRes
|
||||
return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes <*> emptyOkRes <*> maxSizeRes
|
||||
, $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
|
||||
)
|
||||
|
||||
@ -851,6 +853,7 @@ data FileField = FileField
|
||||
, fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
|
||||
, fieldAdditionalFiles :: Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)
|
||||
, fieldMaxFileSize :: Maybe Natural
|
||||
, fieldAllEmptyOk :: Bool
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
genericFileField :: forall m.
|
||||
@ -987,10 +990,26 @@ genericFileField mkOpts = Field{..}
|
||||
)
|
||||
.| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..})
|
||||
mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent)
|
||||
(fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc
|
||||
(fSrc'', allEmpty) <- if
|
||||
| fieldAllEmptyOk -> return (fSrc, False)
|
||||
| otherwise
|
||||
-> let checkEmpty = do
|
||||
(peeked, failed) <- go []
|
||||
mapM_ leftover $ peeked ++ hoistMaybe failed
|
||||
return $ is _Nothing failed
|
||||
go acc = do
|
||||
next <- await
|
||||
case next of
|
||||
Nothing -> return (reverse acc, Nothing)
|
||||
Just x
|
||||
| isEmptyFileReference x -> go $ x : acc
|
||||
| otherwise -> return (reverse acc, Just x)
|
||||
in liftHandler . over (mapped . _1) unsealConduitT $ fSrc $$+ checkEmpty
|
||||
(fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc''
|
||||
$logDebugS "genericFileField.fieldParse" $ tshow nFiles
|
||||
if
|
||||
| nFiles <= 0 -> return Nothing
|
||||
| allEmpty -> throwE $ SomeMessage MsgUploadAtLeastOneNonemptyFile
|
||||
| nFiles <= 1 -> return $ Just fSrc'
|
||||
| not fieldMultiple -> do
|
||||
liftHandler . runDB . runConduit $
|
||||
@ -1060,6 +1079,7 @@ fileFieldMultiple = genericFileField $ return FileField
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
|
||||
@ -1070,6 +1090,7 @@ fileField = genericFileField $ return FileField
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
|
||||
@ -1080,20 +1101,23 @@ specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id
|
||||
, fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
, fieldMaxFileSize = specificFileMaxSize
|
||||
, fieldAllEmptyOk = specificFileEmptyOk
|
||||
}
|
||||
where
|
||||
fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName)
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Bool -- ^ Empty files ok?
|
||||
-> Field Handler FileUploads
|
||||
zipFileField doUnpack permittedExtensions = genericFileField $ return FileField
|
||||
zipFileField doUnpack permittedExtensions emptyOk = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True doUnpack
|
||||
, fieldMultiple = doUnpack
|
||||
, fieldRestrictExtensions = permittedExtensions
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = emptyOk
|
||||
}
|
||||
|
||||
fileUploadForm :: Bool -- ^ Required?
|
||||
@ -1103,13 +1127,13 @@ fileUploadForm isReq mkFs = \case
|
||||
NoUpload
|
||||
-> pure Nothing
|
||||
UploadAny{..}
|
||||
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
||||
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField uploadUnpackZips uploadExtensionRestriction uploadEmptyOk) (mkFs uploadUnpackZips) Nothing
|
||||
UploadSpecific{..}
|
||||
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
|
||||
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable uploadSpecificFiles)
|
||||
where
|
||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
||||
specificFileForm spec@UploadSpecificFile{..}
|
||||
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
|
||||
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) (specificFileRequired && isReq) (specificFileField spec) (fsl specificFileLabel) Nothing
|
||||
|
||||
mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads
|
||||
mergeFileSources (catMaybes -> sources) = case sources of
|
||||
@ -1133,6 +1157,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
|
||||
| FileReference{..} <- Set.toList permitted
|
||||
]
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
data SheetGrading' = Points' | PassPoints' | PassBinary' | PassAlways'
|
||||
|
||||
@ -17,6 +17,7 @@ import Jobs.Queue
|
||||
import Yesod.Core.Types (HandlerContents(..))
|
||||
|
||||
import Control.Monad.State.Class as State
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
|
||||
@ -544,8 +545,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
|
||||
sId <- insert Submission{..}
|
||||
audit $ TransactionSubmissionEdit sId sheetId
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
|
||||
return sId
|
||||
Right sId -> return sId
|
||||
|
||||
@ -561,7 +560,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
guardFileTitles SubmissionMode{..}
|
||||
| Just UploadAny{..} <- submissionModeUser
|
||||
, not isUpdate
|
||||
, Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
|
||||
, Just (map unpack . Set.toList . toNullable -> exts) <- uploadExtensionRestriction
|
||||
= Conduit.mapM $ \x -> if
|
||||
| Left FileReference{..} <- x
|
||||
, none ((flip isExtensionOf `on` CI.foldCase) fileReferenceTitle) exts
|
||||
@ -717,7 +716,11 @@ sinkSubmission userId mExists isUpdate = do
|
||||
-> submissionSheet <$> getJust submissionId -- there must have been a submission, otherwise mExists would have been Left shid
|
||||
|
||||
finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
|
||||
finalize SubmissionSinkState{..} = do
|
||||
finalize sState = do
|
||||
SubmissionSinkState{..} <- flip execStateT sState $
|
||||
when (is _Left mExists)
|
||||
touchSubmission
|
||||
|
||||
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
||||
unless isUpdate $
|
||||
|
||||
@ -372,8 +372,8 @@ customMigrations = Map.fromListWith (>>)
|
||||
( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing
|
||||
( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing
|
||||
( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload)
|
||||
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
|
||||
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
|
||||
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction True)
|
||||
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True)
|
||||
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
|
||||
|
||||
@ -22,6 +22,9 @@ import Data.Maybe (fromJust)
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
|
||||
data SheetGrading
|
||||
= Points { maxPoints :: Points }
|
||||
@ -186,36 +189,68 @@ data UploadSpecificFile = UploadSpecificFile
|
||||
{ specificFileLabel :: Text
|
||||
, specificFileName :: FileName
|
||||
, specificFileRequired :: Bool
|
||||
, specificFileEmptyOk :: Bool
|
||||
, specificFileMaxSize :: Maybe Natural
|
||||
} deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
, omitNothingFields = True
|
||||
} ''UploadSpecificFile
|
||||
instance ToJSON UploadSpecificFile where
|
||||
toJSON UploadSpecificFile{..} = Aeson.object
|
||||
[ "label" Aeson..= specificFileLabel
|
||||
, "name" Aeson..= specificFileName
|
||||
, "required" Aeson..= specificFileRequired
|
||||
, "empty-ok" Aeson..= specificFileEmptyOk
|
||||
, "max-size" Aeson..= specificFileMaxSize
|
||||
]
|
||||
instance FromJSON UploadSpecificFile where
|
||||
parseJSON = Aeson.withObject "UploadSpecificFile" $ \o -> do
|
||||
specificFileLabel <- o Aeson..: "label"
|
||||
specificFileName <- o Aeson..: "name"
|
||||
specificFileRequired <- o Aeson..:? "required" Aeson..!= False
|
||||
specificFileEmptyOk <- o Aeson..:? "empty-ok" Aeson..!= True
|
||||
specificFileMaxSize <- o Aeson..:? "max-size"
|
||||
return UploadSpecificFile{..}
|
||||
derivePersistFieldJSON ''UploadSpecificFile
|
||||
|
||||
data UploadMode = NoUpload
|
||||
| UploadAny
|
||||
{ unpackZips :: Bool
|
||||
, extensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
{ uploadUnpackZips :: Bool
|
||||
, uploadExtensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
, uploadEmptyOk :: Bool
|
||||
}
|
||||
| UploadSpecific
|
||||
{ specificFiles :: NonNull (Set UploadSpecificFile)
|
||||
{ uploadSpecificFiles :: NonNull (Set UploadSpecificFile)
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = \c -> if
|
||||
| c == "UploadAny" -> "upload"
|
||||
| otherwise -> camelToPathPiece c
|
||||
, fieldLabelModifier = camelToPathPiece
|
||||
, sumEncoding = TaggedObject "mode" "settings"
|
||||
, omitNothingFields = True
|
||||
}''UploadMode
|
||||
instance ToJSON UploadMode where
|
||||
toJSON NoUpload = Aeson.object [ "mode" Aeson..= ("no-upload" :: String) ]
|
||||
toJSON UploadAny{..} = Aeson.object $ catMaybes
|
||||
[ pure $ "mode" Aeson..= ("upload" :: String)
|
||||
, pure $ "unpack-zips" Aeson..= uploadUnpackZips
|
||||
, ("extension-restriction" Aeson..=) <$> assertM' (is _Just) uploadExtensionRestriction
|
||||
, pure $ "empty-ok" Aeson..= uploadEmptyOk
|
||||
]
|
||||
toJSON UploadSpecific{..} = Aeson.object
|
||||
[ "mode" Aeson..= ("upload-specific" :: String)
|
||||
, "specific-files" Aeson..= uploadSpecificFiles
|
||||
]
|
||||
instance FromJSON UploadMode where
|
||||
parseJSON = Aeson.withObject "UploadMode" $ \o -> do
|
||||
mode <- o Aeson..: "mode" :: Aeson.Parser String
|
||||
case mode of
|
||||
"no-upload" -> return NoUpload
|
||||
"upload" -> do
|
||||
uploadUnpackZips <- o Aeson..:? "unpack-zips" Aeson..!= True
|
||||
uploadExtensionRestriction <- o Aeson..:? "extension-restriction"
|
||||
uploadEmptyOk <- o Aeson..:? "empty-ok" Aeson..!= True
|
||||
return UploadAny{..}
|
||||
"upload-specific" -> do
|
||||
uploadSpecificFiles <- o Aeson..: "specific-files"
|
||||
return UploadSpecific{..}
|
||||
_ -> fail $ "Unrecognised mode for UploadMode, expecting one of (no-upload|upload|upload-specific): “" <> mode <> "”"
|
||||
derivePersistFieldJSON ''UploadMode
|
||||
|
||||
data UploadModeDescr = UploadModeAny
|
||||
|
||||
@ -939,6 +939,9 @@ takeWhileTime maxT = do
|
||||
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
|
||||
|
||||
runPeekWhile :: forall o m. Monad m => (o -> Bool) -> ConduitT () o m () -> m (ConduitT () o m (), [o])
|
||||
runPeekWhile f src = over (mapped . _1) unsealConduitT $ src $$+ peekWhile f
|
||||
|
||||
-----------------
|
||||
-- Alternative --
|
||||
-----------------
|
||||
|
||||
@ -6,6 +6,7 @@ module Utils.Files
|
||||
, FileUploads
|
||||
, replaceFileReferences, replaceFileReferences'
|
||||
, sinkFileDB, sinkFileMinio
|
||||
, isEmptyFileReference
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -233,3 +234,6 @@ replaceFileReferences :: ( MonadHandler m, MonadThrow m
|
||||
-> FileUploads
|
||||
-> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
|
||||
replaceFileReferences mkFilter residual fs = runConduit $ transPipe liftHandler fs .| replaceFileReferences' mkFilter residual
|
||||
|
||||
isEmptyFileReference :: HasFileReference ref => ref -> Bool
|
||||
isEmptyFileReference = views (_FileReference . _1 . _fileReferenceContent) (maybe True (== $$(liftTyped $ FileContentReference $$(emptyHash))))
|
||||
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kursverwalter können nun angeben ob Uploads, die nur aus leeren Dateien und/oder Verzeichnissen bestehen, pro Übungsblatt akzeptiert werden sollen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Course administrators can now specify whether uploads, which consist solely of empty files and/or directories, are to be accepted on a per-exercise-sheet basis
|
||||
@ -1,5 +1,6 @@
|
||||
$newline never
|
||||
<td>#{csrf}^{fvWidget labelView}
|
||||
<td>^{fvWidget nameView}
|
||||
<td>^{fvWidget emptyOkView}
|
||||
<td>^{fvWidget maxSizeView}
|
||||
<td>^{fvWidget reqView}
|
||||
|
||||
@ -3,6 +3,7 @@ $newline never
|
||||
<thead>
|
||||
<th>_{MsgUploadSpecificFileLabel}
|
||||
<th>_{MsgUploadSpecificFileName}
|
||||
<th>_{MsgUploadSpecificFileEmptyOk}
|
||||
<th>_{MsgUploadSpecificFileMaxSize}
|
||||
<th>_{MsgUploadSpecificFileRequired}
|
||||
<td>
|
||||
|
||||
@ -648,7 +648,7 @@ fillDb = do
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = False
|
||||
@ -667,7 +667,7 @@ fillDb = do
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = False
|
||||
@ -686,7 +686,7 @@ fillDb = do
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = False
|
||||
@ -852,15 +852,16 @@ fillDb = do
|
||||
[ SubmissionMode corrector Nothing
|
||||
, SubmissionMode corrector $ Just NoUpload
|
||||
, SubmissionMode corrector $ Just UploadSpecific
|
||||
{ specificFiles = impureNonNull $ Set.fromList
|
||||
[ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False Nothing
|
||||
, UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False Nothing
|
||||
, UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True (Just 42)
|
||||
{ uploadSpecificFiles = impureNonNull $ Set.fromList
|
||||
[ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False False Nothing
|
||||
, UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False False Nothing
|
||||
, UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True True (Just 42)
|
||||
]
|
||||
}
|
||||
] ++ [ SubmissionMode corrector $ Just UploadAny{..}
|
||||
| unpackZips <- universeF
|
||||
, extensionRestriction <- [ Nothing, Just . impureNonNull $ Set.fromList ["pdf", "txt", "jpeg", "hs"] ]
|
||||
| uploadUnpackZips <- universeF
|
||||
, uploadExtensionRestriction <- [ Nothing, Just . impureNonNull $ Set.fromList ["pdf", "txt", "jpeg", "hs"] ]
|
||||
, let uploadEmptyOk = False
|
||||
]
|
||||
|
||||
sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes)
|
||||
@ -872,8 +873,8 @@ fillDb = do
|
||||
| Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just
|
||||
= let
|
||||
extra = catMaybes
|
||||
[ guardOn (fromMaybe False $ userMode ^? _unpackZips) $ mr MsgAutoUnzip
|
||||
, guardOn (maybe False (is _Just) $ userMode ^? _extensionRestriction) $ mr MsgUploadModeExtensionRestriction
|
||||
[ guardOn (fromMaybe False $ userMode ^? _uploadUnpackZips) $ mr MsgAutoUnzip
|
||||
, guardOn (maybe False (is _Just) $ userMode ^? _uploadExtensionRestriction) $ mr MsgUploadModeExtensionRestriction
|
||||
]
|
||||
in mr (classifySubmissionMode sheetSubmissionMode) <> " (" <> Text.intercalate ", " (mr (classifyUploadMode userMode) : extra) <> ")"
|
||||
| Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just
|
||||
@ -1154,7 +1155,7 @@ fillDb = do
|
||||
, sheetVisibleFrom = Just $ termTime False Winter (fromInteger shNr) False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = False
|
||||
|
||||
@ -106,6 +106,7 @@ instance Arbitrary UploadSpecificFile where
|
||||
<*> (pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadMode where
|
||||
@ -114,6 +115,7 @@ instance Arbitrary UploadMode where
|
||||
, UploadAny
|
||||
<$> arbitrary
|
||||
<*> (fromNullable . Set.fromList . map (pack . getPrintableString) <$> arbitrary)
|
||||
<*> arbitrary
|
||||
, UploadSpecific <$> arbitrary
|
||||
]
|
||||
shrink = genericShrink
|
||||
@ -438,6 +440,14 @@ spec = do
|
||||
encEx 65536 [1, 0, 0]
|
||||
encEx 65537 [1, 0, 1]
|
||||
encEx 197121 [3, 2, 1]
|
||||
describe "SubmissionMode" $ do
|
||||
it "decodes some examples" . example $ do
|
||||
let t str = Aeson.eitherDecode str `shouldSatisfy` (is _Right :: Either _ SubmissionMode -> Bool)
|
||||
t "{\"user\": {\"mode\": \"upload\", \"unpack-zips\": true, \"extension-restriction\": [\"R\", \"pdf\", \"txt\"]}, \"corrector\": false}"
|
||||
t "{\"user\": {\"mode\": \"upload\", \"unpack-zips\": false}, \"corrector\": false}"
|
||||
t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe6.pdf\", \"label\": \"Abgabe 6\", \"required\": true}]}, \"corrector\": false}"
|
||||
t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe10.pdf\", \"label\": \"Abgabe 10\", \"required\": true}, {\"name\": \"deckblatt10.pdf\", \"label\": \"Deckblatt 10\", \"required\": true}]}, \"corrector\": false}"
|
||||
t "{\"user\": {\"mode\": \"no-upload\"}, \"corrector\": false}"
|
||||
|
||||
termExample :: (TermIdentifier, Text) -> Expectation
|
||||
termExample (term, encoded) = example $ do
|
||||
|
||||
Reference in New Issue
Block a user