Merge branch 'master' into 740-labels

This commit is contained in:
Sarah Vaupel 2022-01-21 17:42:10 +01:00
commit 1236b13759
32 changed files with 267 additions and 85 deletions

View File

@ -2,6 +2,50 @@
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. 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.
## [25.25.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.24.1...v25.25.0) (2022-01-21)
### Features
* **communication:** support attachments in course/tutorial comm's ([5bd9ea8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bd9ea85e8f0e4387cf47116bf42c4441bdbe8b3))
* **file-field:** cumulative size limit ([b749039](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b749039636c61157b5fc0bea9848ab9828ee671c))
## [25.24.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.24.0...v25.24.1) (2021-12-29)
### Bug Fixes
* **courses:** enhanced description of study modules ([89fadb2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/89fadb242037151ea792667cab85fc502b135f57))
## [25.24.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.23.0...v25.24.0) (2021-12-28)
### Features
* **course:** show study module on course overview page ([dbc5e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dbc5e99109285d4427832820a77a6b47a8098f62))
* **course:** study modules as new course property ([cb00de7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb00de7960c91d87f5f8fb7ecb29dd15cb61a5a3))
## [25.23.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.22.4...v25.23.0) (2021-12-14)
### Features
* **check-all:** added shift click functionality ([da1c8b5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/da1c8b54510ee1436fefe97ba32372a08299b83e))
* **checkrange:** added tooltip ([ce6f09d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce6f09dd857f53dc8c350d7d29b2164c78645b59))
* **checkrange:** new util checkrange ([337bf73](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/337bf73067f2b98450d0388a1c064f0d2f9c456c))
* **checkrange:** unchecking a range is possible ([154f2e3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/154f2e35cc0e154ff80002b2e0aff3a76afa1ed6))
* **erweiterung such-filter usersr:** first try ([da3b339](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/da3b3391bd5aa9990dfb2818847cf8524ee68a9d))
* **messages:** added frontend translation class ([61c773f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/61c773f51cddb65dd0529f17799cbf7871023137))
* **tooltips:** added translatable tooltip ([e74b610](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e74b61065a5de811bd411c0e863fddf9b9baada0))
### Bug Fixes
* **check-all:** correct constructor argument ([02ce82e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02ce82e9d2026730fd4716a2c0b070c38a6fc53f))
* **frontend-tooltips:** icon is shown ([86ee2fb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/86ee2fb14c05e3b6a78c6c51bf961b6c41d3e5c5))
* **modal:** modals are never destroyed ([7dbe1ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7dbe1ac08aacbda3b145a0da394706273dd6c639))
* **modal:** modals are never destroyed ([53dab90](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/53dab90810675f743ece284883da9c4c0e84270e))
## [25.22.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.22.3...v25.22.4) (2021-10-26) ## [25.22.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.22.3...v25.22.4) (2021-10-26)

View File

@ -292,3 +292,5 @@ bot-mitigations:
- only-logged-in-table-sorting - only-logged-in-table-sorting
volatile-cluster-settings-cache-time: 10 volatile-cluster-settings-cache-time: 10
communication-attachments-max-size: 20971520 # 20MiB

View File

@ -45,7 +45,7 @@ export class CheckAll {
let checkboxColumns = this._findCheckboxColumns(); let checkboxColumns = this._findCheckboxColumns();
checkboxColumns.forEach(columnId => this._checkAllColumns.push(new CheckAllColumn(this._element, app, this._columns[columnId]))); checkboxColumns.forEach(columnId => this._checkAllColumns.push(new CheckAllColumn(this._element, app, this._columns[columnId], this._eventManager)));
// mark initialized // mark initialized
this._element.classList.add(CHECK_ALL_INITIALIZED_CLASS); this._element.classList.add(CHECK_ALL_INITIALIZED_CLASS);

View File

@ -107,7 +107,7 @@ export class NavigateAwayPrompt {
// allow the event to happen if the form was not touched by the // allow the event to happen if the form was not touched by the
// user (i.e. if the current FormData is equal to the initial FormData) // user (i.e. if the current FormData is equal to the initial FormData)
// or the unload event was initiated by a form submit // or the unload event was initiated by a form submit
if (!formDataHasChanged || this.unloadDueToSubmit) if (!formDataHasChanged || this.unloadDueToSubmit || this._parentModalIsClosed())
return; return;
// cancel the unload event. This is the standard to force the prompt to appear. // cancel the unload event. This is the standard to force the prompt to appear.
@ -117,4 +117,13 @@ export class NavigateAwayPrompt {
// for all non standard compliant browsers we return a truthy value to activate the prompt. // for all non standard compliant browsers we return a truthy value to activate the prompt.
return true; return true;
} }
_parentModalIsClosed() {
const parentModal = this._element.closest('.modal');
if (!parentModal)
return false;
const modalClosed = !parentModal.classList.contains('modal--open');
return modalClosed;
}
} }

