From b749039636c61157b5fc0bea9848ab9828ee671c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 20 Jan 2022 00:21:15 +0100 Subject: [PATCH] feat(file-field): cumulative size limit --- config/settings.yml | 2 ++ .../courses/submission/de-de-formal.msg | 1 + .../categories/courses/submission/en-eu.msg | 2 ++ messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/Yesod/StaticContent.hs | 4 +-- src/Handler/Utils/Communication.hs | 12 ++++++- src/Handler/Utils/Form.hs | 33 +++++++++++-------- src/Handler/Utils/Workflow/Form.hs | 2 ++ src/Import/NoModel.hs | 5 +++ src/Model/Types/File.hs | 4 ++- src/Settings.hs | 4 +++ templates/widgets/genericFileField.hamlet | 6 +++- 13 files changed, 58 insertions(+), 19 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index ff72cb3c0..535504e62 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -290,3 +290,5 @@ bot-mitigations: - only-logged-in-table-sorting volatile-cluster-settings-cache-time: 10 + +communication-attachments-max-size: 20971520 # 20MiB diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index 145768cc4..f2eedb946 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -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. FileUploadMaxSize maxSize@Text: Datei darf 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}" InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte. diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index 0574c4a9d..2d0ffb872 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -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. FileUploadMaxSize maxSize: File may 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}” 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: diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 82a4e02f3..6e80466d9 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -55,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximale Dateigröße darf nicht negativ sein UploadSpecificFileEmptyOk: Leere Uploads erlauben UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" GenericFileFieldFileTooLarge file@FilePath: „#{file}“ ist zu groß +GenericFileFieldCumulativeTooLarge: Hochgeladene Dateien sind zu groß GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung OnlyUploadOneFile: Bitte nur eine Datei hochladen. UploadAtLeastOneNonemptyFile: Bitte mindestens eine nichtleere Datei hochladen. diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 28a834e93..652674005 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -55,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximum filesize may not be negative UploadSpecificFileEmptyOk: Allow empty uploads UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}” GenericFileFieldFileTooLarge file: “#{file}” is too large +GenericFileFieldCumulativeTooLarge: Uploaded files are too large GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension OnlyUploadOneFile: Please only upload one file UploadAtLeastOneNonemptyFile: Please upload at least one nonempty file. diff --git a/src/Foundation/Yesod/StaticContent.hs b/src/Foundation/Yesod/StaticContent.hs index a60ace7ff..057c7b873 100644 --- a/src/Foundation/Yesod/StaticContent.hs +++ b/src/Foundation/Yesod/StaticContent.hs @@ -27,10 +27,10 @@ addStaticContent ext _mime content = do for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do let expiry = maybe 0 ceiling memcachedExpiry 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 catchIf Memcached.isKeyNotFound touch . const $ - handleIf Memcached.isKeyExists (const $ return ()) add + handleIf Memcached.isKeyExists (const $ return ()) addItem return . Left $ pack absoluteLink where -- Generate a unique filename based on the content itself, this is used diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 4cfca1a04..39e1681ce 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -206,13 +206,23 @@ commR CommunicationRoute{..} = do 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 <$> recipientAForm <* aformMessage recipientsListMsg <*> ( CommunicationContent <$> 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 fileFieldMultiple) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 34a372192..92940d471 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -998,15 +998,20 @@ genericFileField mkOpts = Field{..} = not (permittedExtension opts fName) && (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip) - whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do - fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE - when (fLength > maxSize) $ do - when (is _Just mIdent) $ - liftHandler . runDB . runConduit $ - mapM_ (transPipe lift . handleFile) files - .| handleUpload opts mIdent - .| C.sinkNull - throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo + whenIsJust (ignoreNothing min fieldMaxFileSize fieldMaxCumulativeSize) $ \takeSize -> + flip evalAccumT mempty . forM_ files $ \fInfo -> do + fLength <- lift . runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ takeSize) .| C.lengthE + add $ Sum fLength + Sum cummSize <- look + when (NTop (Just cummSize) > NTop fieldMaxCumulativeSize || NTop (Just fLength) > NTop fieldMaxFileSize) $ do + when (is _Just mIdent) $ + lift . liftHandler . runDB . runConduit $ + 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 -> do @@ -1125,7 +1130,7 @@ fileFieldMultiple = genericFileField $ return FileField , fieldMultiple = True , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = Nothing + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing , fieldAllEmptyOk = True } @@ -1145,7 +1150,7 @@ singleFileField prev = genericFileField $ do [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] - , fieldMaxFileSize = Nothing + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing , fieldAllEmptyOk = True } @@ -1161,7 +1166,7 @@ specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitle [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList previous ] - , fieldMaxFileSize = specificFileMaxSize + , fieldMaxFileSize = specificFileMaxSize, fieldMaxCumulativeSize = Nothing , fieldAllEmptyOk = specificFileEmptyOk } where @@ -1189,7 +1194,7 @@ zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList previous ] - , fieldMaxFileSize = Nothing + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing , fieldAllEmptyOk = emptyOk } @@ -1232,7 +1237,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] - , fieldMaxFileSize = Nothing + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing , fieldAllEmptyOk = True } diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs index 8dfc47982..0ac389ebc 100644 --- a/src/Handler/Utils/Workflow/Form.hs +++ b/src/Handler/Utils/Workflow/Form.hs @@ -70,6 +70,7 @@ instance ToJSON (FileField FileIdent) where , pure $ "multiple" JSON..= fieldMultiple , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions , pure $ "max-file-size" JSON..= fieldMaxFileSize + , pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize , pure $ "additional-files" JSON..= addFiles' ] where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object @@ -83,6 +84,7 @@ instance FromJSON (FileField FileIdent) where fieldMultiple <- o JSON..: "multiple" fieldRestrictExtensions <- o JSON..:? "restrict-extensions" fieldMaxFileSize <- o JSON..:? "max-file-size" + fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ad0ac8f97..4a75b8fe6 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -118,6 +118,11 @@ import Control.Monad.Trans.State as Import ( State, runState, mapState, withState , 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.Trans.Writer.Lazy as Import ( Writer, runWriter, mapWriter, execWriter diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index fae0b9a0c..2d26ae6ce 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -309,7 +309,7 @@ data FileField fileid = FileField , fieldUnpackZips :: FileFieldUserOption Bool , fieldMultiple :: Bool , fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) - , fieldMaxFileSize :: Maybe Natural + , fieldMaxFileSize, fieldMaxCumulativeSize :: Maybe Natural , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) , fieldAllEmptyOk :: Bool } @@ -327,6 +327,7 @@ instance ToJSON (FileField FileReference) where , pure $ "multiple" JSON..= fieldMultiple , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions , pure $ "max-file-size" JSON..= fieldMaxFileSize + , pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize , pure $ "additional-files" JSON..= addFiles' , pure $ "all-empty-ok" JSON..= fieldAllEmptyOk ] @@ -342,6 +343,7 @@ instance FromJSON (FileField FileReference) where fieldMultiple <- o JSON..: "multiple" fieldRestrictExtensions <- o JSON..:? "restrict-extensions" fieldMaxFileSize <- o JSON..:? "max-file-size" + fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-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 diff --git a/src/Settings.hs b/src/Settings.hs index c9ab18286..af10c98f4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -226,6 +226,8 @@ data AppSettings = AppSettings , appVolatileClusterSettingsCacheTime :: DiffTime , appJobMaxFlush :: Maybe Natural + + , appCommunicationAttachmentsMaxSize :: Maybe Natural } deriving Show data JobMode = JobsLocal { jobsAcceptOffload :: Bool } @@ -693,6 +695,8 @@ instance FromJSON AppSettings where appJobMaxFlush <- o .:? "job-max-flush" + appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + return AppSettings{..} where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 diff --git a/templates/widgets/genericFileField.hamlet b/templates/widgets/genericFileField.hamlet index d1f6d622f..04a5581ac 100644 --- a/templates/widgets/genericFileField.hamlet +++ b/templates/widgets/genericFileField.hamlet @@ -33,7 +33,7 @@ $if not (null fileInfos)
_{MsgUtilAddMoreFiles} $# new files - + $if fieldMultiple
@@ -57,6 +57,10 @@ $maybe maxSize <- fieldMaxFileSize $else _{MsgFileUploadMaxSize (textBytes maxSize)} +$maybe maxSize <- fieldMaxCumulativeSize +
+ _{MsgFileUploadCumulativeMaxSize (textBytes maxSize)} + $if not (fieldOptionForce fieldUnpackZips)
^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}