feat(file-field): cumulative size limit

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

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.

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:

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.

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.

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

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

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
           }
 

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

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

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

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
 

templates/widgets/genericFileField.hamlet

@@ -33,7 +33,7 @@ $if not (null fileInfos)
   <div .file-uploads-label>_{MsgUtilAddMoreFiles}
 
 $# 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
   <div .file-input__info>
@@ -57,6 +57,10 @@ $maybe maxSize <- fieldMaxFileSize
     $else
       _{MsgFileUploadMaxSize (textBytes maxSize)}
 
+$maybe maxSize <- fieldMaxCumulativeSize
+  <div .file-input__info>
+    _{MsgFileUploadCumulativeMaxSize (textBytes maxSize)}
+
 $if not (fieldOptionForce fieldUnpackZips)
   <div .file-input__unpack>
     ^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}