View File

@ -72,16 +72,7 @@ export class Modal {
} }
destroy() { destroy() {
this._eventManager.cleanUp(); throw new Error('Destroying modals is not possible.');
if (this._closerElement !== undefined)
this._closerElement.remove();
if(this._triggerElement !== undefined)
this._triggerElement.classList.remove(MODAL_TRIGGER_CLASS);
if(this._modalsWrapper !== undefined)
this._modalsWrapper.remove();
if(this._modalOverlay !== undefined)
this._modalOverlay.remove();
this._element.classList.remove(MODAL_INITIALIZED_CLASS, MODAL_CLASS);
} }
_ensureModalWrapper() { _ensureModalWrapper() {
@ -164,7 +155,6 @@ export class Modal {
this._modalsWrapper.classList.remove(MODALS_WRAPPER_OPEN_CLASS); this._modalsWrapper.classList.remove(MODALS_WRAPPER_OPEN_CLASS);
document.removeEventListener('keyup', this._onKeyUp); document.removeEventListener('keyup', this._onKeyUp);
this._app.utilRegistry.destroyAll(this._element);
}; };
_fillModal(url) { _fillModal(url) {

View File

@ -186,6 +186,7 @@ UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen ang
UploadModeExtensionRestrictionMultipleTip: Einschränkung von Dateiendungen erfolgt für alle hochgeladenen Dateien, auch innerhalb von ZIP-Archiven. UploadModeExtensionRestrictionMultipleTip: Einschränkung von Dateiendungen erfolgt für alle hochgeladenen Dateien, auch innerhalb von ZIP-Archiven.
FileUploadMaxSize maxSize@Text: Datei darf maximal #{maxSize} groß sein FileUploadMaxSize maxSize@Text: Datei darf maximal #{maxSize} groß sein
FileUploadMaxSizeMultiple maxSize@Text: Dateien dürfen jeweils maximal #{maxSize} groß sein FileUploadMaxSizeMultiple maxSize@Text: Dateien dürfen jeweils maximal #{maxSize} groß sein
FileUploadCumulativeMaxSize maxSize@Text: Dateien dürfen insgesamt maximal #{maxSize} groß sein
InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}" InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte. InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte.

View File

@ -186,6 +186,8 @@ UploadModeExtensionRestrictionTip: Comma-separated. If no file extensions are sp
UploadModeExtensionRestrictionMultipleTip: Checks for valid file extension are performed for all uploaded files, including those packed within zip-archives. UploadModeExtensionRestrictionMultipleTip: Checks for valid file extension are performed for all uploaded files, including those packed within zip-archives.
FileUploadMaxSize maxSize: File may be up to #{maxSize} in size FileUploadMaxSize maxSize: File may be up to #{maxSize} in size
FileUploadMaxSizeMultiple maxSize: Files may each be up to #{maxSize} in size FileUploadMaxSizeMultiple maxSize: Files may each be up to #{maxSize} in size
FileUploadCumulativeMaxSize maxSize: Files may be no larger than #{maxSize} in total
InvalidPseudonym pseudonym: Invalid pseudonym “#{pseudonym}” InvalidPseudonym pseudonym: Invalid pseudonym “#{pseudonym}”
InvalidPseudonymSubmissionIgnored oPseudonyms iPseudonym: The submission with pseudonyms “#{oPseudonyms}” has been ignored since “#{iPseudonym}” could not be automatically corrected to be a valid pseudonym. InvalidPseudonymSubmissionIgnored oPseudonyms iPseudonym: The submission with pseudonyms “#{oPseudonyms}” has been ignored since “#{iPseudonym}” could not be automatically corrected to be a valid pseudonym.
PseudonymAutocorrections: Suggestions: PseudonymAutocorrections: Suggestions:

View File

@ -17,6 +17,8 @@ RGTutorialParticipants tutn@TutorialName: Tutorium-Teilnehmer:innen (#{tutn})
RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“ RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
CommSubject: Betreff CommSubject: Betreff
CommAttachments: Anhänge
CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zum Kurs anmelden, haben Zugriff auf die Datei.
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
CommTestSuccess: Nachricht wurde zu Testzwecken nur an Sie selbst versandt CommTestSuccess: Nachricht wurde zu Testzwecken nur an Sie selbst versandt
@ -53,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximale Dateigröße darf nicht negativ sein
UploadSpecificFileEmptyOk: Leere Uploads erlauben UploadSpecificFileEmptyOk: Leere Uploads erlauben
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
GenericFileFieldFileTooLarge file@FilePath: „#{file}“ ist zu groß GenericFileFieldFileTooLarge file@FilePath: „#{file}“ ist zu groß
GenericFileFieldCumulativeTooLarge: Hochgeladene Dateien sind zu groß
GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
OnlyUploadOneFile: Bitte nur eine Datei hochladen. OnlyUploadOneFile: Bitte nur eine Datei hochladen.
UploadAtLeastOneNonemptyFile: Bitte mindestens eine nichtleere Datei hochladen. UploadAtLeastOneNonemptyFile: Bitte mindestens eine nichtleere Datei hochladen.

View File

@ -17,6 +17,8 @@ RGTutorialParticipants tutn: Tutorial participants (#{tutn})
RGExamRegistered examn: Registered for exam “#{examn}” RGExamRegistered examn: Registered for exam “#{examn}”
RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}” RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
CommSubject: Subject CommSubject: Subject
CommAttachments: Attachments
CommAttachmentsTip: In general it is preferable to upload files as course material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course at a later date.
CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"} CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
CommTestSuccess: Message was sent only to yourself for testing purposes CommTestSuccess: Message was sent only to yourself for testing purposes
@ -53,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximum filesize may not be negative
UploadSpecificFileEmptyOk: Allow empty uploads UploadSpecificFileEmptyOk: Allow empty uploads
UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}” UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}”
GenericFileFieldFileTooLarge file: “#{file}” is too large GenericFileFieldFileTooLarge file: “#{file}” is too large
GenericFileFieldCumulativeTooLarge: Uploaded files are too large
GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension
OnlyUploadOneFile: Please only upload one file OnlyUploadOneFile: Please only upload one file
UploadAtLeastOneNonemptyFile: Please upload at least one nonempty file. UploadAtLeastOneNonemptyFile: Please upload at least one nonempty file.

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "25.22.4", "version": "25.25.0",
"lockfileVersion": 1, "lockfileVersion": 1,
"requires": true, "requires": true,
"dependencies": { "dependencies": {

View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "25.22.4", "version": "25.25.0",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",

View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 25.22.4 version: 25.25.0
dependencies: dependencies:
- base - base
- yesod - yesod

View File

@ -27,10 +27,10 @@ addStaticContent ext _mime content = do
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
let expiry = maybe 0 ceiling memcachedExpiry let expiry = maybe 0 ceiling memcachedExpiry
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn addItem = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
catchIf Memcached.isKeyNotFound touch . const $ catchIf Memcached.isKeyNotFound touch . const $
handleIf Memcached.isKeyExists (const $ return ()) add handleIf Memcached.isKeyExists (const $ return ()) addItem
return . Left $ pack absoluteLink return . Left $ pack absoluteLink
where where
-- Generate a unique filename based on the content itself, this is used -- Generate a unique filename based on the content itself, this is used

View File

@ -29,29 +29,29 @@ import qualified Data.Conduit.List as C
data CourseForm = CourseForm data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId { cfCourseId :: Maybe CourseId
, cfName :: CourseName , cfName :: CourseName
, cfShort :: CourseShorthand , cfShort :: CourseShorthand
, cfSchool :: SchoolId , cfSchool :: SchoolId
, cfTerm :: TermId , cfTerm :: TermId
, cfDesc :: Maybe StoredMarkup , cfDesc :: Maybe StoredMarkup
, cfLink :: Maybe URI , cfLink :: Maybe URI
, cfVisFrom :: Maybe UTCTime , cfVisFrom :: Maybe UTCTime
, cfVisTo :: Maybe UTCTime , cfVisTo :: Maybe UTCTime
, cfMatFree :: Bool , cfMatFree :: Bool
, cfAllocation :: Maybe AllocationCourseForm , cfAllocation :: Maybe AllocationCourseForm
, cfAppRequired :: Bool , cfAppRequired :: Bool
, cfAppInstructions :: Maybe StoredMarkup , cfAppInstructions :: Maybe StoredMarkup
, cfAppInstructionFiles :: Maybe FileUploads , cfAppInstructionFiles :: Maybe FileUploads
, cfAppText :: Bool , cfAppText :: Bool
, cfAppFiles :: UploadMode , cfAppFiles :: UploadMode
, cfAppRatingsVisible :: Bool , cfAppRatingsVisible :: Bool
, cfCapacity :: Maybe Int , cfCapacity :: Maybe Int
, cfSecret :: Maybe Text , cfSecret :: Maybe Text
, cfRegFrom :: Maybe UTCTime , cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime , cfRegTo :: Maybe UTCTime
, cfDeRegUntil :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
} }
data AllocationCourseForm = AllocationCourseForm data AllocationCourseForm = AllocationCourseForm
@ -278,30 +278,28 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
hoist (censorM $ traverseOf _head addTip) $ optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate) (is _Just . cfAllocation <$> template) hoist (censorM $ traverseOf _head addTip) $ optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate) (is _Just . cfAllocation <$> template)
-- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|]
multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
(cfCourseId =<< template) (cfCourseId =<< template)
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …" <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template) & setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
<* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1) <* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1)
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1) <* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1)
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)) <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder))
(cfDesc <$> template) (cfDesc <$> template)
<*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) <*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
(cfLink <$> template) (cfLink <$> template)
<*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgCourseDate) <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgCourseDate)
& setTooltip MsgCourseVisibleFromTip) (deepAlt (cfVisFrom <$> template) newVisFrom) & setTooltip MsgCourseVisibleFromTip) (deepAlt (cfVisFrom <$> template) newVisFrom)
<*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgCourseDate) <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgCourseDate)
& setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template)
<*> apopt checkBoxField (fslI MsgCourseMaterialFree) (cfMatFree <$> template) <*> apopt checkBoxField (fslI MsgCourseMaterialFree) (cfMatFree <$> template)
<* aformSection MsgCourseFormSectionRegistration <* aformSection MsgCourseFormSectionRegistration
<*> allocationForm <*> allocationForm
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)

