Merge branch 'master' into workflows
This commit is contained in:
Gregor Kleen
commit
a0e5edeaef
@ -2,6 +2,13 @@
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
||||
@ -508,6 +508,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
|
||||
@ -893,6 +894,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
|
||||
@ -909,6 +912,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
|
||||
|
||||
@ -505,6 +505,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.
|
||||
@ -879,6 +880,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
|
||||
@ -895,6 +898,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.3",
|
||||
"version": "21.1.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "21.0.3",
|
||||
"version": "21.1.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 21.0.3
|
||||
version: 21.1.0
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
|
||||
@ -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
|
||||
|
||||
@ -593,8 +593,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
|
||||
@ -617,7 +618,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
|
||||
@ -644,10 +645,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")
|
||||
)
|
||||
|
||||
@ -977,10 +979,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 $
|
||||
@ -1050,6 +1068,7 @@ fileFieldMultiple = genericFileField $ return FileField
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
|
||||
@ -1069,6 +1088,7 @@ singleFileField prev = genericFileField $ do
|
||||
| FileReference{..} <- Set.toList permitted
|
||||
]
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
|
||||
@ -1079,20 +1099,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 = _FileReferenceFileReferenceTitleMap # 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 = _FileReferenceFileReferenceTitleMap # Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldAllEmptyOk = emptyOk
|
||||
}
|
||||
|
||||
fileUploadForm :: Bool -- ^ Required?
|
||||
@ -1102,13 +1125,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
|
||||
@ -1132,6 +1155,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 $
|
||||
|
||||
@ -76,6 +76,7 @@ instance FromJSON (FileField FileIdent) where
|
||||
fieldMultiple <- o JSON..: "multiple"
|
||||
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
||||
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
||||
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
||||
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
||||
fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do
|
||||
fIdentTitleMapIdent <- o' JSON..: "Ident"
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -259,6 +259,7 @@ data FileField fileid = FileField
|
||||
, fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
|
||||
, fieldMaxFileSize :: Maybe Natural
|
||||
, fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool)
|
||||
, fieldAllEmptyOk :: Bool
|
||||
} deriving (Generic, Typeable)
|
||||
deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid)
|
||||
deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid)
|
||||
@ -273,6 +274,7 @@ instance ToJSON (FileField FileReference) where
|
||||
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
|
||||
, pure $ "max-file-size" JSON..= fieldMaxFileSize
|
||||
, pure $ "additional-files" JSON..= addFiles'
|
||||
, pure $ "all-empty-ok" JSON..= fieldAllEmptyOk
|
||||
]
|
||||
where addFiles' = unFileReferenceFileReferenceTitleMap fieldAdditionalFiles <&> \FileReferenceFileReferenceTitleMapElem{..} -> JSON.object
|
||||
[ "content" JSON..= fRefTitleMapContent
|
||||
@ -286,6 +288,7 @@ instance FromJSON (FileField FileReference) where
|
||||
fieldMultiple <- o JSON..: "multiple"
|
||||
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
||||
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
||||
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
||||
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
||||
fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do
|
||||
fRefTitleMapContent <- o' JSON..: "content"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -951,6 +951,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 --
|
||||
-----------------
|
||||
|
||||
@ -139,3 +139,17 @@ put :: ( MonadIO m
|
||||
put v = do
|
||||
forM_ (persistUniqueKeys v) deleteBy
|
||||
insert v
|
||||
|
||||
selectMaybe :: forall record backend m.
|
||||
( MonadIO m
|
||||
, PersistQueryRead backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> [Filter record] -> [SelectOpt record]
|
||||
-> ReaderT backend m (Maybe (Entity record))
|
||||
selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
|
||||
where opts' = filter (not . isLimit) opts
|
||||
isLimit = \case
|
||||
LimitTo _ -> True
|
||||
_other -> False
|
||||
|
||||
|
||||
@ -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>
|
||||
|
||||
@ -35,6 +35,9 @@ import qualified Data.Yaml as Yaml
|
||||
|
||||
import Utils.Workflow.Lint
|
||||
|
||||
import System.Directory (getModificationTime)
|
||||
import System.FilePath.Glob (glob)
|
||||
|
||||
|
||||
testdataDir :: FilePath
|
||||
testdataDir = "testdata"
|
||||
@ -603,7 +606,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
|
||||
@ -622,7 +625,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
|
||||
@ -641,7 +644,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
|
||||
@ -807,15 +810,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)
|
||||
@ -827,8 +831,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
|
||||
@ -1109,7 +1113,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
|
||||
@ -1322,3 +1326,19 @@ fillDb = do
|
||||
, workflowInstanceDescriptionTitle = "Abschlussarbeiten"
|
||||
, workflowInstanceDescriptionDescription = Just "Hier können Sie Abschlussarbeiten bei der Prüfungsverwaltung angemeldet werden, der relevante Student die Arbeit digital abgeben und im Anschluss auch die Benotung an die Prüfungsverwaltung übermittelt werden."
|
||||
}
|
||||
|
||||
forM_ universeF $ \changelogItem -> do
|
||||
let ptn = "templates/i18n/changelog/" <> unpack (toPathPiece changelogItem) <> ".*"
|
||||
files <- liftIO $ glob ptn
|
||||
mTime <- fmap minimum . fromNullable <$> mapM (liftIO . getModificationTime) files
|
||||
whenIsJust mTime $ \(utctDay -> firstSeen) -> do
|
||||
oldFirstSeen <- selectMaybe [ ChangelogItemFirstSeenItem ==. changelogItem ] [ Asc ChangelogItemFirstSeenFirstSeen ]
|
||||
case oldFirstSeen of
|
||||
Just (Entity firstSeenId oldEntry)
|
||||
| changelogItemFirstSeenFirstSeen oldEntry > firstSeen
|
||||
-> update firstSeenId [ ChangelogItemFirstSeenFirstSeen =. firstSeen ]
|
||||
Just _
|
||||
-> return ()
|
||||
Nothing
|
||||
-> insert_ $ ChangelogItemFirstSeen changelogItem firstSeen
|
||||
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Types.WorkflowSpec where
|
||||
|
||||
import TestImport hiding (NonEmpty)
|
||||
@ -106,11 +108,11 @@ instance (Arbitrary fileid, Arbitrary userid, Ord fileid, Typeable userid, Typea
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Scientific)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Bool)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Day)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid (Set fileid))
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid fileid)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid userid)
|
||||
]
|
||||
|
||||
instance (Arbitrary payload, IsWorkflowFieldPayload fileid userid payload) => Arbitrary (WorkflowFieldPayload fileid userid payload) where
|
||||
instance (Arbitrary payload, IsWorkflowFieldPayload' fileid userid payload) => Arbitrary (WorkflowFieldPayload fileid userid payload) where
|
||||
arbitrary = review _WorkflowFieldPayload <$> arbitrary
|
||||
|
||||
instance Arbitrary WorkflowScope' where
|
||||
|
||||
@ -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
|
||||
@ -434,6 +436,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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user