refactor(file upload): move to genericFileField

frontend/src/utils/inputs/checkbox.sass

@@ -89,7 +89,7 @@
     \:checked + label::before
       background-color: white
 
-  [disabled] + label
+  [disabled] + label, [readonly] + label
     pointer-events: none
     border: none
     opacity: 0.6

frontend/src/utils/inputs/radio.sass

@@ -38,7 +38,7 @@
       box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
       outline: 0
 
-    [disabled] + label
+    [disabled] + label, [readonly] + label
       pointer-events: none
       border: none
       opacity: 0.6

messages/uniworx/de-de-formal.msg

@@ -788,6 +788,9 @@ UploadModeExtensionRestriction: Zulässige Dateiendungen
 UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
 UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
 
+GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
+FileUploadOnlySessionTip: Sie haben diese Datei in der aktuellen Session bereits hochgeladen, sie ist allerdings noch nicht gespeichert. Sie müssen zunächst noch das Formular „Senden“, damit die Datei ordnungsgemäß gespeichert wird.
+
 UploadSpecificFiles: Vorgegebene Dateinamen
 NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
 UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein

models/allocations.model

@@ -21,7 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     registerByCourse    UTCTime Maybe   -- course registration dates are ignored until this day has passed or always prohibited
     overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
     -- overrideVisible not needed, since courses are always visible
-    matchingSeed        ByteString default=''
+    matchingSeed        ByteString default='\x'::bytea
     TermSchoolAllocationShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolAllocationName   term school name         -- name must be unique within school and semester
     deriving Show Eq Ord Generic

models/files.model

@@ -8,7 +8,5 @@ File
     deriving Show Eq Generic
 
 SessionFile
-    user            UserId
-    reference       SessionFileReference
     file            FileId
     touched         UTCTime

src/Handler/Allocation/Prios.hs

@@ -57,8 +57,8 @@ postAPriosR tid ssh ash = do
 
   formResult priosRes $ \(mode, fInfo) -> do
     let sourcePrios = case mode of
-          AllocationPrioritiesNumeric -> fileSourceCsvPositional Csv.NoHeader fInfo
+          AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
-          AllocationPrioritiesOrdinal -> fileSourceCsvPositional Csv.NoHeader fInfo .| C.map Csv.fromOnly .| ordinalPriorities
+          AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
     
     (matrSunk, matrMissing) <- runDB $ do
       Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash

src/Handler/Material.hs

@@ -316,7 +316,9 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
         keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
         mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
       where
-        finsert (Left fileId) = tell $ singleton fileId
+        finsert (Left fid) = do
+          lift . void $ upsertBy (UniqueMaterialFile mid fid) (MaterialFile mid fid) []
+          tell $ singleton fid
         finsert (Right file) = lift $ do
           fid <- insert file
           void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

src/Handler/Sheet.hs

@@ -610,10 +610,10 @@ handleSheetEdit tid ssh csh msId template dbAction = do
         case mbsid of
           Nothing    -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
           (Just sid) ->  do -- save files in DB:
-            whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
+            insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF
-            whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
+            insertSheetFile' sid SheetHint     $ fromMaybe (return ()) sfHintF
-            whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
+            insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
-            whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
+            insertSheetFile' sid SheetMarking  $ fromMaybe (return ()) sfMarkingF
             insert_ $ SheetEdit aid actTime sid
             addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
             -- Sanity checks generating warnings only, but not errors!
@@ -674,14 +674,6 @@ postSDelR tid ssh csh shn = do
     }
 
 
-insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
-insertSheetFile sid ftype finfo = do
-    runConduit $ sourceFiles finfo .| C.mapM_ finsert
-  where
-    finsert file = do
-      fid <- insert file
-      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
-
 insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
 insertSheetFile' sid ftype fs = do
     oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
@@ -692,7 +684,9 @@ insertSheetFile' sid ftype fs = do
     keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
     mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
   where
-    finsert (Left fileId) = tell $ singleton fileId
+    finsert (Left fid) = do
+      lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) []
+      tell $ singleton fid
     finsert (Right file) = lift $ do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

src/Handler/Utils/Csv.hs

@@ -20,6 +20,8 @@ import Import hiding (Header, mapM_)
 import Data.Csv
 import Data.Csv.Conduit
 
+import Handler.Utils.Form (uploadContents)
+
 import Control.Monad (mapM_)
 
 -- import qualified Data.Csv.Util as Csv