View File

@ -167,6 +167,15 @@ postUsersR = do
-- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text) -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
) )
, ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
)
, ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
)
, ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
@ -192,6 +201,8 @@ postUsersR = do
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgTableMatrikelNr) -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgTableMatrikelNr)
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)

View File

@ -78,16 +78,16 @@ data CommunicationRoute = CommunicationRoute
data Communication = Communication data Communication = Communication
{ cRecipients :: Set (Either UserEmail UserId) { cRecipients :: Set (Either UserEmail UserId)
, cSubject :: Maybe Text , cContent :: CommunicationContent
, cBody :: Html
} }
makeLenses_ ''Communication
crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crJobsCourseCommunication jCourse Communication{..} = do crJobsCourseCommunication jCourse Communication{..} = do
jSender <- requireAuthId jSender <- requireAuthId
let jSubject = cSubject let jMailContent = cContent
jMailContent = cBody
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
jMailObjectUUID <- liftIO getRandom jMailObjectUUID <- liftIO getRandom
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
@ -99,7 +99,7 @@ crTestJobsCourseCommunication jCourse comm = do
jSender <- requireAuthId jSender <- requireAuthId
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let comm' = comm { cSubject = Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) $ cSubject comm } let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
@ -206,11 +206,24 @@ commR CommunicationRoute{..} = do
recipientsListMsg <- messageI Info MsgCommRecipientsList recipientsListMsg <- messageI Info MsgCommRecipientsList
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
let attachmentField = genericFileField $ return FileField
{ fieldIdent = Nothing
, fieldUnpackZips = FileFieldUserOption True False
, fieldMultiple = True
, fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
, fieldAllEmptyOk = True
}
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
<$> recipientAForm <$> recipientAForm
<* aformMessage recipientsListMsg <* aformMessage recipientsListMsg
<*> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> ( CommunicationContent
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
)
formResult commRes $ \case formResult commRes $ \case
(comm, BtnCommunicationSend) -> do (comm, BtnCommunicationSend) -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs

View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Utils.Files module Handler.Utils.Files
( sourceFile, sourceFile' ( sourceFile, sourceFile'
, sourceFiles, sourceFiles' , sourceFiles, sourceFiles'
@ -9,6 +11,7 @@ module Handler.Utils.Files
import Import.NoFoundation hiding (First(..)) import Import.NoFoundation hiding (First(..))
import Foundation.Type import Foundation.Type
import Foundation.DB
import Utils.Metrics import Utils.Metrics
import Data.Monoid (First(..)) import Data.Monoid (First(..))
@ -181,6 +184,11 @@ sourceFiles' = C.map sourceFile'
sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile
sourceFile' = sourceFile . view (_FileReference . _1) sourceFile' = sourceFile . view (_FileReference . _1)
instance (YesodMail UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => ToMailPart UniWorX FileReference where
toMailPart = toMailPart <=< liftHandler . runDBRead . withReaderT projectBackend . toPureFile . sourceFile'
respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX) respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
=> Maybe UTCTime -> MimeType => Maybe UTCTime -> MimeType
-> FileReference -> FileReference

View File

@ -998,15 +998,20 @@ genericFileField mkOpts = Field{..}
= not (permittedExtension opts fName) = not (permittedExtension opts fName)
&& (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip) && (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip)
whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do whenIsJust (ignoreNothing min fieldMaxFileSize fieldMaxCumulativeSize) $ \takeSize ->
fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE flip evalAccumT mempty . forM_ files $ \fInfo -> do
when (fLength > maxSize) $ do fLength <- lift . runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ takeSize) .| C.lengthE
when (is _Just mIdent) $ add $ Sum fLength
liftHandler . runDB . runConduit $ Sum cummSize <- look
mapM_ (transPipe lift . handleFile) files when (NTop (Just cummSize) > NTop fieldMaxCumulativeSize || NTop (Just fLength) > NTop fieldMaxFileSize) $ do
.| handleUpload opts mIdent when (is _Just mIdent) $
.| C.sinkNull lift . liftHandler . runDB . runConduit $
throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo mapM_ (transPipe lift . handleFile) files
.| handleUpload opts mIdent
.| C.sinkNull
when (NTop (Just fLength) > NTop fieldMaxFileSize) $ do
lift . throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo
lift . throwE $ SomeMessage MsgGenericFileFieldCumulativeTooLarge
if | invExt : _ <- filter invalidUploadExtension uploadedFilenames if | invExt : _ <- filter invalidUploadExtension uploadedFilenames
-> do -> do
@ -1125,7 +1130,7 @@ fileFieldMultiple = genericFileField $ return FileField
, fieldMultiple = True , fieldMultiple = True
, fieldRestrictExtensions = Nothing , fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
, fieldAllEmptyOk = True , fieldAllEmptyOk = True
} }
@ -1145,7 +1150,7 @@ singleFileField prev = genericFileField $ do
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList permitted | FileReference{..} <- Set.toList permitted
] ]
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
, fieldAllEmptyOk = True , fieldAllEmptyOk = True
} }
@ -1161,7 +1166,7 @@ specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitle
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList previous | FileReference{..} <- Set.toList previous
] ]
, fieldMaxFileSize = specificFileMaxSize , fieldMaxFileSize = specificFileMaxSize, fieldMaxCumulativeSize = Nothing
, fieldAllEmptyOk = specificFileEmptyOk , fieldAllEmptyOk = specificFileEmptyOk
} }
where where
@ -1189,7 +1194,7 @@ zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList previous | FileReference{..} <- Set.toList previous
] ]
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
, fieldAllEmptyOk = emptyOk , fieldAllEmptyOk = emptyOk
} }
@ -1232,7 +1237,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList permitted | FileReference{..} <- Set.toList permitted
] ]
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
, fieldAllEmptyOk = True , fieldAllEmptyOk = True
} }