@@ -213,9 +215,8 @@ fileSourceCsv :: ( FromNamedRecord csv
                  , MonadHandler m
                  , HandlerSite m ~ UniWorX
                  )
-              => FileInfo
+              => ConduitT (Either FileId File) csv m ()
-              -> ConduitT () csv m ()
+fileSourceCsv = uploadContents .| decodeCsv
-fileSourceCsv = (.| decodeCsv) . fileSource
 
 fileSourceCsvPositional :: ( MonadHandler m
                            , HandlerSite m ~ UniWorX
@@ -223,9 +224,8 @@ fileSourceCsvPositional :: ( MonadHandler m
                            , FromRecord csv
                            )
                         => HasHeader
-                        -> FileInfo
+                        -> ConduitT (Either FileId File) csv m ()
-                        -> ConduitT () csv m ()
+fileSourceCsvPositional hdr = uploadContents .| decodeCsvPositional hdr
-fileSourceCsvPositional hdr = (.| decodeCsvPositional hdr) . fileSource
 
 
 instance ToWidget UniWorX CsvRendered where

src/Handler/Utils/Form.hs

@@ -40,6 +40,8 @@ import qualified Data.Set as Set
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 
+import qualified Data.HashMap.Lazy as HashMap
+
 import Control.Monad.Writer.Class
 import Control.Monad.Error.Class (MonadError(..))
 
@@ -48,8 +50,6 @@ import Data.Aeson.Text (encodeToLazyText)
 
 import qualified Text.Email.Validate as Email
 
-import Yesod.Core.Types (FileInfo(..))
-
 import Data.Text.Lens (unpacked)
 
 import Data.Char (isDigit)
@@ -57,6 +57,12 @@ import Text.Blaze (toMarkup)
 
 import Handler.Utils.Form.MassInput
 
+import qualified Data.Binary as Binary
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Data.Time.Clock.System (systemEpochDay)
+  
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -824,42 +830,253 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
 
 
 type FileUploads = ConduitT () (Either FileId File) Handler ()
-  
 
-specificFileField :: UploadSpecificFile -> Field Handler FileUploads 
+uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m ()
-specificFileField UploadSpecificFile{..} = Field{..}
+uploadContents = C.mapMaybeM $ either dbContents (return . fileContent)
+  where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get
+
+data FileFieldUserOption a = FileFieldUserOption
+  { fieldOptionForce :: Bool
+  , fieldOptionDefault :: a
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data FileField = FileField
+  { fieldIdent :: Maybe Text
+  , fieldUnpackZips :: FileFieldUserOption Bool
+  , fieldMultiple :: Bool
+  , fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
+  , fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool)
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+genericFileField :: forall m.
+                    ( MonadHandler m
+                    , HandlerSite m ~ UniWorX
+                    )
+                 => Handler FileField -> Field m FileUploads
+genericFileField mkOpts = Field{..}
   where
+    permittedExtension :: FileField -> FileName -> Bool
+    permittedExtension FileField{..} fTitle
+      | Just exts <- fieldRestrictExtensions
+      = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
+      | otherwise
+      = True
+
+    getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField -> m' (Maybe Text)
+    getIdent FileField{..} = do
+      ident <- case fieldIdent of
+        Just ident -> return $ Just ident
+        Nothing -> runMaybeT $ do
+          cRoute <- MaybeT getCurrentRoute
+          pos <- newIdent
+          $logDebugS "genericFileField.getIdent" pos
+          return $ hash (cRoute, pos)
+            & toStrict . Binary.encode
+            & decodeUtf8 . Base64.encode
+            & Text.dropWhileEnd (== '=')
+      $logDebugS "genericFileField.getIdent" $ tshow ident
+      return ident
+
+    getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool))
+    getPermittedFiles mIdent opts@FileField{..} = do
+      sessionFiles <- fmap fold . for mIdent $ \fieldIdent' ->
+        fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles
+      sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do
+        SessionFile{..} <- MaybeT $ get sfId
+        when (is _Just fieldRestrictExtensions) $ do
+          (fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do
+            E.where_ $ file E.^. FileId E.==. E.val sessionFileFile
+            return $ (file E.^. FileTitle, E.isNothing $ file E.^. FileContent)
+          guard $ isDirectory || permittedExtension opts (pack fTitle)
+        return . Map.singleton sessionFileFile $ FileFieldUserOption False True
+      $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
+      $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
+      return $ fieldAdditionalFiles <> sessionFiles'
+
+    handleUpload :: Maybe Text -> File -> DB (Maybe FileId)
+    handleUpload mIdent file = do
+      for mIdent $ \ident -> do
+        now <- liftIO getCurrentTime
+        fId <- insert file
+        sfId <- insert $ SessionFile fId now
+        tellSessionJson SessionFiles . MergeHashMap . HashMap.singleton ident $ Set.singleton sfId
+        return fId
+
     fieldEnctype = Multipart
-    fieldParse _ files
+    fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
-      | [f] <- files
+    fieldParse vals files = do
-      = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) .| C.map Right
+      opts@FileField{..} <- liftHandler mkOpts
-      | null files   = return $ Right Nothing
-      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
-    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
 