View File

@ -70,6 +70,7 @@ instance ToJSON (FileField FileIdent) where
, pure $ "multiple" JSON..= fieldMultiple , pure $ "multiple" JSON..= fieldMultiple
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
, pure $ "max-file-size" JSON..= fieldMaxFileSize , pure $ "max-file-size" JSON..= fieldMaxFileSize
, pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize
, pure $ "additional-files" JSON..= addFiles' , pure $ "additional-files" JSON..= addFiles'
] ]
where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object
@ -83,6 +84,7 @@ instance FromJSON (FileField FileIdent) where
fieldMultiple <- o JSON..: "multiple" fieldMultiple <- o JSON..: "multiple"
fieldRestrictExtensions <- o JSON..:? "restrict-extensions" fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
fieldMaxFileSize <- o JSON..:? "max-file-size" fieldMaxFileSize <- o JSON..:? "max-file-size"
fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-size"
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do

View File

@ -118,6 +118,11 @@ import Control.Monad.Trans.State as Import
( State, runState, mapState, withState ( State, runState, mapState, withState
, StateT(..), mapStateT, withStateT , StateT(..), mapStateT, withStateT
) )
import Control.Monad.Trans.Accum as Import
( Accum, runAccum, mapAccum
, AccumT, runAccumT, execAccumT, evalAccumT, mapAccumT
, look, looks, add
)
import Control.Monad.State.Class as Import (MonadState(state)) import Control.Monad.State.Class as Import (MonadState(state))
import Control.Monad.Trans.Writer.Lazy as Import import Control.Monad.Trans.Writer.Lazy as Import
( Writer, runWriter, mapWriter, execWriter ( Writer, runWriter, mapWriter, execWriter

View File

@ -47,6 +47,9 @@ import qualified Data.Foldable as F
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
import Jobs.Types
import Data.Aeson.Lens (_JSON)
dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles :: JobHandler UniWorX
dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin
@ -83,6 +86,9 @@ workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece
, (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)) , (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
] ]
jobFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) ()
jobFileReferences = E.selectSource (E.from $ pure . (E.^. QueuedJobContent)) .| C.mapMaybe (preview _JSON . E.unValue) .| awaitForever (mapMOf_ (typesCustom @JobChildren @Job @Job @FileContentReference @FileContentReference) yield)
dispatchJobDetectMissingFiles :: JobHandler UniWorX dispatchJobDetectMissingFiles :: JobHandler UniWorX
dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
@ -103,8 +109,10 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
E.distinctOnOrderBy [E.asc ref] $ return ref E.distinctOnOrderBy [E.asc ref] $ return ref
transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind) transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind)
iforM_ workflowFileReferences $ \refKind refSource -> let useRefSource refKind refSource = transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind) iforM_ workflowFileReferences useRefSource
useRefSource (nameToPathPiece ''Job) jobFileReferences
let allMissingDb :: Set Minio.Object let allMissingDb :: Set Minio.Object
allMissingDb = setOf (folded . folded . re minioFileReference) missingDb allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
@ -204,14 +212,16 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash) return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
E.where_ $ chunkIdFilter unreferencedChunkHash E.where_ $ chunkIdFilter unreferencedChunkHash
let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do let unmarkSourceFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
E.where_ $ chunkIdFilter unreferencedChunkHash E.where_ $ chunkIdFilter unreferencedChunkHash
unmarkRefSource refSource = runConduit $ refSource .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkSourceFiles
chunkSize = 100 chunkSize = 100
in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles unmarkRefSource $ sequence_ workflowFileReferences
unmarkRefSource jobFileReferences
let let
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do