-    extensions = fileNameExtensions specificFileName
+      mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
-    acceptRestricted = not $ null extensions
+        fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v
-    accept = Text.intercalate "," . map ("." <>) $ extensions
 
+      let
+        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
+
+      let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files
+
+      let
+        doUnpack
+          | fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips
+          | otherwise = unpackZips `elem` vals
+        handleFile :: FileInfo -> ConduitT () File Handler ()
+        handleFile
+          | doUnpack  = sourceFiles
+          | otherwise = yieldM . acceptFile
+
+      if | invExt : _ <- filter (not . permittedExtension opts) uploadedFilenames
+           -> do
+             liftHandler . runDB . runConduit $
+                  mapM_ (transPipe lift . handleFile) files
+               .| C.mapM_ (void . handleUpload mIdent)
+             return . Left . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt
+         | otherwise
+           -> do
+             let fSrc = do
+                   permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts
+                   yieldMany [ Left fId
+                             | (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles
+                             , fieldOptionForce, fieldOptionDefault
+                             ]
+                   yieldMany vals
+                     .| C.mapMaybe fromPathPiece
+                     .| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc)
+                     .| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles)
+                     .| C.filter (\(_, enc) -> fieldMultiple
+                                            || (    (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals)
+                                                 && null files
+                                               )
+                                 )
+                     .| C.map (\(fId, _) -> Left fId)
+                   mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right
+             (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2
+             $logDebugS "genericFileField.fieldParse" $ tshow nFiles
+             if
+               | nFiles <= 0 -> return $ Right Nothing
+               | nFiles <= 1 -> return . Right $ Just fSrc'
+               | not fieldMultiple -> do
+                   liftHandler . runDB . runConduit $
+                        mapM_ (transPipe lift . handleFile) files
+                     .| C.mapM_ (void . handleUpload mIdent)
+                   return . Left $ SomeMessage MsgOnlyUploadOneFile
+               | otherwise -> return . Right $ Just fSrc'
+             
+    fieldView :: FieldViewFunc m FileUploads
+    fieldView fieldId fieldName _attrs val req = do
+      opts@FileField{..} <- liftHandler mkOpts
+      mIdent <- getIdent opts
+      identSecret <- for mIdent $ encodedSecretBox SecretBoxShort
+
+      fileInfos <- liftHandler . runDB $ do
+        permittedFiles <- getPermittedFiles mIdent opts
+
+        let
+          handleReference fId
+            | fId `Map.member` permittedFiles = return $ Just fId
+            | otherwise = return Nothing
+
+        sentVals <- for val $ \src ->
+          fmap Set.fromList . sourceToList
+            $ transPipe lift src
+           .| C.mapMaybeM (either handleReference $ handleUpload mIdent)
+        let
+          toFUI (E.Value fuiId', E.Value fuiTitle) = do
+            fuiId <- encrypt fuiId'
+            let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|]
+                fuiChecked
+                  | Right sentVals' <- sentVals
+                  = fuiId' `Set.member` sentVals'
+                  | Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles
+                  = fieldOptionDefault
+                  | otherwise = False
+                fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles
+                fuiForced
+                  | Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles
+                  = fieldOptionForce
+                  | otherwise
+                  = False
+            return FileUploadInfo{..}
+        fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do
+            E.where_ $ file E.^. FileId `E.in_` E.valList (Set.toList $ fold sentVals <> Map.keysSet permittedFiles)
+            E.orderBy [E.asc $ file E.^. FileTitle]
+            return (file E.^. FileId, file E.^. FileTitle)
+
+        return $ sortOn (splitPath . fuiTitle) fileInfos'
+
+      let
+        mayUnpack = not (fieldOptionForce fieldUnpackZips) || fieldOptionDefault fieldUnpackZips
+
+        zipExtensions = mimeExtensions typeZip
+
+        acceptRestricted = isJust fieldRestrictExtensions
+        accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) mayUnpack ++ toListOf (_Just . re _nullable . folded) fieldRestrictExtensions
+
+      uploadOnlySessionMessage <- messageIconI Warning IconFileUploadSession MsgFileUploadOnlySessionTip
+
+      $(widgetFile "widgets/genericFileField")
+    unpackZips :: Text
+    unpackZips = "unpack-zip"
+   
+  
+  
+fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
+fileFieldMultiple = genericFileField $ return FileField
+  { fieldIdent = Nothing
+  , fieldUnpackZips = FileFieldUserOption True False
+  , fieldMultiple = True
+  , fieldRestrictExtensions = Nothing
+  , fieldAdditionalFiles = Map.empty
+  }
+
+fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
+fileField = genericFileField $ return FileField
+  { fieldIdent = Nothing
+  , fieldUnpackZips = FileFieldUserOption True False
+  , fieldMultiple = False
+  , fieldRestrictExtensions = Nothing
+  , fieldAdditionalFiles = Map.empty
+  }
+  
+specificFileField :: UploadSpecificFile -> Field Handler FileUploads 
+specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . genericFileField $ return FileField
+  { fieldIdent = Nothing
+  , fieldUnpackZips = FileFieldUserOption True False
+  , fieldMultiple = False
+  , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName
+  , fieldAdditionalFiles = Map.empty
+  }
+  where
+    fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile)
+      where updateFileReference fId = runDB . maybeT (return fId) $ do
+              oldTitle <- MaybeT . fmap (getFirst . foldMap (First . Just)) . E.select . E.from $ \file -> do
+                E.where_ $ file E.^. FileId E.==. E.val fId
+                return $ file E.^. FileTitle
+              if | oldTitle == E.Value (unpack specificFileName)
+                   -> return fId
+                 | otherwise -> lift $ do
+                     fId' <- insert $ File (unpack specificFileName) Nothing (toMidnight systemEpochDay) {- temporary -}
+                     E.update $ \file' -> do
+                       let newModified = E.subSelect . E.from $ \file -> do
+                             E.where_ $ file E.^. FileId E.==. E.val fId
+                             return $ file E.^. FileModified
+                           newContent = E.subSelect . E.from $ \file -> do
+                             E.where_ $ file E.^. FileId E.==. E.val fId
+                             return $ file E.^. FileContent
+                       E.set file' [ FileModified E.=. E.maybe (E.val $ toMidnight systemEpochDay) id newModified, FileContent E.=. E.joinV newContent ]
+                     return fId'
+            updateFile = return . set _fileTitle (unpack specificFileName)
 
 zipFileField :: Bool -- ^ Unpack zips?
              -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
              -> Field Handler FileUploads 
-zipFileField doUnpack permittedExtensions = Field{..}
+zipFileField doUnpack permittedExtensions = genericFileField $ return FileField
-  where
+  { fieldIdent = Nothing
-    fieldEnctype = Multipart
+  , fieldUnpackZips = FileFieldUserOption True doUnpack
-    fieldParse _ files
+  , fieldMultiple = doUnpack
-      | [f@FileInfo{..}] <- files
+  , fieldRestrictExtensions = permittedExtensions
-      , maybe True (anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fileName)) permittedExtensions || doUnpack
+  , fieldAdditionalFiles = Map.empty
-      = return . Right . Just $ bool (yieldM . fmap Right . acceptFile) ((.| C.map Right) . sourceFiles) doUnpack f
+  }
-      | null files   = return $ Right Nothing
-      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
-    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
-
-    zipExtensions = mimeExtensions typeZip
-
-    acceptRestricted = isJust permittedExtensions
-    accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
 
 fileUploadForm :: Bool -- ^ Required?
                -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
@@ -887,53 +1104,14 @@ multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .|
 
 multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
                -> Field Handler FileUploads 
-multiFileField permittedFiles' = Field{..}
+multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
-  where
+  where mkField permitted = FileField
-    fieldEnctype = Multipart
+          { fieldIdent = Nothing
-    fieldParse vals files = return . Right . Just $ do
+          , fieldUnpackZips = FileFieldUserOption False False
-      pVals <- lift permittedFiles'
+          , fieldMultiple = True
-      let
+          , fieldRestrictExtensions = Nothing
-        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+          , fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted
-        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
+          }
-      yieldMany vals
-        .| C.filter (/= unpackZips)
-        .| C.map fromPathPiece .| C.catMaybes
-        .| C.mapMaybeM decrypt'
-        .| C.filter (`elem` pVals)
-        .| C.map Left
-      let
-        handleFile :: FileInfo -> ConduitT () File Handler ()
-        handleFile
-          | doUnpack  = sourceFiles
-          | otherwise = yieldM . acceptFile
-      mapM_ handleFile files .| C.map Right
-      where
-        doUnpack = unpackZips `elem` vals
-    fieldView fieldId fieldName _attrs val req = do
-      pVals <- handlerToWidget permittedFiles'
-      sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
-      let
-        toFUI (E.Value fuiId', E.Value fuiTitle) = do
-          fuiId <- encrypt fuiId'
-          fuiHtmlId <- newIdent
-          let fuiChecked
-                | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
-                | otherwise = True
-          return FileUploadInfo{..}
-        autoUnzipInfo :: Widget
-        autoUnzipInfo = i18n MsgAutoUnzipInfo
-      fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
-          E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
-          E.orderBy [E.asc $ file E.^. FileTitle]
-          return (file E.^. FileId, file E.^. FileTitle)
-      let fileInfos = sortOn fuiTitle fileInfos'
-      $(widgetFile "widgets/multiFileField")
-    unpackZips :: Text
-    unpackZips = "unpack-zip"
-    takeLefts :: Monad m => ConduitT (Either b a) b m ()
-    takeLefts = awaitForever $ \case
-      Right _ -> return ()
-      Left  r -> yield r
 
 data SheetGrading' = Points' | PassPoints' | PassBinary'
   deriving (Eq, Ord, Read, Show, Enum, Bounded)

src/Handler/Utils/Form/Types.hs

@@ -6,5 +6,5 @@ data FileUploadInfo = FileUploadInfo
   { fuiId :: CryptoUUIDFile
   , fuiTitle :: FilePath
   , fuiHtmlId :: Text
-  , fuiChecked :: Bool
+  , fuiChecked, fuiSession, fuiForced :: Bool
   }

src/Handler/Utils/Table/Pagination.hs

@@ -377,7 +377,7 @@ data DBCsvMode
     { dbCsvExportData :: Dynamic
     }
   | DBCsvImport
-    { dbCsvFiles :: [FileInfo]
+    { dbCsvFiles :: FileUploads
     }
   | DBCsvExportExample
   | DBCsvAbort
@@ -1109,7 +1109,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                       -> return $ DBCsvDiffExisting rowKey' oldRow row
                     | otherwise
                       -> return $ DBCsvDiffNew rowKey row
-              mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff
+              transPipe liftHandler dbCsvFiles .| fileSourceCsv .| C.mapM toDiff
 
               seen <- State.get
               forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if

src/Jobs/Handler/PruneFiles.hs

@@ -27,12 +27,12 @@ dispatchJobPruneUnreferencedFiles = do
   where
     references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()]
     references ((E.^. FileId) -> fId) =
-      [ E.from $ \matching  -> E.where_ $ matching  E.^. AllocationMatchingLog        E.==. fId
+      [ E.from $ \appFile   -> E.where_ $ appFile   E.^. CourseApplicationFileFile    E.==. fId
-      , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileFile E.==. fId
-      , E.from $ \appFile   -> E.where_ $ appFile   E.^. CourseApplicationFileFile    E.==. fId
       , E.from $ \matFile   -> E.where_ $ matFile   E.^. MaterialFileFile             E.==. fId
       , E.from $ \newsFile  -> E.where_ $ newsFile  E.^. CourseNewsFileFile           E.==. fId
-      , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileFile              E.==. fId
       , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile                E.==. fId
+      , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileFile E.==. fId
+      , E.from $ \matching  -> E.where_ $ matching  E.^. AllocationMatchingLog        E.==. fId
       , E.from $ \subFile   -> E.where_ $ subFile   E.^. SubmissionFileFile           E.==. fId
+      , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileFile              E.==. fId
       ]

src/Model.hs

@@ -38,6 +38,8 @@ deriving newtype instance ToJSONKey UserId
 deriving newtype instance FromJSONKey UserId
 deriving newtype instance ToJSONKey ExamOccurrenceId
 deriving newtype instance FromJSONKey ExamOccurrenceId
+deriving newtype instance ToJSONKey FileId
+deriving newtype instance FromJSONKey FileId
 
 -- ToMarkup and ToMessage instances for displaying selected database primary keys
 

src/Utils/Form.hs

@@ -672,32 +672,6 @@ secretJsonField :: forall m a.
                 => Field m a
 secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)
 
-fileFieldMultiple :: Monad m => Field m [FileInfo]
-fileFieldMultiple = Field{..}
-  where
-    fieldEnctype = Multipart
-    fieldParse _ files = return $ case files of
-      [] -> Right Nothing
-      fs -> Right $ Just fs
-    fieldView id' name attrs _ isReq =
-      [whamlet|
-        $newline never
-        <input type="file" uw-file-input ##{id'} name=#{name} *{attrs} multiple :isReq:required>
-      |]
-
-fileField :: Monad m => Field m FileInfo
-fileField = Field{..}
-  where
-    fieldEnctype = Multipart
-    fieldParse _ files = return $ case files of
-      []    -> Right Nothing
-      f : _ -> Right $ Just f
-    fieldView id' name attrs _ isReq =
-      [whamlet|
-        $newline never
-        <input type=file uw-file-input ##{id'} name=#{name} *{attrs} :isReq:required>
-      |]
-
 guardField :: Functor m => (a -> Bool) -> Field m a -> Field m a
 guardField p field = field { fieldParse = \ts fs -> fieldParse field ts fs <&> \case
                                Right (Just x)

src/Utils/Icon.hs

@@ -83,6 +83,7 @@ data Icon
   | IconPageActionPrimaryExpand | IconPageActionSecondary
   | IconBreadcrumbSeparator
   | IconMissingAllocationPriority
+  | IconFileUploadSession
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
 
 iconText :: Icon -> Text
@@ -144,6 +145,7 @@ iconText = \case
     IconPageActionSecondary     -> "ellipsis-h"
     IconBreadcrumbSeparator     -> "angle-right"
     IconMissingAllocationPriority -> "empty-set"
+    IconFileUploadSession       -> "file-upload"
 
 instance Universe Icon
 instance Finite   Icon

src/Utils/Session.hs

@@ -16,6 +16,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
                 | SessionAllocationResults
                 | SessionLang
                 | SessionError
+                | SessionFiles
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 

templates/widgets/genericFileField.hamlet

@@ -0,0 +1,41 @@
+$newline never
+
+$maybe ident <- identSecret
+  <input type=hidden name=#{fieldName} id=#{fieldId}--ident value=#{ident}>
+  
+$if not (null fileInfos)
+  <div .file-uploads-label>_{MsgPreviouslyUploadedInfo}
+  <ul .list--iconless .file-input__list>
+    $forall FileUploadInfo{..} <- fileInfos
+      <li>
+        <div .file-container>
+          <input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{toPathPiece fuiId} :fuiForced:readonly>
+          $if fuiSession
+            ^{messageTooltip uploadOnlySessionMessage}
+          <label for=#{fuiHtmlId}>
+            #{fuiTitle}
+
+  <div .file-input__info>
+    _{MsgPreviouslyUploadedDeletionInfo}
+
+  <div .file-uploads-label>_{MsgAddMoreFiles}
+
+$# new files
+<input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required>
+
+$if fieldMultiple
+  <div .file-input__info>
+    _{MsgMultiFileUploadInfo}
+
+$maybe exts <- fmap toNullable fieldRestrictExtensions
+  <div .file-input__info>
+    _{MsgUploadModeExtensionRestriction}: #
+    <ul .list--inline .list--comma-separated .list--iconless>
+      $forall ext <- bool id (mappend zipExtensions) mayUnpack exts
+        <li style="font-family: monospace">#{ext}
+
+$if not (fieldOptionForce fieldUnpackZips)
+  <div .file-input__unpack>
+    ^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}
+    <label for=#{fieldId}_zip>_{MsgAutoUnzip}
+    <input type=checkbox id=#{fieldId}--zip name=#{fieldName} value=#{unpackZips} :fieldOptionDefault fieldUnpackZips:checked>