View File

@ -20,10 +20,9 @@ dispatchJobSendCourseCommunication :: Either UserEmail UserId
-> CourseId -> CourseId
-> UserId -> UserId
-> UUID -> UUID
-> Maybe Text -> CommunicationContent
-> Html
-> JobHandler UniWorX -> JobHandler UniWorX
dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = JobHandlerException $ do dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
(sender, Course{..}) <- runDB $ (,) (sender, Course{..}) <- runDB $ (,)
<$> getJust jSender <$> getJust jSender
<*> getJust jCourse <*> getJust jCourse
@ -34,8 +33,9 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
_mailFrom .= userAddressFrom sender _mailFrom .= userAddressFrom sender
addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
addMailHeader "Auto-Submitted" "no" addMailHeader "Auto-Submitted" "no"
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
forM_ ccAttachments $ addPart' . toMailPart
when (jRecipientEmail == Right jSender) $ when (jRecipientEmail == Right jSender) $
addPart' $ do addPart' $ do
partIsAttachmentCsv MsgCommAllRecipients partIsAttachmentCsv MsgCommAllRecipients

View File

@ -44,7 +44,7 @@ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
import System.Clock (getTime, Clock(Monotonic), TimeSpec) import System.Clock (getTime, Clock(Monotonic), TimeSpec)
import GHC.Conc (unsafeIOToSTM) import GHC.Conc (unsafeIOToSTM)
import Data.Generics.Product.Types (Children, ChGeneric) import Data.Generics.Product.Types (Children, ChGeneric, HasTypesCustom(..))
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
@ -67,8 +67,7 @@ data Job
, jCourse :: CourseId , jCourse :: CourseId
, jSender :: UserId , jSender :: UserId
, jMailObjectUUID :: UUID , jMailObjectUUID :: UUID
, jSubject :: Maybe Text , jMailContent :: CommunicationContent
, jMailContent :: Html
} }
| JobInvitation { jInviter :: Maybe UserId | JobInvitation { jInviter :: Maybe UserId
, jInvitee :: UserEmail , jInvitee :: UserEmail
@ -169,10 +168,14 @@ type family ChildrenJobChildren a where
ChildrenJobChildren UUID = '[] ChildrenJobChildren UUID = '[]
ChildrenJobChildren (Key a) = '[] ChildrenJobChildren (Key a) = '[]
ChildrenJobChildren (CI a) = '[] ChildrenJobChildren (CI a) = '[]
ChildrenJobChildren (Set a) = '[] ChildrenJobChildren (Set v) = '[v]
ChildrenJobChildren MailContext = '[] ChildrenJobChildren MailContext = '[]
ChildrenJobChildren (Digest a) = '[]
ChildrenJobChildren a = Children ChGeneric a ChildrenJobChildren a = Children ChGeneric a
instance (Ord b', HasTypesCustom JobChildren a' b' a b) => HasTypesCustom JobChildren (Set a') (Set b') a b where
typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @JobChildren
classifyJob :: Job -> String classifyJob :: Job -> String

View File

@ -42,6 +42,7 @@ import Data.Kind (Type)
import Model.Types.Languages import Model.Types.Languages
import Model.Types.Csv import Model.Types.Csv
import Model.Types.File
import Network.Mail.Mime hiding (addPart, addAttachment) import Network.Mail.Mime hiding (addPart, addAttachment)
import qualified Network.Mail.Mime as Mime (addPart) import qualified Network.Mail.Mime as Mime (addPart)
@ -89,7 +90,7 @@ import qualified Data.Binary as Binary
import "network-bsd" Network.BSD (getHostName) import "network-bsd" Network.BSD (getHostName)
import Data.Time.Zones (utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime) import Data.Time.Zones (utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..)) import Data.Time.LocalTime (ZonedTime(..), TimeZone(..), utcToZonedTime, utc)
import Data.Time.Format (rfc822DateFormat) import Data.Time.Format (rfc822DateFormat)
import Network.HaskellNet.SMTP (SMTPConnection) import Network.HaskellNet.SMTP (SMTPConnection)
@ -123,6 +124,12 @@ import Language.Haskell.TH (nameBase)
import Network.Mail.Mime.Instances() import Network.Mail.Mime.Instances()
import Data.Char (isLatin1)
import Data.Text.Lazy.Encoding (decodeUtf8')
import System.FilePath (takeFileName)
import Network.HTTP.Types.Header (hETag)
import Web.HttpApiData (ToHttpApiData(toHeader))
makeLenses_ ''Address makeLenses_ ''Address
makeLenses_ ''Mail makeLenses_ ''Mail
@ -346,6 +353,20 @@ instance YesodMail site => ToMailPart site Html where
_partEncoding .= QuotedPrintableText _partEncoding .= QuotedPrintableText
_partContent .= PartContent (renderMarkup html) _partContent .= PartContent (renderMarkup html)
instance YesodMail site => ToMailPart site PureFile where
toMailPart file@File{fileTitle, fileModified} = do
_partDisposition .= AttachmentDisposition (pack $ takeFileName fileTitle)
_partType .= decodeUtf8 (mimeLookup $ pack fileTitle)
let
content :: LBS.ByteString
content = file ^. _pureFileContent . _Just
isLatin = either (const False) (all isLatin1) $ decodeUtf8' content
_partEncoding .= bool Base64 QuotedPrintableText isLatin
_partContent .= PartContent content
forM_ (file ^. _FileReference . _1 . _fileReferenceContent) $ \fRefContent ->
replaceMailHeader (CI.original hETag) . Just . decodeUtf8 . toHeader $ etagFileReference # fRefContent
replaceMailHeader (CI.original hLastModified) . Just . pack . formatTime defaultTimeLocale rfc822DateFormat $ utcToZonedTime utc fileModified
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
toMailPart act = do toMailPart act = do

View File

@ -24,3 +24,4 @@ import Model.Types.Markup as Types
import Model.Types.Room as Types import Model.Types.Room as Types
import Model.Types.Csv as Types import Model.Types.Csv as Types
import Model.Types.Upload as Types import Model.Types.Upload as Types
import Model.Types.Communication as Types

View File

@ -0,0 +1,21 @@
module Model.Types.Communication
( CommunicationContent(..), _ccSubject, _ccBody, _ccAttachments
) where
import Import.NoModel
import Model.Types.File
import Utils.Lens.TH
data CommunicationContent = CommunicationContent
{ ccSubject :: Maybe Text
, ccBody :: Html
, ccAttachments :: Set FileReference
} deriving stock (Eq, Ord, Show, Read, Generic, Typeable)
deriving anyclass (Hashable, NFData)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''CommunicationContent
makeLenses_ ''CommunicationContent

View File

@ -18,7 +18,24 @@ module Model.Types.File
, _fieldIdent, _fieldUnpackZips, _fieldMultiple, _fieldRestrictExtensions, _fieldAdditionalFiles, _fieldMaxFileSize , _fieldIdent, _fieldUnpackZips, _fieldMultiple, _fieldRestrictExtensions, _fieldAdditionalFiles, _fieldMaxFileSize
) where ) where
import Import.NoModel import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON, Proxy(..))
import Crypto.Hash (Digest, SHA3_512)
import Language.Haskell.TH.Syntax (Lift)
import Data.Binary (Binary)
import Crypto.Hash.Instances ()
import Data.Proxy (Proxy(..))
import Control.Lens
import Utils.HttpConditional
import Data.Binary.Instances.Time ()
import Data.Time.Clock.Instances ()
import Data.Aeson.TH
import Utils
import Data.Kind (Type)
import Data.Universe
import Numeric.Natural
import Network.Mime
import Control.Monad.Morph
import Data.NonNull.Instances ()
import Database.Persist.Sql (PersistFieldSql(..)) import Database.Persist.Sql (PersistFieldSql(..))
import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
@ -204,7 +221,6 @@ instance HasFileReference FileReference where
instance HasFileReference PureFile where instance HasFileReference PureFile where
newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON)
deriving anyclass (NFData) deriving anyclass (NFData)
_FileReference = iso toFileReference fromFileReference _FileReference = iso toFileReference fromFileReference
@ -293,7 +309,7 @@ data FileField fileid = FileField
, fieldUnpackZips :: FileFieldUserOption Bool , fieldUnpackZips :: FileFieldUserOption Bool
, fieldMultiple :: Bool , fieldMultiple :: Bool
, fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) , fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
, fieldMaxFileSize :: Maybe Natural , fieldMaxFileSize, fieldMaxCumulativeSize :: Maybe Natural
, fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool)
, fieldAllEmptyOk :: Bool , fieldAllEmptyOk :: Bool
} }
@ -311,6 +327,7 @@ instance ToJSON (FileField FileReference) where
, pure $ "multiple" JSON..= fieldMultiple , pure $ "multiple" JSON..= fieldMultiple
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
, pure $ "max-file-size" JSON..= fieldMaxFileSize , pure $ "max-file-size" JSON..= fieldMaxFileSize
, pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize
, pure $ "additional-files" JSON..= addFiles' , pure $ "additional-files" JSON..= addFiles'
, pure $ "all-empty-ok" JSON..= fieldAllEmptyOk , pure $ "all-empty-ok" JSON..= fieldAllEmptyOk
] ]
@ -326,6 +343,7 @@ instance FromJSON (FileField FileReference) where
fieldMultiple <- o JSON..: "multiple" fieldMultiple <- o JSON..: "multiple"
fieldRestrictExtensions <- o JSON..:? "restrict-extensions" fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
fieldMaxFileSize <- o JSON..:? "max-file-size" fieldMaxFileSize <- o JSON..:? "max-file-size"
fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-size"
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do

View File

@ -226,6 +226,8 @@ data AppSettings = AppSettings
, appVolatileClusterSettingsCacheTime :: DiffTime , appVolatileClusterSettingsCacheTime :: DiffTime
, appJobMaxFlush :: Maybe Natural , appJobMaxFlush :: Maybe Natural
, appCommunicationAttachmentsMaxSize :: Maybe Natural
} deriving Show } deriving Show
data JobMode = JobsLocal { jobsAcceptOffload :: Bool } data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
@ -695,6 +697,8 @@ instance FromJSON AppSettings where
appJobMaxFlush <- o .:? "job-max-flush" appJobMaxFlush <- o .:? "job-max-flush"
appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size"
return AppSettings{..} return AppSettings{..}
where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 where isValidARCConf ARCConf{..} = arccMaximumWeight > 0

View File

@ -0,0 +1,2 @@
$newline never
An Kurs- und Tutoriumsmitteilungen können nun Dateien angehängt werden.

View File

@ -0,0 +1,2 @@
$newline never
Course- and tutorial messages (emails) may now carry attached files.

View File

@ -4,4 +4,4 @@ $newline never
<head> <head>
<meta charset="UTF-8"> <meta charset="UTF-8">
<body> <body>
#{jMailContent} #{ccBody}

View File

@ -33,7 +33,7 @@ $if not (null fileInfos)
<div .file-uploads-label>_{MsgUtilAddMoreFiles} <div .file-uploads-label>_{MsgUtilAddMoreFiles}
$# new files $# new files
<input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required :is _Just fieldMaxFileSize:data-max-size=#{maybe "-1" tshow fieldMaxFileSize}> <input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required :is _Just fieldMaxFileSize || is _Just fieldMaxCumulativeSize:data-max-size=#{maybe "-1" tshow (ignoreNothing min fieldMaxFileSize fieldMaxCumulativeSize)}>
$if fieldMultiple $if fieldMultiple
<div .file-input__info> <div .file-input__info>
@ -57,6 +57,10 @@ $maybe maxSize <- fieldMaxFileSize
$else $else
_{MsgFileUploadMaxSize (textBytes maxSize)} _{MsgFileUploadMaxSize (textBytes maxSize)}
$maybe maxSize <- fieldMaxCumulativeSize
<div .file-input__info>
_{MsgFileUploadCumulativeMaxSize (textBytes maxSize)}
$if not (fieldOptionForce fieldUnpackZips) $if not (fieldOptionForce fieldUnpackZips)
<div .file-input__unpack> <div .file-input__unpack>
^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False} ^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}