refactor(files): store content separately from metadata

messages/uniworx/de-de-formal.msg

@@ -333,6 +333,11 @@ SheetGeneratePseudonym: Generieren
 SheetAnonymousCorrection: Anonymisierte Korrektur
 SheetAnonymousCorrectionTip: Wenn die Korrektur anonymisiert erfolgt, können Korrektoren die ihnen zugeteilten Abgaben nicht bestimmten Studierenden zuordnen (Name, Matrikelnummer und feste Abgabegruppe der Abgebenden werden versteckt) 
 
+SheetArchiveFileTypeDirectoryExercise: aufgabenstellung
+SheetArchiveFileTypeDirectoryHint: hinweis
+SheetArchiveFileTypeDirectorySolution: loesung
+SheetArchiveFileTypeDirectoryMarking: korrektur
+
 SheetFormType: Wertung & Abgabe
 SheetFormTimes: Zeiten
 SheetFormFiles: Dateien

minio-file-uploads.md

@@ -0,0 +1,12 @@
+  - `SessionFile` should only have `touched` and `content`; just there to keep `FileContent` alive  
+    Store `fileTitle` and `fileModified` within actual session
+
+    Better symmetry with e.g. `SubmissionFile`
+  - Restrict `genericFileField` to not allow duplicate `fileTitle`s
+
+    Make `fieldAdditionalFiles` isomophoric to `[FileReference, FileFieldUserOption Bool]`
+
+    `type FileUploads = Map FileTitle (Maybe FileContentReference, UTCTime)` (`~ [FileReference]`)
+  - Route um Uploads nachzureichen
+
+    Cronjob, der `FileContent` aus MinIO füttert sollte panische E-Mail mit Link auf jene Route verschicken, wenn Datei nicht zur Hand ist

models/allocations.model

@@ -30,7 +30,7 @@ AllocationMatching
     allocation          AllocationId
     fingerprint         AllocationFingerprint
     time                UTCTime
-    log                 FileId
+    log                 FileContentReference
 
 AllocationCourse
     allocation          AllocationId

models/audit.model

@@ -5,3 +5,4 @@ TransactionLog
   initiator UserId Maybe -- User associated with performing this action
   remote IP Maybe -- Remote party that triggered this action via HTTP
   info Value -- JSON-encoded `Transaction`
+  deriving Eq Read Show Generic Typeable

models/courses.model

@@ -35,9 +35,11 @@ CourseEvent
     lastChanged UTCTime default=now()
 
 CourseAppInstructionFile
-    course    CourseId
+    course   CourseId
-    file      FileId
+    title    FilePath
-    UniqueCourseAppInstructionFile course file
+    content  FileContentReference Maybe
+    modified UTCTime
+    UniqueCourseAppInstructionFile course title
 
 CourseEdit                -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables)
     user         UserId

models/courses/applications.model

@@ -10,7 +10,10 @@ CourseApplication
     allocationPriority  Natural         Maybe
     time                UTCTime               default=now()
     ratingTime          UTCTime         Maybe
+
 CourseApplicationFile 
     application         CourseApplicationId
-    file                FileId
+    title               FilePath
-    UniqueApplicationFile application file
+    content             FileContentReference Maybe
+    modified            UTCTime
+    UniqueCourseApplicationFile application title

models/courses/materials.model

@@ -9,5 +9,7 @@ Material -- course material for disemination to course participants
   deriving Generic
 MaterialFile -- a file that is part of a material distribution
   material MaterialId
-  file     FileId
+  title    FilePath
-  UniqueMaterialFile material file
+  content  FileContentReference Maybe
+  modified UTCTime
+  UniqueMaterialFile material title

models/courses/news.model

@@ -7,6 +7,8 @@ CourseNews
     summary             Html Maybe
     lastEdit            UTCTime
 CourseNewsFile
-    news                CourseNewsId
+    news     CourseNewsId
-    file                FileId
+    title    FilePath
-    UniqueCourseNewsFile news file
+    content  FileContentReference Maybe
+    modified UTCTime
+    UniqueCourseNewsFile news title

models/files.model

@@ -1,12 +1,8 @@
--- Table storing all kinds of larges files as 8bit-byte vectors (regardless of encoding)
+FileContent
--- PostgreSQL is intelligent enough to handle this in a sensible manner;
+    hash            FileContentReference
--- helps to ensure consistency of database snapshots, no data is stored outside database
+    content         ByteString
-File
+    Primary         hash
-    title           FilePath
-    content         ByteString Maybe -- Nothing iff this is a directory
-    modified        UTCTime
-    deriving Show Eq Generic
 
 SessionFile
-    file            FileId
+    content         FileContentReference Maybe
     touched         UTCTime

models/sheets.model

@@ -37,7 +37,9 @@ SheetCorrector                -- grant corrector role to user for a sheet
     UniqueSheetCorrector user sheet
     deriving Show Eq Ord
 SheetFile                     -- a file that is part of an exercise sheet
-    sheet           SheetId
+    sheet    SheetId
-    file            FileId
+    type     SheetFileType   -- excercise, marking, hint or solution
-    type            SheetFileType   -- excercise, marking, hint or solution
+    title    FilePath
-    UniqueSheetFile file sheet type
+    content  FileContentReference Maybe
+    modified UTCTime
+    UniqueSheetFile sheet type title

models/submissions.model

@@ -11,11 +11,13 @@ SubmissionEdit                    -- user uploads new version of their submissio
     time            UTCTime
     submission      SubmissionId
 SubmissionFile                    -- files that are part of a submission
-    submission      SubmissionId
+    submission SubmissionId
-    file            FileId
+    title      FilePath
-    isUpdate        Bool          -- is this the file updated by a corrector (original will always be retained)
+    content    FileContentReference Maybe
-    isDeletion      Bool          -- only set if isUpdate is also set, but file was deleted by corrector
+    modified   UTCTime
-    UniqueSubmissionFile file submission isUpdate
+    isUpdate   Bool          -- is this the file updated by a corrector (original will always be retained)
+    isDeletion Bool          -- only set if isUpdate is also set, but file was deleted by corrector
+    UniqueSubmissionFile submission title isUpdate
     deriving Show
 SubmissionUser                    -- which submission belongs to whom
     user            UserId

src/Audit.hs

@@ -24,6 +24,8 @@ import qualified Net.IPv6 as IPv6
 
 import Control.Exception (ErrorCall(..))
 
+import GHC.Stack
+
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
 
@@ -86,6 +88,7 @@ audit :: ( AuthId (HandlerSite m) ~ Key User
          , MonadHandler m
          , MonadCatch m
          , HasAppSettings (HandlerSite m)
+         , HasCallStack
          )
       => Transaction -- ^ Transaction to record
       -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
@@ -94,7 +97,7 @@ audit :: ( AuthId (HandlerSite m) ~ Key User
 --   - `transactionLogTime` is now
 --   - `transactionLogInitiator` is currently logged in user (or none)
 --   - `transactionLogRemote` is determined from current HTTP-Request
-audit (toJSON -> transactionLogInfo) = do
+audit transaction@(toJSON -> transactionLogInfo) = do
 
   transactionLogTime <- liftIO getCurrentTime
   transactionLogInstance <- getsYesod $ view instanceID
@@ -102,3 +105,5 @@ audit (toJSON -> transactionLogInfo) = do
   transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
 
   insert_ TransactionLog{..}
+
+  $logInfoS "Audit" $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> "\n" <> pack (prettyCallStack callStack)

src/Audit/Types.hs

@@ -92,28 +92,10 @@ data Transaction
   | TransactionSubmissionFileEdit
     { transactionSubmissionFile :: SubmissionFileId
     , transactionSubmission     :: SubmissionId
-    , transactionFile           :: FileId
     }
   | TransactionSubmissionFileDelete
     { transactionSubmissionFile :: SubmissionFileId
     , transactionSubmission     :: SubmissionId
-    , transactionFile           :: FileId
-    }
-
-  -- TODO: not yet audited
-  | TransactionUserEdit
-    { transactionUser :: UserId
-    }
-  | TransactionUserDelete
-    { transactionUser :: UserId
-    }
-
-  -- TODO: not yet audited
-  | TransactionFileEdit
-    { transactionFile :: FileId
-    }
-  | TransactionFileDelete
-    { transactionFile :: FileId
     }
 
   | TransactionExamOfficeUserAdd

src/CryptoID.hs

@@ -58,7 +58,6 @@ instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m)
 
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
-             , ''FileId
              , ''UserId
              , ''SheetId
              , ''SystemMessageId

src/Database/Esqueleto/Utils.hs

@@ -22,6 +22,7 @@ module Database.Esqueleto.Utils
   , (->.)
   , fromSqlKey
   , selectCountRows
+  , selectMaybe
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -271,3 +272,6 @@ selectCountRows q = do
       -> return res'
     _other
       -> error "E.countRows did not return exactly one result"
+
+selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
+selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)

src/Foundation/I18n.hs

@@ -7,6 +7,7 @@ module Foundation.I18n
   , MsgLanguage(..)
   , ShortSex(..)
   , SheetTypeHeader(..)
+  , SheetArchiveFileTypeDirectory(..)
   , ShortStudyDegree(..)
   , ShortStudyTerms(..)
   , StudyDegreeTerm(..)
@@ -212,6 +213,9 @@ embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
 
+newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
+embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel
+
 instance RenderMessage UniWorX SheetType where
   renderMessage foundation ls sheetType = case sheetType of
       NotGraded -> mr $ SheetTypeHeader NotGraded

src/Handler/Admin/Test/Download.hs

@@ -10,7 +10,6 @@ import qualified Crypto.Random as Random
 
 import qualified Data.ByteString.Base64.URL as Base64
 
-import qualified Data.Conduit.List as C (mapMaybe)
 import qualified Data.Conduit.Combinators as C
 
 import qualified Data.Binary as Binary
@@ -81,13 +80,12 @@ testDownload = do
       sourceDBChunks :: ConduitT () Int DB ()
       sourceDBChunks = forever sourceDBFiles
                     .| C.mapM (\x -> x <$ $logDebugS "testDownload.sourceDBChunks" (tshow $ entityKey x))
-                    .| C.mapMaybe ((fmap length $!!) . fileContent . entityVal)
+                    .| C.map ((length $!!) . fileContentContent . entityVal)
                     .| takeLimit dlMaxSize
         where
-          sourceDBFiles = E.selectSource . E.from $ \file -> do
+          sourceDBFiles = E.selectSource . E.from $ \fileContent -> do
             E.orderBy [E.asc $ E.random_ @Int64]
-            E.where_ . E.not_ . E.isNothing $ file E.^. FileContent
+            return fileContent
-            return file
           
           takeLimit n | n <= 0 = return ()
           takeLimit n = do

src/Handler/Allocation/Application.hs

@@ -15,12 +15,9 @@ import qualified Data.Text as Text
 import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.Conduit.List as C
 
-import Crypto.Hash (hash)
-
 import Control.Monad.Trans.State (execStateT)
 import Control.Monad.State.Class (modify) 
 
@@ -290,13 +287,8 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
             , courseApplicationTime               = now
             , courseApplicationRatingTime         = guardOn rated now
             }
-          let
+
-            sinkFile' (Right file) =
+          runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
-              insert file >>= sinkFile' . Left
-            sinkFile' (Left fId) =
-              insert_ $ CourseApplicationFile appId fId
-          forM_ afFiles $ \afFiles' ->
-            runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
           audit $ TransactionCourseApplicationEdit cid uid appId
           addMessageI Success $ MsgCourseApplicationCreated courseShorthand
       | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
@@ -307,33 +299,15 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
 
           changes <- if
             | afmApplicantEdit afMode -> do
-              oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
+              oldFiles <- Set.fromList . map (courseApplicationFileTitle . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
               changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
-                let sinkFile' (Right file) = do
+                let sinkAppFile fRef@FileReference{..}
-                      oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do
+                      | fileReferenceTitle `Set.member` oldFiles = modify $ Set.delete fileReferenceTitle
-                        E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId
-                        E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file)
-                                E.&&. E.maybe
-                                        (E.val . is _Nothing $ fileContent file)
-                                        (\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file)
-                                        (file' E.^. FileContent)
-                                E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles)
-                        return $ file' E.^. FileId
-                      if
-                        | [E.Value oldFileId] <- oldFiles'
-                          -> modify $ Set.delete oldFileId
-                        | otherwise
-                          -> do
-                            fId <- lift $ insert file
-                            lift . insert_ $ CourseApplicationFile appId fId
-                            modify $ Set.insert fId
-                    sinkFile' (Left fId)
-                      | fId `Set.member` oldFiles = modify $ Set.delete fId
                       | otherwise = do
-                          lift . insert_ $ CourseApplicationFile appId fId
+                          lift . insert_ $ _FileReference # (fRef, CourseApplicationFileResidual appId)
-                          modify $ Set.insert fId
+                          modify $ Set.insert fileReferenceTitle
-                in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
+                in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkAppFile
-              deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
+              deleteWhere [ CourseApplicationFileApplication ==. appId, CourseApplicationFileTitle <-. Set.toList (oldFiles `Set.intersection` changes) ]
               return changes
             | otherwise
               -> return Set.empty

src/Handler/Course/Application/Files.hs

@@ -31,10 +31,9 @@ getCAFilesR tid ssh csh cID = do
 
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
   let
-    fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
+    fsSource = E.selectSource . E.from $ \courseApplicationFile -> do
-      E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
       E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
-      return file
+      return courseApplicationFile
 
   serveSomeFiles archiveName $ fsSource .| C.map entityVal
 
@@ -47,7 +46,7 @@ getCAppsFilesR tid ssh csh = do
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
 
   let
-    fsSource :: ConduitT () File DB ()
+    fsSource :: ConduitT () CourseApplicationFile DB ()
     fsSource = do
       apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
         E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
@@ -90,19 +89,19 @@ getCAppsFilesR tid ssh csh = do
       forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
         cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
         let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
-            dirFiles = C.map $ over _fileTitle mkAppDir . entityVal
+            fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do
-            fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
-              E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
               E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
-              return file
+              return courseApplicationFile
         
-        yield File
+        yield $ _FileReference # ( FileReference
-          { fileModified = courseApplicationTime
+                                   { fileReferenceModified = courseApplicationTime
-          , fileTitle = mkAppDir ""
+                                   , fileReferenceTitle = mkAppDir ""
-          , fileContent = Nothing
+                                   , fileReferenceContent = Nothing
-          }
+                                   }
+                                 , CourseApplicationFileResidual appId
+                                 )
 
-        fileEntitySource .| dirFiles
+        fileEntitySource .| C.map (view _entityVal) .| C.map (over (_FileReference . _1 . _fileReferenceTitle) mkAppDir)
 
 
   serveSomeFiles archiveName fsSource

src/Handler/Course/Edit.hs

@@ -40,7 +40,7 @@ data CourseForm = CourseForm
         , cfAllocation  :: Maybe AllocationCourseForm
         , cfAppRequired         :: Bool
         , cfAppInstructions     :: Maybe Html
-        , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
+        , cfAppInstructionFiles :: Maybe FileUploads
         , cfAppText             :: Bool
         , cfAppFiles            :: UploadMode
         , cfAppRatingsVisible   :: Bool
@@ -84,10 +84,10 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
                            ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
     }
   where
-    cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue)
+    cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (view $ _entityVal . _FileReference . _1)
       where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
               E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
-              return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile
+              return courseAppInstructionFile
       
 
 allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
@@ -521,14 +521,14 @@ courseEditHandler miButtonAction mbCourseForm = do
                     insert_ $ CourseEdit aid now cid
 
                     let
-                      finsert val = do
+                      finsert fRef@FileReference{..} = do
-                        fId <- lift $ either return insert val
+                        tell $ Set.singleton fileReferenceTitle
-                        tell $ Set.singleton fId
+                        void . lift $ upsertBy (UniqueCourseAppInstructionFile cid fileReferenceTitle) (_FileReference # (fRef, CourseAppInstructionFileResidual cid))
-                        lift $
+                          [ CourseAppInstructionFileModified =. fileReferenceModified
-                          void . insertUnique $ CourseAppInstructionFile cid fId
+                          , CourseAppInstructionFileContent =. fileReferenceContent
+                          ]
                     keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
-                    acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
+                    deleteWhere [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileTitle /<-. Set.toList keep ]
-                    mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
 
                     upsertAllocationCourse cid $ cfAllocation res
 

src/Handler/Course/News/Download.hs

@@ -19,10 +19,9 @@ getCNArchiveR tid ssh csh cID = do
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle)
 
   let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $
-        \(newsFile `E.InnerJoin` file) -> do
+        \newsFile -> do
-          E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
           E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
-          return file
+          return newsFile
 
   serveSomeFiles archiveName getFilesQuery
 
@@ -32,10 +31,9 @@ getCNFileR _ _ _ cID title = do
   nId <- decrypt cID
 
   let
-    fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do
+    fileQuery = E.selectSource . E.from $ \newsFile -> do
-        E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId
+        E.where_ $ newsFile E.^. CourseNewsFileNews  E.==. E.val nId
-        E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
+             E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val title
-             E.&&. file     E.^. FileTitle          E.==. E.val title
+        return newsFile
-        return file
 
   serveOneFile $ fileQuery .| C.map entityVal

src/Handler/Course/News/Edit.hs

@@ -20,7 +20,7 @@ postCNEditR tid ssh csh cID = do
     courseNews <- get404 nId
     cnfs <- selectList [CourseNewsFileNews ==. nId] []
     return ( courseNews
-           , setOf (folded . _entityVal . _courseNewsFileFile) cnfs
+           , cnfs ^.. folded . _entityVal . _FileReference . _1
            )
 
   ((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids
@@ -38,10 +38,12 @@ postCNEditR tid ssh csh cID = do
         , courseNewsLastEdit         = now
         }
       let
-        insertFile (Left  fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) []
+        insertFile fRef@FileReference{..} = fileReferenceTitle <$ upsertBy (UniqueCourseNewsFile nId fileReferenceTitle) (_FileReference # (fRef, CourseNewsFileResidual nId))
-        insertFile (Right f  ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId)
+          [ CourseNewsFileModified =. fileReferenceModified
-      newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton
+          , CourseNewsFileContent =. fileReferenceContent
-      deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ]
+          ]
+      newTitles <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton
+      deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileTitle /<-. Set.toList newTitles ]
     addMessageI Success MsgCourseNewsEdited
     redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
 

src/Handler/Course/News/Form.hs

@@ -9,8 +9,6 @@ import Handler.Utils
 
 import qualified Data.Conduit.List as C
 
-import qualified Data.Set as Set
-
 
 data CourseNewsForm = CourseNewsForm
   { cnfTitle            :: Maybe Text
@@ -18,14 +16,14 @@ data CourseNewsForm = CourseNewsForm
   , cnfContent          :: Html
   , cnfParticipantsOnly :: Bool
   , cnfVisibleFrom      :: Maybe UTCTime
-  , cnfFiles            :: Maybe (ConduitT () (Either FileId File) Handler ())
+  , cnfFiles            :: Maybe FileUploads 
   }
 
 courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
 courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do
   now <- liftIO getCurrentTime
 
-  let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles
+  let oldFileIds = fromMaybe (return ()) $ template >>= cnfFiles
       cTime = ceilingQuarterHour now
       visibleFromTip
         | Just vFrom <- template >>= cnfVisibleFrom
@@ -48,7 +46,7 @@ courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard
     (cnfContent <$> template)
   cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template)
   cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime))
-  cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template)
+  cnfFiles' <- wopt (multiFileField' oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template)
 
   return $ CourseNewsForm
     <$> cnfTitle'
@@ -58,12 +56,12 @@ courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard
     <*> cnfVisibleFrom'
     <*> cnfFiles'
 
-courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm
+courseNewsToForm :: CourseNews -> [FileReference] -> CourseNewsForm
 courseNewsToForm CourseNews{..} fs = CourseNewsForm
   { cnfTitle = courseNewsTitle
   , cnfSummary = courseNewsSummary
   , cnfContent = courseNewsContent
   , cnfParticipantsOnly = courseNewsParticipantsOnly
   , cnfVisibleFrom = courseNewsVisibleFrom
-  , cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs)
+  , cnfFiles = guardOn (not $ null fs) $ C.sourceList fs
   }

src/Handler/Course/News/New.hs

@@ -30,8 +30,7 @@ postCNewsNewR tid ssh csh = do
         , courseNewsLastEdit         = now
         }
       let
-        insertFile (Left  fId) = insert_ $ CourseNewsFile nId fId
+        insertFile = insert_ . review _FileReference . (, CourseNewsFileResidual nId)
-        insertFile (Right f  ) = insert_ . CourseNewsFile nId =<< insert f
       forM_ cnfFiles $ \fSource ->
         runConduit $ transPipe lift fSource .| C.mapM_ insertFile
       encrypt nId :: DB CryptoUUIDCourseNews

src/Handler/Course/Register.hs

@@ -195,7 +195,7 @@ postCRegisterR tid ssh csh = do
             whenIsJust appRes $ 
               audit . TransactionCourseApplicationEdit cid uid 
             whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
-              runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . CourseApplicationFile appId <=< either return insert)
+              runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
             return appRes
         | otherwise
         = return $ Just ()
@@ -256,9 +256,7 @@ deleteApplications uid cid = do
     audit $ TransactionCourseApplicationDeleted cid uid appId
 
 deleteApplicationFiles :: CourseApplicationId -> DB ()
-deleteApplicationFiles appId = do
+deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ]
-  fs <- selectList [ CourseApplicationFileApplication ==. appId ] []
-  deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ]
 
 deregisterParticipant :: UserId -> CourseId -> DB ()
 deregisterParticipant uid cid = do

src/Handler/Course/Show.hs

@@ -79,10 +79,9 @@ getCShowR tid ssh csh = do
       cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
       guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
       let visible = cTime >= NTop courseNewsVisibleFrom
-      files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do
+      files' <- lift . lift . E.select . E.from $ \newsFile -> do
-        E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
         E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
-        return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle)
+        return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle)
       let files = files'
             & over (mapped . _1) E.unValue
             & over (mapped . _2) E.unValue
@@ -228,11 +227,10 @@ getCShowR tid ssh csh = do
 getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
 getCRegisterTemplateR tid ssh csh = do
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh
-  let source = (.| C.map entityVal) . E.selectSource . E.from $ \(file `E.InnerJoin` courseAppInstructionFile `E.InnerJoin` course) -> do
+  let source = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do
         E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
-        E.on $ courseAppInstructionFile E.^. CourseAppInstructionFileFile E.==. file E.^. FileId
         E.where_ $ course E.^. CourseTerm E.==. E.val tid
              E.&&. course E.^. CourseSchool E.==. E.val ssh
              E.&&. course E.^. CourseShorthand E.==. E.val csh
-        return file
+        return courseAppInstructionFile
   serveSomeFiles archiveName source

src/Handler/Material.hs

@@ -22,19 +22,13 @@ data MaterialForm = MaterialForm
       , mfType         :: Maybe (CI Text)
       , mfDescription  :: Maybe Html
       , mfVisibleFrom  :: Maybe UTCTime
-      , mfFiles        :: Maybe (ConduitT () (Either FileId File) Handler ())
+      , mfFiles        :: Maybe FileUploads 
       }
 
 makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
 makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
   MsgRenderer mr <- getMsgRenderer
-  let setIds :: Either FileId File -> Set FileId
+  let typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
-      setIds = either Set.singleton $ const Set.empty
-      oldFileIds
-        | Just source <- template >>= mfFiles
-                    = runConduit $ source .| C.foldMap setIds
-        | otherwise = return Set.empty
-      typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
       typeOptions = do
         let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
         previouslyUsed <- runDB $
@@ -62,7 +56,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
                                                              (mfDescription <$> template)
       <*> aopt utcTimeField   (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip)
                                                             ((mfVisibleFrom <$> template) <|> pure (Just ctime))
-      <*> aopt (multiFileField oldFileIds)
+      <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template)
                               (fslI MsgMaterialFiles)        (mfFiles <$> template)
 
 getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material)
@@ -163,20 +157,19 @@ getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -
 getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
   where
     fileQuery = E.selectSource $ E.from $
-      \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
+      \(course `E.InnerJoin` material `E.InnerJoin` matFile) -> do
         -- Restrict to consistent rows that correspond to each other
-        E.on (file     E.^. FileId               E.==. matFile  E.^. MaterialFileFile)
         E.on (matFile  E.^. MaterialFileMaterial E.==. material E.^. MaterialId)
         E.on (material E.^. MaterialCourse       E.==. course   E.^. CourseId)
         -- filter to requested file
-        E.where_ ((file      E.^. FileTitle       E.==. E.val title)
+        E.where_ ((matFile   E.^. MaterialFileTitle E.==. E.val title)
-          E.&&.   (material  E.^. MaterialName    E.==. E.val mnm  )
+          E.&&.   (material  E.^. MaterialName      E.==. E.val mnm  )
-          E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
+          E.&&.   (course    E.^. CourseShorthand   E.==. E.val csh  )
-          E.&&.   (course    E.^. CourseSchool    E.==. E.val ssh  )
+          E.&&.   (course    E.^. CourseSchool      E.==. E.val ssh  )
-          E.&&.   (course    E.^. CourseTerm      E.==. E.val tid  )
+          E.&&.   (course    E.^. CourseTerm        E.==. E.val tid  )
           )
         -- return file entity
-        return file
+        return matFile
 
 getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
 getMShowR tid ssh csh mnm = do
@@ -197,12 +190,11 @@ getMShowR tid ssh csh mnm = do
           else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt)
     let psValidator = def & defaultSortingByFileTitle
     fileTable' <- dbTable psValidator DBTable
-      { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do
+      { dbtSQLQuery = \matFile -> do
-            E.on     $ matFile E.^. MaterialFileFile     E.==. file E.^. FileId
             E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
-                E.&&.  E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
+                E.&&.  E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories
-            return (file E.^. FileTitle, file E.^. FileModified)
+            return (matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified)
-      , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
+      , dbtRowKey = (E.^. MaterialFileId)
       , dbtColonnade = widgetColonnade $ mconcat
             [ (<> indicatorCell) <$> colFilePathSimple   (view $ _dbrOutput . _1) matLink
             , materialModDateCol  (view $ _dbrOutput . _2)
@@ -214,9 +206,9 @@ getMShowR tid ssh csh mnm = do
       , dbtFilterUI = mempty
       , dbtIdent    = "material-files" :: Text
       , dbtSorting  = Map.fromList
-            [ sortFilePath         $(sqlIJproj 2 2)
+        [ sortFilePath         id
-            , sortFileModification $(sqlIJproj 2 2)
+        , sortFileModification id
-            ]
+        ]
       , dbtCsvEncode  = noCsvEncode
       , dbtCsvDecode  = Nothing
       }
@@ -239,18 +231,15 @@ getMEditR = postMEditR
 postMEditR tid ssh csh mnm = do
   (Entity mid Material{..}, files) <- runDB $ do
     matEnt <- fetchMaterial tid ssh csh mnm
-    fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do
+    mFileEnts <- selectList [ MaterialFileMaterial ==. entityKey matEnt ] []
-      E.on     $ matFile  E.^. MaterialFileFile     E.==. file E.^. FileId
+    return (matEnt, mFileEnts)
-      E.where_ $ matFile  E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
-      return $ file E.^. FileId
-    return (matEnt, Left . E.unValue <$> fileIds)
   -- let cid = materialCourse
   let template = Just MaterialForm
         { mfName         = materialName
         , mfType         = materialType
         , mfDescription  = materialDescription
         , mfVisibleFrom  = materialVisibleFrom
-        , mfFiles        = Just $ yieldMany files
+        , mfFiles        = Just $ yieldMany [ matFile ^. _FileReference . _1 | Entity _ matFile <- files ]
         }
   editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
   let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
@@ -305,23 +294,21 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
       when saveOk $ redirect -- redirect must happen outside of runDB
         $ CourseR tid ssh csh (MaterialR mfName MShowR)
 
-    insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB ()
+    insertMaterialFile' :: MaterialId -> FileUploads -> DB ()
     insertMaterialFile' mid fs = do
-        oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
+      oldFiles <- fmap (Map.fromList . map $(unValueN 2)) . E.select . E.from $ \materialFile -> do
-          E.on     $  materialFile E.^. MaterialFileFile E.==. file E.^. FileId
+        E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
-          E.where_ $  materialFile E.^. MaterialFileMaterial E.==. E.val mid
+        return (materialFile E.^. MaterialFileTitle, materialFile E.^. MaterialFileId)
-          return $ file E.^. FileId
+      keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
-        let oldFileIds = setFromList $ map E.unValue oldFileIdVals
+      deleteWhere [ MaterialFileMaterial ==. mid, MaterialFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
-        keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
-        mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
       where
-        finsert (Left fid) = do
+        finsert oldFiles fRef
-          lift . void $ upsertBy (UniqueMaterialFile mid fid) (MaterialFile mid fid) []
+          | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
-          tell $ singleton fid
+          = tell $ Set.singleton sfId
-        finsert (Right file) = lift $ do
+          | otherwise
-          fid <- insert file
+          = do
-          void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+              sfId <- lift . insert $ _FileReference # (fRef, MaterialFileResidual mid)
-
+              tell $ Set.singleton sfId
 
 getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand ->  MaterialName -> Handler Html
 getMDelR = postMDelR
@@ -363,15 +350,14 @@ getMArchiveR tid ssh csh mnm = do
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm
 
   let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
-        \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
+        \(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do
-          E.on $ file     E.^. FileId         E.==. materialFile E.^. MaterialFileFile
           E.on $ material E.^. MaterialId     E.==. materialFile E.^. MaterialFileMaterial
           E.on $ material E.^. MaterialCourse E.==. course       E.^. CourseId
           E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
               E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
               E.&&.  course   E.^. CourseShorthand E.==. E.val csh
               E.&&.  material E.^. MaterialName    E.==. E.val mnm
-          return file
+          return materialFile
 
   serveSomeFiles archiveName getMatQuery
     

src/Handler/Sheet.hs

@@ -57,7 +57,7 @@ type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
 data SheetForm = SheetForm
       { sfName         :: SheetName
       , sfDescription  :: Maybe Html
-      , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
+      , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: Maybe UTCTime
       , sfActiveTo     :: Maybe UTCTime
@@ -85,13 +85,12 @@ instance Button UniWorX ButtonGeneratePseudonym where
   btnClasses BtnGenerate = [BCIsButton, BCDefault]
 
 
-getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
+getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
 getFtIdMap sId = do
-  allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
+  allSheetFiles <- E.select . E.from $ \sheetFile -> do
-      E.on     $ sheetFile E.^. SheetFileFile  E.==. file E.^. FileId
       E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
-      return    (sheetFile E.^. SheetFileType, file E.^. FileId)
+      return sheetFile
-  return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
+  return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ]
 
 makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
@@ -353,14 +352,12 @@ getSShowR tid ssh csh shn = do
         | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft)  =  dateTimeCell mtime
         | otherwise  =  mempty
 
-  let fileData (sheetFile `E.InnerJoin` file) = do
+  let fileData sheetFile = do
-        -- Restrict to consistent rows that correspond to each other
-        E.on (sheetFile E.^. SheetFileFile  E.==.  file E.^. FileId)
         -- filter to requested file
         E.where_ $  sheetFile E.^. SheetFileSheet  E.==.  E.val sid
-              E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
+              E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories
         -- return desired columns
-        return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
+        return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType)
   let colonnadeFiles = widgetColonnade $ mconcat
         [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
             let link = CSheetR tid ssh csh shn $ SZipR ftype in
@@ -382,7 +379,7 @@ getSShowR tid ssh csh shn = do
                         & forceFilter "may-access" (Any True)
   (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery = fileData
-    , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
+    , dbtRowKey = (E.^. SheetFileId)
     , dbtColonnade = colonnadeFiles
     , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
     , dbtStyle = def
@@ -395,16 +392,16 @@ getSShowR tid ssh csh shn = do
     , dbtIdent = "files" :: Text
     , dbtSorting = Map.fromList
       [ ( "type"
-        , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> E.orderByEnum $ sheetFile E.^. SheetFileType
+        , SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType
         )
       , ( "path"
-        , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
+        , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle
         )
       -- , ( "visible"
       --   , SortColumn $ \(sheetFile `E.InnerJoin` _file) ->  sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
       --   )
       , ( "time"
-        , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
+        , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified
         )
       ]
     , dbtParams = def
@@ -442,10 +439,44 @@ getSShowR tid ssh csh shn = do
 
 getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
 getSArchiveR tid ssh csh shn = do
-  archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetArchiveName tid ssh csh shn
+  shId <- runDB $ fetchSheetId tid ssh csh shn
+
+  MsgRenderer mr <- getMsgRenderer
+  let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn
   let sftArchive  = CSheetR tid ssh csh shn . SZipR    -- used to check access to SheetFileTypes
-  allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound]
+  allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF
-  serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal
+  multipleSFTs <- if
+    | length allowedSFTs < 2 -> return False
+    | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do
+        E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType
+         E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle
+        E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet
+         E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet
+        E.where_ $ sheet E.^. SheetId E.==. E.val shId
+             E.&&. sFile1 E.^. SheetFileType  `E.in_` E.valList allowedSFTs
+             E.&&. sFile2 E.^. SheetFileType  `E.in_` E.valList allowedSFTs
+  let modifyTitles SheetFile{..}
+        | not multipleSFTs = SheetFile{..}
+        | otherwise = SheetFile
+          { sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) </> sheetFileTitle
+          , ..
+          }
+  sftDirectories <- if
+    | not multipleSFTs -> return mempty
+    | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do
+        E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId
+             E.&&. sFile E.^. SheetFileType E.==. E.val sft
+        return . E.max_ $ sFile E.^. SheetFileModified
+  
+  serveZipArchive archiveName $ do
+    forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile
+      { sheetFileType = sft
+      , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft
+      , sheetFileModified = mTime
+      , sheetFileContent = Nothing
+      , sheetFileSheet = shId
+      }
+    sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles
 
 
 getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
@@ -562,12 +593,12 @@ getSEditR tid ssh csh shn = do
         , sfActiveFrom     = sheetActiveFrom
         , sfActiveTo       = sheetActiveTo
         , sfSubmissionMode = sheetSubmissionMode
-        , sfSheetF         = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
+        , sfSheetF         = Just . yieldMany . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom       = sheetHintFrom
-        , sfHintF          = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
+        , sfHintF          = Just . yieldMany . Set.elems $ sheetFileIds SheetHint
         , sfSolutionFrom   = sheetSolutionFrom
-        , sfSolutionF      = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
+        , sfSolutionF      = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution
-        , sfMarkingF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
+        , sfMarkingF       = Just . yieldMany . Set.elems $ sheetFileIds SheetMarking
         , sfMarkingText    = sheetMarkingText
         , sfAutoDistribute = sheetAutoDistribute
         , sfAnonymousCorrection = sheetAnonymousCorrection
@@ -674,22 +705,22 @@ postSDelR tid ssh csh shn = do
     }
 
 
-insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
+insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX ()
 insertSheetFile' sid ftype fs = do
-    oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
+    oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
       E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
-           E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
+           E.&&. sheetFile E.^. SheetFileType  E.==. E.val ftype
-      return (file E.^. FileId)
+      return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId)
-    keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
+    keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
-    mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
+    deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
   where
-    finsert (Left fid) = do
+    finsert oldFiles fRef
-      lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) []
+      | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
-      tell $ singleton fid
+      = tell $ Set.singleton sfId
-    finsert (Right file) = lift $ do
+      | otherwise
-      fid <- insert file
+      = do
-      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+          sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype)
+          tell $ Set.singleton sfId
 
 
 defaultLoads :: CourseId -> DB Loads

src/Handler/Submission/Correction.hs

@@ -17,8 +17,6 @@ import qualified Control.Monad.State.Class as State
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
-import qualified Data.Conduit.List as C
-
 
 correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
 correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
@@ -30,13 +28,11 @@ correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin`
        E.&&. course E.^. CourseShorthand  E.==. E.val csh
        E.&&. sheet  E.^. SheetName        E.==. E.val shn
        E.&&. submission E.^. SubmissionId E.==. E.val sub
-  let filesCorrected = E.exists . E.from $ \((f1 `E.InnerJoin` sFile1) `E.LeftOuterJoin` (f2 `E.InnerJoin` sFile2)) -> do
+  let filesCorrected = E.exists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do
-        E.on $ f2 E.?. FileId E.==. sFile2 E.?. SubmissionFileFile
+        E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle
-        E.on $ E.just (f1 E.^. FileTitle) E.==. f2 E.?. FileTitle
          E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission
-         -- E.&&. f1 E.^. FileContent E.!=. E.joinV (f2 E.?. FileContent)
+         E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent)
          E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate)
-        E.on $ f1 E.^. FileId E.==. sFile1 E.^. SubmissionFileFile
         E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. submission E.^. SubmissionId
              E.&&. sFile2 E.?. SubmissionFileSubmission E.==. E.just (submission E.^. SubmissionId)
   return (course, sheet, submission, corrector, filesCorrected)
@@ -133,7 +129,7 @@ postCorrectionR tid ssh csh shn cid = do
       formResult uploadResult $ \fileUploads -> do
         uid <- maybeAuthId
 
-        res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+        res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
         when (is _Just res) $ do
           addMessageI Success MsgRatingFilesUpdated

src/Handler/Submission/Download.hs

@@ -37,14 +37,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
           maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
       | otherwise -> notFound
     False -> do
-      let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+      let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do
-            E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
             E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-                 E.&&. f E.^. FileTitle E.==. E.val path
+                 E.&&. sf E.^. SubmissionFileTitle E.==. E.val path
                  E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
                  E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
                  -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
-            return f
+            return sf
 
       serveOneFile results
 
@@ -61,17 +60,16 @@ getSubArchiveR tid ssh csh shn cID sfType = do
         rating <- lift $ getRating submissionID
 
         case sfType of
-          SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+          SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do
-            E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
             E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
                  E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
-            return f
+            return sf
-          _ -> submissionFileSource submissionID .| Conduit.map entityVal
+          _other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal)
 
         when (sfType == SubmissionCorrected) $
-          maybe (return ()) (yieldM . ratingFile cID) rating
+          maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating
 
-  serveSomeFiles archiveName source
+  serveSomeFiles' archiveName source
 
 
 getCorrectionsDownloadR :: Handler TypedContent

src/Handler/Submission/Helper.hs

@@ -18,8 +18,6 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
 
-import qualified Data.Conduit.Combinators as Conduit
-
 import qualified Data.Set as Set
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
@@ -396,7 +394,7 @@ submissionHelper tid ssh csh shn mcid = do
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
             (Just files, _) -> -- new files
-              runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
+              runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
             (Nothing, Nothing) -- new submission, no file upload requested
               -> do
                 sid <- insert Submission
@@ -482,58 +480,53 @@ submissionHelper tid ssh csh shn mcid = do
   -- Maybe construct a table to display uploaded archive files
   let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
       colonnadeFiles cid = mconcat $ catMaybes
-        [ Just . sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
+        [ Just . sortable (Just "path") (i18nCell MsgFileTitle) $ \(mOrig, mCorr) -> let
-              Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
+              Just fileTitle' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
-              origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig
+              origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
-              corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
+              corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
               Just isFile = origIsFile <|> corrIsFile
             in if
               | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
                                                       [whamlet|#{fileTitle'}|]
               | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
-        , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
+        , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of
             Nothing -> cell mempty
-            Just (_, Entity _ File{..})
+            Just (Entity _ SubmissionFile{..})
-              | isJust fileContent ->
+              | isJust submissionFileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected submissionFileTitle)
-                  anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
+                                                 [whamlet|_{MsgFileCorrected}|]
-                             [whamlet|_{MsgFileCorrected}|]
               | otherwise -> i18nCell MsgCorrected
-        , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
+        , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let
-              origTime = fileModified . entityVal . snd <$> mOrig
+              origTime = submissionFileModified . entityVal <$> mOrig
-              corrTime = fileModified . entityVal . snd <$> mCorr
+              corrTime = submissionFileModified . entityVal <$> mCorr
               Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
             in dateTimeCell fileTime
         ]
-      coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
-      coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
       submissionFiles :: _ -> _ -> E.SqlQuery _
-      submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
+      submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
-        E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile
+        E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
-        E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle
          E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
          E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId
          E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
-        E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile
 
         E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
              E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True)  E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
              E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False)  E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion))
              E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
 
-        return ((sf1, f1), (sf2, f2))
+        return (sf1, sf2)
       smid2ArchiveTable (smid,cid) = DBTable
         { dbtSQLQuery = submissionFiles smid
-        , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
+        , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
         , dbtColonnade = colonnadeFiles cid
         , dbtProj = return . dbrOutput
         , dbtStyle = def
         , dbtIdent = "files" :: Text
         , dbtSorting = Map.fromList
           [ ( "path"
-            , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
+            , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> E.coalesce [sf1 E.?. SubmissionFileTitle, sf2 E.?. SubmissionFileTitle]
             )
           , ( "time"
-            , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
+            , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "GREATEST" ([sf1 E.?. SubmissionFileModified, sf2 E.?. SubmissionFileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
             )
           ]
         , dbtFilter = mempty
@@ -545,13 +538,11 @@ submissionHelper tid ssh csh shn mcid = do
   mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
 
-  filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \((f1 `E.InnerJoin` sFile1) `E.LeftOuterJoin` (f2 `E.InnerJoin` sFile2)) -> do
+  filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do
-    E.on $ f2 E.?. FileId E.==. sFile2 E.?. SubmissionFileFile
+    E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle
-    E.on $ E.just (f1 E.^. FileTitle) E.==. f2 E.?. FileTitle
      E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission
-     -- E.&&. f1 E.^. FileContent E.!=. E.joinV (f2 E.?. FileContent)
+     E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent)
      E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate)
-    E.on $ f1 E.^. FileId E.==. sFile1 E.^. SubmissionFileFile
     E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
     E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId)
 

src/Handler/Submission/Upload.hs

@@ -54,7 +54,6 @@ postCorrectionsUploadR = do
     uid <- requireAuthId
     mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $
          transPipe (lift . lift) files
-      .| C.mapM (either get404 return)
       .| extractRatingsMsg
       .| C.map setDone
       .| sinkMultiSubmission uid True

src/Handler/Users.hs

@@ -430,9 +430,7 @@ deleteUser duid = do
     singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
     deleteCascade duid
     forM_ singleSubmissions $ \(E.Value submissionId) -> do
-      deleteFileIds  <- map E.unValue <$> getSubmissionFiles submissionId
       deleteCascade submissionId
-      deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
 
     deletedSubmissionGroups <- deleteSingleSubmissionGroups
     return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
@@ -447,13 +445,6 @@ deleteUser duid = do
              E.&&. whereBuddies numBuddies
         return $ submission E.^. SubmissionId
 
-    getSubmissionFiles :: SubmissionId ->  DB [E.Value (Key File)]
-    getSubmissionFiles subId = E.select $ E.from $ \file -> do
-      E.where_ $ E.exists $ E.from $ \submissionFile ->
-          E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
-              E.&&.  submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
-      return $ file E.^. FileId
-
     deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
       E.where_ $ E.exists $ E.from $ \subGroupUser ->
           E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId

src/Handler/Utils.hs

@@ -9,6 +9,7 @@ import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Conduit.List as Conduit
+import qualified Data.Conduit.Combinators as C
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -25,6 +26,7 @@ import Handler.Utils.Widgets    as Handler.Utils
 import Handler.Utils.Database   as Handler.Utils
 import Handler.Utils.Occurrences as Handler.Utils
 import Handler.Utils.Memcached  as Handler.Utils
+import Handler.Utils.Files      as Handler.Utils
   
 import Handler.Utils.Term as Handler.Utils
 
@@ -36,44 +38,47 @@ sendThisFile :: File -> Handler TypedContent
 sendThisFile File{..}
   | Just fileContent' <- fileContent = do
       setContentDisposition' . Just $ takeFileName fileTitle
-      return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+      return $ TypedContent (simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
   | otherwise = sendResponseStatus noContent204 ()
 
 -- | Serve a single file, identified through a given DB query
-serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
+serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
 serveOneFile source = do
   results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
   case results of
-    [file] -> sendThisFile file
+    [file] -> sendThisFile =<< runDB (sourceFile' file)
     []     -> notFound
-    other  -> do
+    _other -> do
-      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
+      $logErrorS "SFileR" "Multiple matching files found."
       error "Multiple matching files found."
 
 -- | Serve one file directly or a zip-archive of files, identified through a given DB query
 --
 -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
-serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
+serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
-serveSomeFiles archiveName source = do
+serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
+
+serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent 
+serveSomeFiles' archiveName source = do
   results <- runDB . runConduit $ source .| peekN 2
 
   $logDebugS "serveSomeFiles" . tshow $ length results
 
   case results of
     []         -> notFound
-    [file]     -> sendThisFile file
+    [file]     -> sendThisFile =<< either (runDB . sourceFile') return file
     _moreFiles -> do
       setContentDisposition' $ Just archiveName
       respondSourceDB typeZip $ do
         let zipComment = T.encodeUtf8 $ pack archiveName
-        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+        source .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
 
 -- | Serve any number of files as a zip-archive of files, identified through a given DB query
 --
 -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
-serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
+serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
 serveZipArchive archiveName source = do
-  results <- runDB . runConduit $ source .| peekN 2
+  results <- runDB . runConduit $ source .| peekN 1
 
   $logDebugS "serveZipArchive" . tshow $ length results
 
@@ -83,7 +88,7 @@ serveZipArchive archiveName source = do
       setContentDisposition' $ Just archiveName
       respondSourceDB typeZip $ do
         let zipComment = T.encodeUtf8 $ pack archiveName
-        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+        source .| sourceFiles' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
 
 
 -- | Prefix a message with a short course id,

src/Handler/Utils/Allocation.hs

@@ -278,6 +278,7 @@ storeAllocationResult :: AllocationId
                       -> (AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)
                       -> DB ()
 storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
-  insert_ . AllocationMatching allocId allocFp now <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
+  FileReference{..} <- sinkFile $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
+  insert_ . AllocationMatching allocId allocFp now $ fromMaybe (error "allocation result stored without fileReferenceContent") fileReferenceContent
 
   doAllocation allocId now allocMatchings

src/Handler/Utils/Csv.hs

@@ -215,7 +215,7 @@ fileSourceCsv :: ( FromNamedRecord csv
                  , MonadHandler m
                  , HandlerSite m ~ UniWorX
                  )
-              => ConduitT (Either FileId File) csv m ()
+              => ConduitT FileReference csv m ()
 fileSourceCsv = uploadContents .| decodeCsv
 
 fileSourceCsvPositional :: ( MonadHandler m
@@ -224,7 +224,7 @@ fileSourceCsvPositional :: ( MonadHandler m
                            , FromRecord csv
                            )
                         => HasHeader
-                        -> ConduitT (Either FileId File) csv m ()
+                        -> ConduitT FileReference csv m ()
 fileSourceCsvPositional hdr = uploadContents .| decodeCsvPositional hdr
 
 

src/Handler/Utils/Files.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Files
+  ( sourceFile, sourceFile'
+  , sourceFiles, sourceFiles'
+  , SourceFilesException(..)
+  ) where
+
+import Import
+
+import qualified Data.Conduit.Combinators as C
+
+  
+data SourceFilesException
+  = SourceFilesMismatchedHashes
+  | SourceFilesContentUnavailable
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+
+sourceFiles :: ConduitT FileReference File (YesodDB UniWorX) ()
+sourceFiles = C.mapM sourceFile
+
+sourceFile :: FileReference -> DB File
+sourceFile FileReference{..} = do
+  mFileContent <- traverse get $ FileContentKey <$> fileReferenceContent
+  fileContent <- if
+    | is (_Just . _Nothing) mFileContent
+      -> throwM SourceFilesContentUnavailable
+    | fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
+      -> throwM SourceFilesMismatchedHashes
+    | Just fileContent' <- fileContentContent <$> join mFileContent
+      -> return $ Just fileContent'
+    | otherwise
+      -> return Nothing
+
+  return File
+    { fileTitle = fileReferenceTitle
+    , fileContent
+    , fileModified = fileReferenceModified
+    }
+
+sourceFiles' :: forall file. HasFileReference file => ConduitT file File (YesodDB UniWorX) ()
+sourceFiles' = C.mapM sourceFile'
+  
+sourceFile' :: forall file. HasFileReference file => file -> DB File
+sourceFile' = sourceFile . view (_FileReference . _1)

src/Handler/Utils/Form.hs

@@ -7,6 +7,7 @@ module Handler.Utils.Form
   ) where
 
 import Utils.Form
+import Utils.Files
 
 import Handler.Utils.Form.Types
 
@@ -18,6 +19,8 @@ import Handler.Utils.Widgets
 
 import Handler.Utils.I18n
 
+import Handler.Utils.Files
+
 import Import
 import Data.Char (chr, ord)
 import qualified Data.Char as Char
@@ -31,7 +34,7 @@ import Yesod.Form.Bootstrap3
 
 import Handler.Utils.Zip
 import qualified Data.Conduit.Combinators as C
-import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM)
+import qualified Data.Conduit.List as C (mapMaybe)
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
@@ -61,8 +64,6 @@ 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 ) --
@@ -831,11 +832,10 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
 
-type FileUploads = ConduitT () (Either FileId File) Handler ()
+type FileUploads = ConduitT () FileReference Handler ()
 
-uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m ()
+uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m ()
-uploadContents = C.mapMaybeM $ either dbContents (return . fileContent)
+uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybe fileContent
-  where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get
 
 data FileFieldUserOption a = FileFieldUserOption
   { fieldOptionForce :: Bool
@@ -847,9 +847,9 @@ data FileField = FileField
   , fieldUnpackZips :: FileFieldUserOption Bool
   , fieldMultiple :: Bool
   , fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
-  , fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool)
+  , fieldAdditionalFiles :: Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)
-  , fieldMaxFileSize :: Maybe Natural -- ^ Applied to each file separately
+  , fieldMaxFileSize :: Maybe Natural
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  } deriving (Generic, Typeable)
 
 genericFileField :: forall m.
                     ( MonadHandler m
@@ -860,6 +860,8 @@ genericFileField mkOpts = Field{..}
   where
     permittedExtension :: FileField -> FileName -> Bool
     permittedExtension FileField{..} fTitle
+      | unpack fTitle `Map.member` fieldAdditionalFiles
+      = True
       | Just exts <- fieldRestrictExtensions
       = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
       | otherwise
@@ -880,38 +882,37 @@ genericFileField mkOpts = Field{..}
       $logDebugS "genericFileField.getIdent" $ tshow ident
       return ident
 
-    getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool))
+    getPermittedFiles :: Maybe Text -> FileField -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool))
     getPermittedFiles mIdent opts@FileField{..} = do
-      sessionFiles <- fmap fold . for mIdent $ \fieldIdent' ->
+      sessionFiles <- for mIdent $ \fieldIdent' ->
-        fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles
+        foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles
-      sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do
+      sessionFiles' <- flip foldMapM sessionFiles $ \sFiles -> flip foldMapM (Map.toList sFiles) $ \(fTitle, (sfId, fModified)) -> maybeT (return Map.empty) $ do
         SessionFile{..} <- MaybeT $ get sfId
-        when (is _Just fieldRestrictExtensions) $ do
+        guard $ is _Nothing sessionFileContent || permittedExtension opts (pack fTitle)
-          (fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do
+        return $ Map.singleton fTitle (sessionFileContent, fModified, FileFieldUserOption False True)
-            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'
+      return $ mconcat
+        [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) fieldAdditionalFiles
+        , sessionFiles'
+        , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) fieldAdditionalFiles
+        ]
 
-    handleUpload :: FileField -> Maybe Text -> File -> DB (Maybe FileId)
+    handleUpload :: FileField -> Maybe Text -> ConduitT File FileReference (YesodDB UniWorX) ()
-    handleUpload FileField{fieldMaxFileSize} mIdent file
+    handleUpload FileField{fieldMaxFileSize} mIdent
-      | maybe (const False) (<) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) (fileContent file)
+      =    C.filter (\File{..} -> maybe (const True) (<) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
-      = return Nothing -- Don't save files that are too large
+        .| sinkFiles
-      | otherwise = do
+        .| maybe (C.map id) mkSessionFile mIdent
-          for mIdent $ \ident -> do
+      where
-            now <- liftIO getCurrentTime
+        mkSessionFile ident = C.mapM $ \fRef@FileReference{..} -> fRef <$ do
-            oldSFIds <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \sessionFile -> do
+          now <- liftIO getCurrentTime
-              E.where_ $ E.subSelectForeign sessionFile SessionFileFile (E.^. FileTitle) E.==. E.val (fileTitle file)
+          sfId <- insert $ SessionFile fileReferenceContent now
-                   E.&&. sessionFile E.^. SessionFileTouched E.<=. E.val now
+          modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
-              return $ sessionFile E.^. SessionFileId
+            Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
-            fId <- insert file
+
-            sfId <- insert $ SessionFile fId now
+  
-            modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+    _FileTitle :: Prism' Text FilePath
-              Just . MergeHashMap $ HashMap.insert ident (Set.insert sfId . maybe Set.empty (`Set.difference` oldSFIds) $ HashMap.lookup ident old) old
+    _FileTitle = prism' (("f." <>) . pack) $ fmap unpack . Text.stripPrefix "f."
-            return fId
 
     fieldEnctype = Multipart
     fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
@@ -921,10 +922,6 @@ genericFileField mkOpts = Field{..}
       mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
         fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v
 
-      let
-        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
-        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
-
       let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files
 
       let
@@ -933,7 +930,7 @@ genericFileField mkOpts = Field{..}
           | otherwise = unpackZips `elem` vals
         handleFile :: FileInfo -> ConduitT () File Handler ()
         handleFile
-          | doUnpack  = sourceFiles
+          | doUnpack  = receiveFiles
           | otherwise = yieldM . acceptFile
         invalidUploadExtension fName
           = not (permittedExtension opts fName)
@@ -942,36 +939,42 @@ genericFileField mkOpts = Field{..}
       whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do
         fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE
         when (fLength > maxSize) $ do
-          liftHandler . runDB . runConduit $
+          when (is _Just mIdent) $ 
-               mapM_ (transPipe lift . handleFile) files
+            liftHandler . runDB . runConduit $
-            .| C.mapM_ (void . handleUpload opts mIdent)
+                mapM_ (transPipe lift . handleFile) files
+             .| handleUpload opts mIdent
+             .| C.sinkNull
           throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo
 
       if | invExt : _ <- filter invalidUploadExtension uploadedFilenames
            -> do
-             liftHandler . runDB . runConduit $
+             when (is _Just mIdent) $ 
-                  mapM_ (transPipe lift . handleFile) files
+               liftHandler . runDB . runConduit $
-               .| C.mapM_ (void . handleUpload opts mIdent)
+                   mapM_ (transPipe lift . handleFile) files
+                .| handleUpload opts mIdent
+                .| C.sinkNull
              throwE . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt
          | otherwise
            -> do
              let fSrc = do
                    permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts
-                   yieldMany [ Left fId
+                   yieldMany [ FileReference{..}
-                             | (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles
+                             | ( fileReferenceTitle
+                               , (fileReferenceContent, fileReferenceModified, FileFieldUserOption{..})
+                               ) <- Map.toList permittedFiles
                              , fieldOptionForce, fieldOptionDefault
                              ]
                    yieldMany vals
-                     .| C.mapMaybe fromPathPiece
+                     .| C.mapMaybe (preview _FileTitle)
-                     .| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc)
+                     .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
-                     .| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles)
+                     .| C.filter (\(fTitle, _) ->
-                     .| C.filter (\(_, enc) -> fieldMultiple
+                                     fieldMultiple
-                                            || (    (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals)
+                                  || (    (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals)
-                                                 && null files
+                                       && null files
-                                               )
+                                     )
                                  )
-                     .| C.map (\(fId, _) -> Left fId)
+                     .| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..})
-                   mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right
+                   mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent)
              (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2
              $logDebugS "genericFileField.fieldParse" $ tshow nFiles
              if
@@ -980,7 +983,8 @@ genericFileField mkOpts = Field{..}
                | not fieldMultiple -> do
                    liftHandler . runDB . runConduit $
                         mapM_ (transPipe lift . handleFile) files
-                     .| C.mapM_ (void . handleUpload opts mIdent)
+                     .| handleUpload opts mIdent
+                     .| sinkNull
                    throwE $ SomeMessage MsgOnlyUploadOneFile
                | otherwise -> return $ Just fSrc'
              
@@ -990,39 +994,33 @@ genericFileField mkOpts = Field{..}
       mIdent <- getIdent opts
       identSecret <- for mIdent $ encodedSecretBox SecretBoxShort
 
-      fileInfos <- liftHandler . runDB $ do
+      fileInfos <- liftHandler $ do
-        (uploads, references) <- runWriterT . for val $ \src -> do
+        references <- for val $ fmap (Map.fromList . map (\FileReference{..} -> (fileReferenceTitle, (fileReferenceContent, fileReferenceModified)))) . sourceToList
-          fmap Set.fromList . sourceToList
-            $ transPipe (lift . lift) src
-           .| C.mapMaybeM (either (\fId -> Nothing <$ tell (Set.singleton fId)) $ lift . handleUpload opts mIdent)
 
-        permittedFiles <- getPermittedFiles mIdent opts
+        permittedFiles <- runDB $ getPermittedFiles mIdent opts
 
         let
-          sentVals :: Either Text (Set FileId)
+          sentVals :: Either Text (Set FilePath)
-          sentVals = uploads <&> Set.union (references `Set.intersection` Map.keysSet permittedFiles)
+          sentVals = references <&> (`Set.intersection` Map.keysSet permittedFiles) . Map.keysSet
 
         let
-          toFUI (E.Value fuiId', E.Value fuiTitle) = do
+          toFUI fuiTitle
-            fuiId <- encrypt fuiId'
+            = let fuiHtmlId = [st|#{fieldId}--#{fuiTitle}|]
-            let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|]
+                  fuiChecked
-                fuiChecked
+                    | Right sentVals' <- sentVals
-                  | Right sentVals' <- sentVals
+                    = fuiTitle `Set.member` sentVals'
-                  = fuiId' `Set.member` sentVals'
+                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle fieldAdditionalFiles
-                  | Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles
+                    = fieldOptionDefault
-                  = fieldOptionDefault
+                    | otherwise = False
-                  | otherwise = False
+                  fuiSession = fuiTitle `Map.notMember` fieldAdditionalFiles
-                fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles
+                  fuiForced
-                fuiForced
+                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles
-                  | Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles
+                    = fieldOptionForce
-                  = fieldOptionForce
+                    | otherwise
-                  | otherwise
+                    = False
-                  = False
+               in FileUploadInfo{..}
-            return FileUploadInfo{..}
+
-        fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do
+          fileInfos' = map toFUI . Set.toList $ fold sentVals <> Map.keysSet permittedFiles
-            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'
 
@@ -1063,7 +1061,7 @@ fileField = genericFileField $ return FileField
   }
   
 specificFileField :: UploadSpecificFile -> Field Handler FileUploads 
-specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . genericFileField $ return FileField
+specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField
   { fieldIdent = Nothing
   , fieldUnpackZips = FileFieldUserOption True False
   , fieldMultiple = False
@@ -1072,25 +1070,7 @@ specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . gen
   , fieldMaxFileSize = specificFileMaxSize
   }
   where
-    fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile)
+    fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName)
-      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
@@ -1126,9 +1106,9 @@ fileUploadForm isReq mkFs = \case
 
 multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField`
                 -> Field Handler FileUploads 
-multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
+multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.foldMap Set.singleton
 
-multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
+multiFileField :: Handler (Set FileReference) -- ^ Set of files that may be submitted by id-reference
                -> Field Handler FileUploads 
 multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
   where mkField permitted = FileField
@@ -1136,7 +1116,10 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
           , fieldUnpackZips = FileFieldUserOption False False
           , fieldMultiple = True
           , fieldRestrictExtensions = Nothing
-          , fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted
+          , fieldAdditionalFiles = Map.fromList
+            [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
+            | FileReference{..} <- Set.toList permitted
+            ]
           , fieldMaxFileSize = Nothing
           }
 

src/Handler/Utils/Form/Types.hs

@@ -3,8 +3,7 @@ module Handler.Utils.Form.Types where
 import Import
 
 data FileUploadInfo = FileUploadInfo
-  { fuiId :: CryptoUUIDFile
+  { fuiTitle :: FilePath
-  , fuiTitle :: FilePath
   , fuiHtmlId :: Text
   , fuiChecked, fuiSession, fuiForced :: Bool
   }

src/Handler/Utils/Mail.hs

@@ -8,6 +8,7 @@ module Handler.Utils.Mail
 
 import Import
 import Handler.Utils.Pandoc
+import Handler.Utils.Files
 
 import qualified Data.CaseInsensitive as CI
 
@@ -69,15 +70,15 @@ userMailT uid mAct = do
 
 addFileDB :: ( MonadMail m
              , HandlerSite m ~ UniWorX
-             ) => FileId -> m (Maybe MailObjectId)
+             ) => FileReference -> m (Maybe MailObjectId)
-addFileDB fId = runMaybeT $ do
+addFileDB fRef = runMaybeT $ do
-  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- lift . liftHandler . runDB $ sourceFile fRef
   lift . addPart $ do
     _partType .= decodeUtf8 (mimeLookup fileName)
     _partEncoding .= Base64
     _partDisposition .= AttachmentDisposition fileName
     _partContent .= PartContent (LBS.fromStrict fileContent)
-    setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId
+    setMailObjectIdPseudorandom (fileName, fileContent) :: StateT Part (HandlerFor UniWorX) MailObjectId
 
 
 class YesodMail site => ToMailHtml site a where

src/Handler/Utils/Rating.hs

@@ -11,6 +11,7 @@ module Handler.Utils.Rating
 
 import Import
 
+import Handler.Utils.Files
 import Handler.Utils.DateTime (getDateTimeFormatter)
 
 import qualified Data.Text as Text
@@ -102,23 +103,23 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
   return File{..}
   where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
 
-type SubmissionContent = Either File (SubmissionId, Rating')
+type SubmissionContent = Either FileReference (SubmissionId, Rating')
 
 extractRatings :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
-                  
+                  ) => ConduitT FileReference SubmissionContent m ()
-                  ) => ConduitT File SubmissionContent m ()
+extractRatings = Conduit.mapM $ \fRef@FileReference{..} -> liftHandler $ do
-extractRatings = Conduit.mapM $ \f@File{..} -> liftHandler $ do
+  msId <- isRatingFile fileReferenceTitle
-  msId <- isRatingFile fileTitle
+  if
-  case () of
+    | Just sId <- msId
-    _ | Just sId <- msId
+    , isJust fileReferenceContent -> do
-      , isJust fileContent -> do
+        f <- runDB $ sourceFile fRef
-          (rating, cID) <- handle (throwM . RatingFileException fileTitle) $ parseRating f
+        (rating, cID) <- handle (throwM . RatingFileException fileReferenceTitle) $ parseRating f
-          sId' <- traverse decrypt cID
+        sId' <- traverse decrypt cID
-          unless (maybe (const True) (==) sId' sId) $
+        unless (maybe (const True) (==) sId' sId) $
-            throwM $ RatingFileException fileTitle RatingSubmissionIDIncorrect
+          throwM $ RatingFileException fileReferenceTitle RatingSubmissionIDIncorrect
-          return $ Right (sId, rating)
+        return $ Right (sId, rating)
-      | otherwise -> return $ Left f
+    | otherwise -> return $ Left fRef
 
 isRatingFile :: forall m.
                 ( MonadHandler m

src/Handler/Utils/Submission.hs

@@ -39,6 +39,7 @@ import qualified Database.Esqueleto.Utils.TH as E
 
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
+import qualified Data.Conduit.Combinators as C
 
 import System.FilePath
 import System.FilePath.Glob
@@ -255,21 +256,21 @@ planSubmissions sid restriction = do
     maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
 
 
-submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) ()
+submissionFileSource :: SubmissionId -> ConduitT () File (YesodDB UniWorX) ()
-submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
+submissionFileSource subId = E.selectSource (E.from $ submissionFileQuery subId)
+                          .| C.map entityVal
+                          .| sourceFiles'
 
-submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
+submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile)
-                        -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
+                    -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile))
-submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+submissionFileQuery submissionID sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
-  E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
   E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-  E.where_ . E.not_ . E.exists . E.from $ \(sf' `E.InnerJoin` f') -> do
+  E.where_ . E.not_ . E.exists . E.from $ \sf' ->
-    E.on $ f' E.^. FileId E.==. sf' E.^. SubmissionFileFile
     E.where_ $ sf' E.^. SubmissionFileIsDeletion
          E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
-         E.&&. f' E.^. FileTitle E.==. f E.^. FileTitle
+         E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle
   E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
-  return (sf, f)
+  return sf
 
 data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
                                  | SubmissionDownloadSurnames
@@ -366,8 +367,8 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
             | otherwise              =                                                                 submissionDirectory
 
           fileEntitySource = do
-            submissionFileSource submissionID .| Conduit.map entityVal
+            yieldM $ ratingFile cID rating
-            yieldM (ratingFile cID rating)
+            submissionFileSource submissionID
 
           withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
 
@@ -400,13 +401,13 @@ instance Monoid SubmissionSinkState where
   mempty = memptydefault
   mappend = (<>)
 
-filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
+filterSubmission :: MonadLogger m => ConduitM FileReference FileReference m (Set FilePath)
 -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
 filterSubmission = do
   $logDebugS "filterSubmission" $ tshow submissionBlacklist
   execWriterLC . awaitForever $ \case
-    File{fileTitle}
+    FileReference{fileReferenceTitle}
-      | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
+      | any (`match'` fileReferenceTitle) submissionBlacklist -> tell $ Set.singleton fileReferenceTitle
     file -> yield file
   where
     match' = matchWith $ matchDefault
@@ -415,12 +416,12 @@ filterSubmission = do
 
 extractRatings :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
-                  ) => ConduitM File SubmissionContent m (Set FilePath)
+                  ) => ConduitM FileReference SubmissionContent m (Set FilePath)
 extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
 
 extractRatingsMsg :: ( MonadHandler m
                      , HandlerSite m ~ UniWorX
-                     ) => ConduitT File SubmissionContent m ()
+                     ) => ConduitT FileReference SubmissionContent m ()
 extractRatingsMsg = do
   ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
   let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
@@ -558,10 +559,10 @@ sinkSubmission userId mExists isUpdate = do
       , not isUpdate
       , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
       = Conduit.mapM $ \x -> if
-          | Left File{..} <- x
+          | Left FileReference{..} <- x
-          , none ((flip isExtensionOf `on` CI.foldCase) fileTitle) exts
+          , none ((flip isExtensionOf `on` CI.foldCase) fileReferenceTitle) exts
-          , isn't _Nothing fileContent -- File record is not a directory, we don't care about those
+          , isn't _Nothing fileReferenceContent -- File record is not a directory, we don't care about those
-            -> throwM $ InvalidFileTitleExtension fileTitle
+            -> throwM $ InvalidFileTitleExtension fileReferenceTitle
           | otherwise
             -> return x
       | otherwise = Conduit.map id
@@ -569,55 +570,57 @@ sinkSubmission userId mExists isUpdate = do
     sinkSubmission' :: SubmissionId
                     -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
-      Left file@(File{..}) -> do
+      Left file@(FileReference{..}) -> do
-        $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
+        $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
 
-        alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
+        alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
-        when alreadySeen . throwM $ DuplicateFileTitle fileTitle
+        when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle
-        tellSt $ mempty{ sinkFilenames = Set.singleton fileTitle  }
+        tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle  }
 
-        otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+        otherVersions <- lift . E.select . E.from $ \sf -> do
-          E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
           E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
           -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-          E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
+          E.where_ $ sf E.^. SubmissionFileTitle E.==. E.val fileReferenceTitle -- 'Zip.hs' normalises filenames already, so this should work
-          return (f, sf)
+          return sf
 
-        let collidingFiles = [ t | t@(_, Entity _ sf) <- otherVersions
+        let collidingFiles = [ t | t@(Entity _ sf) <- otherVersions
                                  , submissionFileIsUpdate sf == isUpdate
                                  ]
-            underlyingFiles = [ t | t@(_, Entity _ sf) <- otherVersions
+            underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
                                   , submissionFileIsUpdate sf == False
                                   ]
             anyChanges
-              | not (null collidingFiles)  = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ]
+              | not (null collidingFiles)  = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
               | otherwise                  = True
             matchesUnderlying
-              | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
+              | not (null underlyingFiles) = all (~~ file) [ view (_FileReference . _1) sf | Entity _ sf <- underlyingFiles ]
               | otherwise                  = False
-            undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
+            undoneDeletion = any submissionFileIsDeletion [ sf | Entity _ sf <- collidingFiles ]
 
         when anyChanges $ do
           touchSubmission
-          when (not $ null collidingFiles) $
+          forM_ collidingFiles $ \(Entity sfId' _) -> lift $ do
-            lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ]
+            delete sfId'
-          lift $ case () of
+            audit $ TransactionSubmissionFileDelete sfId' submissionId
-            _ | matchesUnderlying
+          lift $ if
-              , isUpdate
+            | matchesUnderlying
-                -> return ()
+            , isUpdate
-            _   -> do
+              -> return ()
-              fileId <- insert file
+            | otherwise -> do
-              subFileId <- insert $ SubmissionFile
+                subFileId <- insert $
-                { submissionFileSubmission = submissionId
+                  _FileReference # ( file
-                , submissionFileFile = fileId
+                                   , SubmissionFileResidual
-                , submissionFileIsUpdate = isUpdate
+                                     { submissionFileResidualSubmission = submissionId
-                , submissionFileIsDeletion = False
+                                     , submissionFileResidualIsUpdate = isUpdate
-                }
+                                     , submissionFileResidualIsDeletion = False
-              audit $ TransactionSubmissionFileEdit subFileId submissionId fileId
+                                     }
+                                   )
+                audit $ TransactionSubmissionFileEdit subFileId submissionId
         when undoneDeletion $ do
           touchSubmission
-          lift $ forM_ [ (sfId, submissionFileFile sf) | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] $ \(sfId, fId) -> audit $ TransactionSubmissionFileDelete sfId submissionId fId
+          forM_ (filter (submissionFileIsDeletion . entityVal) collidingFiles) $ \(Entity sfId' _) -> lift $ do
-          lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
+            delete sfId'
+            audit $ TransactionSubmissionFileDelete sfId' submissionId
 
       Right (submissionId', r) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
@@ -673,9 +676,10 @@ sinkSubmission userId mExists isUpdate = do
       where
         a /~ b = not $ a ~~ b
 
-        (~~) :: File -> File -> Bool
+        (~~) :: FileReference -> FileReference -> Bool
         (~~) a b
-          | isUpdate  = fileTitle a == fileTitle b && fileContent a == fileContent b
+          | isUpdate  = fileReferenceTitle   a == fileReferenceTitle   b
+                     && fileReferenceContent a == fileReferenceContent b
           | otherwise = a == b
         -- The Eq Instance for File compares modification time exactly even
         -- though zip archives have very limited accuracy and range regarding
@@ -710,40 +714,46 @@ sinkSubmission userId mExists isUpdate = do
 
         finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
         finalize SubmissionSinkState{..} = do
-          missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+          missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
-            E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
             E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
             when (not isUpdate) $
-              E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+              E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
-            E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
+            E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
             E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
 
-            return (f, sf)
+            return sf
 
           case isUpdate of
-            False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
+            False -> do
-            True  -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
+              shadowed <- selectKeysList
-              shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+                [ SubmissionFileSubmission ==. submissionId
-                E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+                , SubmissionFileIsUpdate ==. False
-                E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
+                , SubmissionFileId <-. map entityKey missingFiles
-                E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
+                ] []
-                E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
+              forM_ shadowed $ \sfId' -> do
-                return $ f E.^. FileId
+                delete sfId'
+                audit $ TransactionSubmissionFileDelete sfId' submissionId
+            True  -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
+              shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
 
-              case (shadowing, submissionFileIsUpdate) of
+              if
-                ([], _) -> deleteCascade fileId
+                | not shadowing -> do
-                (E.Value f:_, False) -> do
+                    delete sfId
-                  sfId' <- insert $ SubmissionFile
+                    audit $ TransactionSubmissionFileDelete sfId submissionId
-                    { submissionFileSubmission = submissionId
+                | submissionFileIsUpdate -> do
-                    , submissionFileFile = f
+                    update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
-                    , submissionFileIsUpdate = True
+                    audit $ TransactionSubmissionFileEdit sfId submissionId
-                    , submissionFileIsDeletion = True
+                | otherwise -> do
-                    }
+                    now <- liftIO getCurrentTime
-                  audit $ TransactionSubmissionFileEdit sfId' submissionId f
+                    sfId' <- insert $ SubmissionFile
-                (E.Value f:_, True) -> do
+                      { submissionFileSubmission = submissionId
-                  update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
+                      , submissionFileTitle
-                  deleteCascade fileId
+                      , submissionFileModified = now
-                  audit $ TransactionSubmissionFileDelete sfId submissionId f
+                      , submissionFileContent = Nothing
+                      , submissionFileIsUpdate = True
+                      , submissionFileIsDeletion = True
+                      }
+                    audit $ TransactionSubmissionFileEdit sfId' submissionId
 
           if
             | isUpdate
@@ -805,7 +815,7 @@ sinkMultiSubmission userId isUpdate = do
       cID <- encrypt sId
       $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
       lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ])
-    (Left f@File{..})  -> do
+    (Left f@FileReference{..})  -> do
       let
         acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
         acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
@@ -817,17 +827,17 @@ sinkMultiSubmission userId isUpdate = do
                   sId <- decrypt (cID :: CryptoFileNameSubmission)
                   Just sId <$ get404 sId
               | otherwise = return Nothing
-          Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
+          Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
           return (msId, fp)
-      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
+      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
       case msId of
         Nothing -> do
-          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
+          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
         Just sId -> do
-          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
+          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
           cID <- encrypt sId
-          lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
+          lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
-            feed sId $ Left f{ fileTitle = fileTitle' }
+            feed sId $ Left f{ fileReferenceTitle = fileTitle' }
   when (not $ null ignoredFiles) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

src/Handler/Utils/Table/Columns.hs

@@ -417,11 +417,11 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms
   where conDTCell = ifCell condition dateTimeCell $ const mempty
 
 
-sortFilePath :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
+sortFilePath :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
-sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
+sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField))
 
-sortFileModification :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
+sortFileModification :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
-sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
+sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField))
 
 defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
 defaultSortingByFileTitle = defaultSorting [SortAscBy "path"]

src/Handler/Utils/Zip.hs

@@ -8,7 +8,7 @@ module Handler.Utils.Zip
   , produceZip
   , consumeZip
   , modifyFileTitle
-  , sourceFiles, acceptFile
+  , receiveFiles, acceptFile
   ) where
 
 import Import
@@ -123,8 +123,8 @@ modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m ()
 modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
 
 -- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
-sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
+receiveFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
-sourceFiles fInfo
+receiveFiles fInfo
     | ((==) `on` simpleContentType) mimeType typeZip = do
         $logInfoS "sourceFiles" "Unpacking ZIP"
         fileSource fInfo .| void consumeZip

src/Import.hs

@@ -7,5 +7,6 @@ import Import.NoFoundation   as Import
 
 import Utils.SystemMessage   as Import
 import Utils.Metrics         as Import
+import Utils.Files           as Import
 
 import Jobs.Types            as Import (JobHandler(..))

src/Import/NoModel.hs

@@ -19,6 +19,7 @@ import ClassyPrelude.Yesod    as Import
          , try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
          , htmlField, fileField
          , mreq, areq, wreq -- Use `mreqMsg`, `areqMsg`, `wreqMsg`
+         , sinkFile, sourceFile
          )
 
 import UnliftIO.Async.Utils as Import
@@ -161,7 +162,7 @@ import Web.Cookie.Instances as Import ()
 import Network.HTTP.Types.Method.Instances as Import ()
 import Crypto.Random.Instances as Import ()
 
-import Crypto.Hash as Import (Digest, SHA3_256)
+import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
 
 import Control.Lens as Import

src/Jobs/Handler/PruneFiles.hs

@@ -21,18 +21,18 @@ dispatchJobPruneSessionFiles = JobHandlerAtomic  . hoist lift $ do
 
 dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX
 dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do
-  n <- E.deleteCount . E.from $ \file ->
+  n <- E.deleteCount . E.from $ \fileContent ->
-    E.where_ . E.not_ . E.any E.exists $ references file
+    E.where_ . E.not_ . E.any E.exists $ references fileContent
   $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
   where
-    references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()]
+    references :: E.SqlExpr (Entity FileContent) -> [E.SqlQuery ()]
-    references ((E.^. FileId) -> fId) =
+    references (E.just . (E.^. FileContentHash) -> fHash) =
-      [ E.from $ \appFile   -> E.where_ $ appFile   E.^. CourseApplicationFileFile    E.==. fId
+      [ E.from $ \appFile   -> E.where_ $ appFile   E.^. CourseApplicationFileContent    E.==. fHash
-      , E.from $ \matFile   -> E.where_ $ matFile   E.^. MaterialFileFile             E.==. fId
+      , E.from $ \matFile   -> E.where_ $ matFile   E.^. MaterialFileContent             E.==. fHash
-      , E.from $ \newsFile  -> E.where_ $ newsFile  E.^. CourseNewsFileFile           E.==. fId
+      , E.from $ \newsFile  -> E.where_ $ newsFile  E.^. CourseNewsFileContent           E.==. fHash
-      , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile                E.==. fId
+      , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent                E.==. fHash
-      , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileFile E.==. fId
+      , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileContent E.==. fHash
-      , E.from $ \matching  -> E.where_ $ matching  E.^. AllocationMatchingLog        E.==. fId
+      , E.from $ \matching  -> E.where_ $ E.just (matching  E.^. AllocationMatchingLog)  E.==. fHash
-      , E.from $ \subFile   -> E.where_ $ subFile   E.^. SubmissionFileFile           E.==. fId
+      , E.from $ \subFile   -> E.where_ $ subFile   E.^. SubmissionFileContent           E.==. fHash
-      , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileFile              E.==. fId
+      , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileContent              E.==. fHash
       ]

src/Model.hs

@@ -38,8 +38,6 @@ 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
 
@@ -54,3 +52,185 @@ instance ToMarkup (Key Term) where
 
 instance ToMessage (Key Term) where
   toMessage = termToText . unTermKey
+
+
+instance HasFileReference CourseApplicationFile where
+  newtype FileReferenceResidual CourseApplicationFile
+    = CourseApplicationFileResidual { courseApplicationFileResidualApplication :: CourseApplicationId }
+
+  _FileReference
+    = iso (\CourseApplicationFile{..} -> ( FileReference
+                                           { fileReferenceTitle    = courseApplicationFileTitle
+                                           , fileReferenceContent  = courseApplicationFileContent
+                                           , fileReferenceModified = courseApplicationFileModified
+                                           }
+                                         , CourseApplicationFileResidual courseApplicationFileApplication
+                                         )
+          )
+          (\( FileReference{..}
+            , CourseApplicationFileResidual courseApplicationFileApplication
+            ) -> CourseApplicationFile
+                 { courseApplicationFileApplication
+                 , courseApplicationFileTitle    = fileReferenceTitle
+                 , courseApplicationFileContent  = fileReferenceContent
+                 , courseApplicationFileModified = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = CourseApplicationFileTitle
+  fileReferenceContentField = CourseApplicationFileContent
+  fileReferenceModifiedField = CourseApplicationFileModified
+
+instance HasFileReference CourseAppInstructionFile where
+  newtype FileReferenceResidual CourseAppInstructionFile
+    = CourseAppInstructionFileResidual { courseAppInstructionFileResidualCourse :: CourseId }
+
+  _FileReference
+    = iso (\CourseAppInstructionFile{..} -> ( FileReference
+                                              { fileReferenceTitle    = courseAppInstructionFileTitle
+                                              , fileReferenceContent  = courseAppInstructionFileContent
+                                              , fileReferenceModified = courseAppInstructionFileModified
+                                              }
+                                            , CourseAppInstructionFileResidual courseAppInstructionFileCourse
+                                            )
+          )
+          (\( FileReference{..}
+            , CourseAppInstructionFileResidual courseAppInstructionFileCourse
+            ) -> CourseAppInstructionFile
+                 { courseAppInstructionFileCourse
+                 , courseAppInstructionFileTitle    = fileReferenceTitle
+                 , courseAppInstructionFileContent  = fileReferenceContent
+                 , courseAppInstructionFileModified = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = CourseAppInstructionFileTitle
+  fileReferenceContentField = CourseAppInstructionFileContent
+  fileReferenceModifiedField = CourseAppInstructionFileModified
+
+instance HasFileReference SheetFile where
+  data FileReferenceResidual SheetFile = SheetFileResidual
+    { sheetFileResidualSheet :: SheetId
+    , sheetFileResidualType :: SheetFileType
+    }
+
+  _FileReference
+    = iso (\SheetFile{..} -> ( FileReference
+                               { fileReferenceTitle    = sheetFileTitle
+                               , fileReferenceContent  = sheetFileContent
+                               , fileReferenceModified = sheetFileModified
+                               }
+                             , SheetFileResidual
+                               { sheetFileResidualSheet = sheetFileSheet
+                               , sheetFileResidualType = sheetFileType
+                               }
+                             )
+          )
+          (\( FileReference{..}
+            , SheetFileResidual{..}
+            ) -> SheetFile
+                 { sheetFileSheet = sheetFileResidualSheet
+                 , sheetFileType       = sheetFileResidualType
+                 , sheetFileTitle      = fileReferenceTitle
+                 , sheetFileContent    = fileReferenceContent
+                 , sheetFileModified   = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = SheetFileTitle
+  fileReferenceContentField = SheetFileContent
+  fileReferenceModifiedField = SheetFileModified
+ 
+instance HasFileReference SubmissionFile where
+  data FileReferenceResidual SubmissionFile = SubmissionFileResidual
+    { submissionFileResidualSubmission :: SubmissionId
+    , submissionFileResidualIsUpdate
+    , submissionFileResidualIsDeletion :: Bool
+    }
+
+  _FileReference
+    = iso (\SubmissionFile{..} -> ( FileReference
+                                    { fileReferenceTitle    = submissionFileTitle
+                                    , fileReferenceContent  = submissionFileContent
+                                    , fileReferenceModified = submissionFileModified
+                                    }
+                                  , SubmissionFileResidual
+                                    { submissionFileResidualSubmission = submissionFileSubmission
+                                    , submissionFileResidualIsUpdate   = submissionFileIsUpdate
+                                    , submissionFileResidualIsDeletion = submissionFileIsDeletion
+                                    }
+                                  )
+          )
+          (\( FileReference{..}
+            , SubmissionFileResidual{..}
+            ) -> SubmissionFile
+                 { submissionFileSubmission = submissionFileResidualSubmission
+                 , submissionFileIsUpdate   = submissionFileResidualIsUpdate
+                 , submissionFileIsDeletion = submissionFileResidualIsDeletion
+                 , submissionFileTitle      = fileReferenceTitle
+                 , submissionFileContent    = fileReferenceContent
+                 , submissionFileModified   = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = SubmissionFileTitle
+  fileReferenceContentField = SubmissionFileContent
+  fileReferenceModifiedField = SubmissionFileModified
+
+instance HasFileReference CourseNewsFile where
+  newtype FileReferenceResidual CourseNewsFile
+    = CourseNewsFileResidual { courseNewsFileResidualNews :: CourseNewsId }
+
+  _FileReference
+    = iso (\CourseNewsFile{..} -> ( FileReference
+                                    { fileReferenceTitle    = courseNewsFileTitle
+                                    , fileReferenceContent  = courseNewsFileContent
+                                    , fileReferenceModified = courseNewsFileModified
+                                    }
+                                  , CourseNewsFileResidual courseNewsFileNews
+                                  )
+          )
+          (\( FileReference{..}
+            , CourseNewsFileResidual courseNewsFileNews
+            ) -> CourseNewsFile
+                 { courseNewsFileNews
+                 , courseNewsFileTitle    = fileReferenceTitle
+                 , courseNewsFileContent  = fileReferenceContent
+                 , courseNewsFileModified = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = CourseNewsFileTitle
+  fileReferenceContentField = CourseNewsFileContent
+  fileReferenceModifiedField = CourseNewsFileModified
+
+instance HasFileReference MaterialFile where
+  data FileReferenceResidual MaterialFile = MaterialFileResidual
+    { materialFileResidualMaterial :: MaterialId
+    }
+
+  _FileReference
+    = iso (\MaterialFile{..} -> ( FileReference
+                               { fileReferenceTitle    = materialFileTitle
+                               , fileReferenceContent  = materialFileContent
+                               , fileReferenceModified = materialFileModified
+                               }
+                             , MaterialFileResidual
+                               { materialFileResidualMaterial = materialFileMaterial
+                               }
+                             )
+          )
+          (\( FileReference{..}
+            , MaterialFileResidual{..}
+            ) -> MaterialFile
+                 { materialFileMaterial = materialFileResidualMaterial
+                 , materialFileTitle    = fileReferenceTitle
+                 , materialFileContent  = fileReferenceContent
+                 , materialFileModified = fileReferenceModified
+                 }
+          )
+
+  fileReferenceTitleField = MaterialFileTitle
+  fileReferenceContentField = MaterialFileContent
+  fileReferenceModifiedField = MaterialFileModified
+ 

src/Model/Migration.hs

@@ -426,7 +426,7 @@ customMigrations = Map.fromListWith (>>)
         |]
 
         let getFileEntries = rawQuery [st|SELECT "allocation_course_file"."id", "allocation_course"."course", "allocation_course_file"."file" FROM "allocation_course_file" INNER JOIN "allocation_course" ON "allocation_course"."id" = "allocation_course_file"."allocation_course"|] []
-            moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: FileId)] =
+            moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: Int64)] =
               [executeQQ|
                 INSERT INTO "course_app_instruction_file" ("course", "file") VALUES (#{cid}, #{fid});
                 DELETE FROM "allocation_course_file" WHERE "id" = #{acfId};
@@ -662,6 +662,191 @@ customMigrations = Map.fromListWith (>>)
     , whenM (tableExists "session_file") $
         tableDropEmpty "session_file"
     )
+  , ( AppliedMigrationKey [migrationVersion|37.0.0|] [version|38.0.0|]
+    , do
+        unlessM (tableExists "file_content") $
+          [executeQQ|
+            CREATE TABLE "file_content" ( PRIMARY KEY ("hash")
+                                        , "hash" BYTEA NOT NULL
+                                        , "content" BYTEA NOT NULL
+                                        );
+          |]
+
+        let
+          migrateFromFile :: forall fRef.
+                             ( HasFileReference fRef
+                             , PersistRecordBackend fRef SqlBackend
+                             )
+                          => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef))
+                          -> (Entity fRef -> ReaderT SqlBackend m ())
+                          -> [PersistValue]
+                          -> ReaderT SqlBackend m ()
+          migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do
+            let (fRefKey, residual) = toResidual rest
+            fileDat <- [sqlQQ|
+              SELECT "file".title, "file".modified FROM "file" WHERE "id" = #{fId};
+            |]
+            insertedContent <- [sqlQQ|
+              INSERT INTO "file_content" (SELECT digest("content", 'sha3-512') as "hash", "content" FROM "file" WHERE id = #{fId} AND NOT ("content" IS NULL)) ON CONFLICT("hash") DO UPDATE SET "hash" = EXCLUDED."hash" RETURNING "hash";
+            |]
+            forM_ fileDat $ \case
+              (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right (fileReferenceModified :: UTCTime)) -> do
+                let fileReferenceContent = listToMaybe $ mapMaybe (preview _Right . fromPersistValue . unSingle) insertedContent
+                    fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual)
+                    candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ]
+                      where (fName, ext) = splitExtension fileReferenceTitle' 
+                validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles
+                case validTitles of
+                  fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle
+                  _other -> error "Could not make validTitle"
+              _other -> return ()
+          migrateFromFile _ _ _ = return ()
+
+        whenM (tableExists "submission_file") $ do
+          [executeQQ|
+            ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file";
+            ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update");
+          |]
+          let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right sfId
+                         , fromPersistValue -> Right submissionFileResidualSubmission
+                         , fromPersistValue -> Right submissionFileResidualIsUpdate
+                         , fromPersistValue -> Right submissionFileResidualIsDeletion
+                         ]
+                         = (sfId, SubmissionFileResidual{..})
+              toResidual _ = error "Could not convert SubmissionFile to residual"
+          runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "submission_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "sheet_file") $ do
+          [executeQQ|
+            ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file";
+            ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title");
+          |]
+          let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right shfId
+                         , fromPersistValue -> Right sheetFileResidualSheet
+                         , fromPersistValue -> Right sheetFileResidualType
+                         ]
+                         = (shfId, SheetFileResidual{..})
+              toResidual _ = error "Could not convert SheetFile to residual"
+          runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "sheet_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "course_app_instruction_file") $ do
+          [executeQQ|
+            ALTER TABLE "course_app_instruction_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "course_app_instruction_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "course_app_instruction_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "course_app_instruction_file" DROP CONSTRAINT "unique_course_app_instruction_file";
+            ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course", "title");
+          |]
+          let getCourseAppInstructionFiles = [queryQQ|SELECT "file", "course_app_instruction_file"."id", "course" FROM "course_app_instruction_file" LEFT OUTER JOIN "file" ON "course_app_instruction_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right caifId
+                         , fromPersistValue -> Right courseAppInstructionFileResidualCourse
+                         ]
+                         = (caifId, CourseAppInstructionFileResidual{..})
+              toResidual _ = error "Could not convert CourseAppInstructionFile to residual"
+          runConduit $ getCourseAppInstructionFiles .| C.mapM_ (migrateFromFile @CourseAppInstructionFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "course_app_instruction_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "course_news_file") $ do
+          [executeQQ|
+            ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file";
+            ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title");
+          |]
+          let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right cnfId
+                         , fromPersistValue -> Right courseNewsFileResidualNews
+                         ]
+                         = (cnfId, CourseNewsFileResidual{..})
+              toResidual _ = error "Could not convert CourseNewsFile to residual"
+          runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "course_news_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "material_file") $ do
+          [executeQQ|
+            ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file";
+            ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title");
+          |]
+          let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right shfId
+                         , fromPersistValue -> Right materialFileResidualMaterial
+                         ]
+                         = (shfId, MaterialFileResidual{..})
+              toResidual _ = error "Could not convert MaterialFile to residual"
+          runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "material_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "course_application_file") $ do
+          [executeQQ|
+            ALTER TABLE "course_application_file" ADD COLUMN "title" VARCHAR;
+            ALTER TABLE "course_application_file" ADD COLUMN "content" BYTEA NULL;
+            ALTER TABLE "course_application_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
+            ALTER TABLE "course_application_file" DROP CONSTRAINT "unique_application_file";
+            ALTER TABLE "course_application_file" ADD CONSTRAINT "unique_course_application_file" UNIQUE("application", "title");
+          |]
+          let getCourseApplicationFiles = [queryQQ|SELECT "file", "course_application_file"."id", "application" FROM "course_application_file" LEFT OUTER JOIN "file" ON "course_application_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
+              toResidual [ fromPersistValue -> Right cnfId
+                         , fromPersistValue -> Right courseApplicationFileResidualApplication
+                         ]
+                         = (cnfId, CourseApplicationFileResidual{..})
+              toResidual _ = error "Could not convert CourseApplicationFile to residual"
+          runConduit $ getCourseApplicationFiles .| C.mapM_ (migrateFromFile @CourseApplicationFile toResidual replaceEntity)
+          [executeQQ|
+            ALTER TABLE "course_application_file" DROP COLUMN "file";
+          |]
+
+        whenM (tableExists "allocation_matching") $ do
+          [executeQQ|
+            ALTER TABLE "allocation_matching" ADD COLUMN "log_ref" BYTEA;
+          |]
+          let getAllocationMatchingFiles = [queryQQ|SELECT "log", "allocation_matching"."id" FROM "allocation_matching";|]
+              moveMatchingFile [ fromPersistValue -> Right (fId :: Int64), fromPersistValue -> Right (amId :: AllocationMatchingId) ] = do
+                insertedContent <- [sqlQQ|
+                  INSERT INTO "file_content" (SELECT digest("content", 'sha3-512') as "hash", "content" FROM "file" WHERE id = #{fId} AND NOT ("content" IS NULL)) ON CONFLICT("hash") DO UPDATE SET "hash" = EXCLUDED."hash" RETURNING "hash";
+                |]
+                let refContent :: Maybe FileContentReference
+                    refContent = listToMaybe $ mapMaybe (preview _Right . fromPersistValue . unSingle) insertedContent
+                case refContent of
+                  Nothing -> error "AllocationMatching had no fileContent"
+                  Just h -> [executeQQ|UPDATE "allocation_matching" SET "log_ref" = #{h} WHERE "id" = #{amId};|]
+              moveMatchingFile _ = return ()
+          runConduit $ getAllocationMatchingFiles .| C.mapM_ moveMatchingFile
+          [executeQQ|
+            ALTER TABLE "allocation_matching" DROP COLUMN "log";
+            ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
+          |]
+
+        whenM (tableExists "session_file") $
+          [executeQQ|
+            TRUNCATE TABLE "session_file";
+            ALTER TABLE "session_file" DROP COLUMN "file";
+            ALTER TABLE "session_file" ADD COLUMN "content" BYTEA NULL;
+          |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -15,3 +15,4 @@ import Model.Types.Misc as Types
 import Model.Types.School as Types
 import Model.Types.Allocation as Types
 import Model.Types.Languages as Types
+import Model.Types.File as Types

src/Model/Types/Common.hs

@@ -55,4 +55,4 @@ type ClusterId               = UUID
 type TokenId                 = UUID
 type TermCandidateIncidence  = UUID
 
-type SessionFileReference    = Digest SHA3_256
+type FileContentReference    = Digest SHA3_512

src/Model/Types/File.hs

@@ -0,0 +1,37 @@
+module Model.Types.File
+  ( File(..), _fileTitle, _fileContent, _fileModified
+  , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
+  , HasFileReference(..)
+  ) where
+
+import Import.NoModel
+import Model.Types.Common (FileContentReference)
+
+import Utils.Lens.TH
+
+
+data File = File
+  { fileTitle    :: FilePath
+  , fileContent  :: Maybe ByteString
+  , fileModified :: UTCTime
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLenses_ ''File
+
+data FileReference = FileReference
+  { fileReferenceTitle    :: FilePath
+  , fileReferenceContent  :: Maybe FileContentReference
+  , fileReferenceModified :: UTCTime
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLenses_ ''FileReference
+
+
+class PersistEntity record => HasFileReference record where
+  data FileReferenceResidual record :: *
+
+  _FileReference :: Iso' record (FileReference, FileReferenceResidual record)
+
+  fileReferenceTitleField    :: EntityField record FilePath
+  fileReferenceContentField  :: EntityField record (Maybe FileContentReference)
+  fileReferenceModifiedField :: EntityField record UTCTime

src/Utils.hs

@@ -43,10 +43,10 @@ import qualified Data.List as List
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Vector as V
 
--- import qualified Data.Conduit.List as C
+import qualified Data.Conduit.List as C (mapMaybe)
 import qualified Data.Conduit.Combinators as C
 
-import Control.Lens
+import Control.Lens hiding (uncons)
 import Control.Lens as Utils (none)
 import Control.Lens.Extras (is)
 import Data.Set.Lens
@@ -434,6 +434,12 @@ nonEmpty' = maybe empty pure . nonEmpty
 nubOn :: Eq b => (a -> b) -> [a] -> [a]
 nubOn = List.nubBy . ((==) `on`)
 
+dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq
+dropWhileM p xs'
+  | Just (x, xs) <- uncons xs'
+  = bool (return xs') (dropWhileM p xs) =<< p x
+  | otherwise = return xs'
+
 ----------
 -- Sets --
 ----------
@@ -831,6 +837,9 @@ allMC f = C.mapM f .| andC
 yieldMMany :: forall mono m a. (Monad m, MonoFoldable mono) => m mono -> ConduitT a (Element mono) m ()
 yieldMMany = C.yieldMany <=< lift
 
+eitherC :: Monad m => ConduitT l o m () -> ConduitT r o m () -> ConduitT (Either l r) o m ()
+eitherC lC rC = void $ sequenceConduits [C.mapMaybe (preview _Left) .| lC, C.mapMaybe (preview _Right) .| rC]
+
 -----------------
 -- Alternative --
 -----------------

src/Utils/DB.hs

@@ -107,6 +107,13 @@ myReplaceUnique key datumNew = getJust key >>= replaceOriginal
         changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
         uniqueKeysOriginal = persistUniqueKeys original
 
+replaceEntity :: ( MonadIO m
+                 , PersistRecordBackend record backend
+                 , PersistStoreWrite backend
+                 )
+              => Entity record -> ReaderT backend m ()
+replaceEntity Entity{..} = replace entityKey entityVal
+
 checkUniqueKeys :: ( MonadIO m
                    , PersistUniqueRead backend
                    , PersistRecordBackend record backend

src/Utils/Files.hs

@@ -0,0 +1,36 @@
+module Utils.Files
+  ( sinkFile, sinkFiles
+  , sinkFile', sinkFiles'
+  ) where
+
+import Import.NoFoundation
+
+import qualified Crypto.Hash as Crypto (hash)
+
+import qualified Data.Conduit.Combinators as C
+
+
+sinkFiles :: MonadIO m => ConduitT File FileReference (SqlPersistT m) ()
+sinkFiles = C.mapM sinkFile
+  
+sinkFile :: MonadIO m => File -> SqlPersistT m FileReference
+sinkFile File{..} = do
+  fileReferenceContent <- for fileContent $ \fileContentContent -> do
+    let fileContentHash = Crypto.hash fileContentContent
+    unlessM (exists [ FileContentHash ==. fileContentHash ]) $
+      repsert (FileContentKey fileContentHash) FileContent{..}
+    return fileContentHash
+
+  return FileReference
+    { fileReferenceContent
+    , fileReferenceTitle    = fileTitle
+    , fileReferenceModified = fileModified
+    }
+  
+sinkFiles' :: (MonadIO m, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
+sinkFiles' = C.mapM $ uncurry sinkFile'
+
+sinkFile' :: (MonadIO m, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
+sinkFile' file residual = do
+  reference <- sinkFile file
+  return $ _FileReference # (reference, residual)

src/Utils/Lens.hs

@@ -206,8 +206,6 @@ makeLenses_ ''CourseApplication
   
 makeLenses_ ''Allocation
 
-makeLenses_ ''File
-
 makeLenses_ ''Submission
 makeLenses_ ''SubmissionUser
 

src/Utils/Sheet.hs

@@ -46,15 +46,14 @@ sheetOldUnassigned tid ssh csh = do
     _ -> error "SQL Query with limit 1 returned more than one result"
 
 -- | Return a specfic file from  a `Sheet`
-sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity File) (SqlPersistT m) ()
+sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity SheetFile) (SqlPersistT m) ()
 sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $
-  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
+  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do
   -- Restrict to consistent rows that correspond to each other
-  E.on (file  E.^. FileId         E.==. sFile  E.^. SheetFileFile)
   E.on (sFile E.^. SheetFileSheet E.==. sheet  E.^. SheetId)
   E.on (sheet E.^. SheetCourse    E.==. course E.^. CourseId)
   -- filter to requested file
-  E.where_ ((file   E.^. FileTitle       E.==. E.val title)
+  E.where_ ((sFile  E.^. SheetFileTitle  E.==. E.val title)
     E.&&.   (sFile  E.^. SheetFileType   E.==. E.val sft  )
     E.&&.   (sheet  E.^. SheetName       E.==. E.val shn  )
     E.&&.   (course E.^. CourseShorthand E.==. E.val csh  )
@@ -62,14 +61,13 @@ sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $
     E.&&.   (course E.^. CourseTerm      E.==. E.val tid  )
     )
   -- return file entity
-  return file
+  return sFile
 
 -- | Return all files of a certain `SheetFileType` for a `Sheet`
-sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity File) (SqlPersistT m) ()
+sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity SheetFile) (SqlPersistT m) ()
 sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
-  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
+  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do
   -- Restrict to consistent rows that correspond to each other
-  E.on (file  E.^. FileId         E.==. sFile  E.^. SheetFileFile)
   E.on (sFile E.^. SheetFileSheet E.==. sheet  E.^. SheetId)
   E.on (sheet E.^. SheetCourse    E.==. course E.^. CourseId)
   -- filter to requested file
@@ -80,14 +78,13 @@ sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
     E.&&.   (sFile  E.^. SheetFileType   E.==. E.val sft  )
     )
   -- return file entity
-  return file
+  return sFile
 
 -- | Return all files of certain `SheetFileTypes` for a `Sheet`
-sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity File) (SqlPersistT m) ()
+sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity SheetFile) (SqlPersistT m) ()
 sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $
-  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
+  \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do
   -- Restrict to consistent rows that correspond to each other
-  E.on (file  E.^. FileId         E.==. sFile  E.^. SheetFileFile)
   E.on (sFile E.^. SheetFileSheet E.==. sheet  E.^. SheetId)
   E.on (sheet E.^. SheetCourse    E.==. course E.^. CourseId)
   -- filter to requested file
@@ -98,7 +95,7 @@ sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $
     E.&&.   (sFile  E.^. SheetFileType  `E.in_` E.valList sfts )
     )
   -- return file entity
-  return file
+  return sFile
 
 -- | Check whether a sheet has any files for a given file type
 hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> SheetFileType -> E.SqlExpr (E.Value Bool)

stack.yaml

@@ -114,5 +114,7 @@ extra-deps:
 
   - normaldistribution-1.1.0.3
 
+  - unordered-containers-0.2.11.0
+
 resolver: lts-15.12
 allow-newer: true

stack.yaml.lock

@@ -318,6 +318,13 @@ packages:
       sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c
   original:
     hackage: normaldistribution-1.1.0.3
+- completed:
+    hackage: unordered-containers-0.2.11.0@sha256:ba70b8a9d7eebc2034bf92e5690b2dd71200e76aa9f3f93e0b6be3f27f244d18,4998
+    pantry-tree:
+      size: 1416
+      sha256: d9b83f62373f509a441223f22f12e22e39b38ef3275dfca7c190a4795bebfed5
+  original:
+    hackage: unordered-containers-0.2.11.0
 snapshots:
 - completed:
     size: 494635

templates/course.hamlet

@@ -165,6 +165,21 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
               _{MsgCourseApplicationTemplateApplication}
             $else
               _{MsgCourseApplicationTemplateRegistration}
+  $nothing
+    $if hasApplicationTemplate
+      <dt .deflist__dt>
+        $if courseApplicationsRequired course
+          _{MsgCourseApplicationInstructionsApplication}
+        $else
+          _{MsgCourseApplicationInstructionsRegistration}
+      <dd .deflist__dd>
+        <a href=@{CourseR tid ssh csh CRegisterTemplateR}>
+          #{iconRegisterTemplate} #
+          $if courseApplicationsRequired course
+            _{MsgCourseApplicationTemplateApplication}
+          $else
+            _{MsgCourseApplicationTemplateRegistration}
+
   $maybe mGroup <- submissionGroup
     <dt .deflist__dt>
       _{MsgSubmissionGroup}

templates/widgets/genericFileField.hamlet

@@ -9,7 +9,7 @@ $if not (null fileInfos)
     $forall FileUploadInfo{..} <- fileInfos
       <li>
         <div .file-container>
-          <input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{toPathPiece fuiId} :fuiForced:readonly>
+          <input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{review _FileTitle fuiTitle} :fuiForced:readonly>
           $if fuiSession
             ^{messageTooltip uploadOnlySessionMessage}
           <label for=#{fuiHtmlId}>

test/Database/Fill.hs

@@ -35,11 +35,11 @@ testdataDir :: FilePath
 testdataDir = "testdata"
 
   
-insertFile :: FilePath -> DB FileId
+insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef)
-insertFile fileTitle = do
+insertFile residual fileTitle = do
   fileContent <- liftIO . fmap Just . BS.readFile $ testdataDir </> fileTitle
   fileModified <- liftIO getCurrentTime
-  insert File{..}
+  sinkFile' File{..} residual >>= insert
 
 fillDb :: DB ()
 fillDb = do
@@ -832,12 +832,9 @@ fillDb = do
     void . insert $ SheetCorrector jost shId (Load (Just True) 0) CorrectorNormal
     void . insert $ SheetCorrector gkleen shId (Load (Just True) 1) CorrectorNormal
     void . insert $ SheetCorrector svaupel shId (Load (Just True) 1) CorrectorNormal
-    h102 <- insertFile "H10-2.hs"
+    void $ insertFile (SheetFileResidual shId SheetHint) "H10-2.hs"
-    h103 <- insertFile "H10-3.hs"
+    void $ insertFile (SheetFileResidual shId SheetSolution) "H10-3.hs"
-    pdf10 <- insertFile "ProMo_Uebung10.pdf"
+    void $ insertFile (SheetFileResidual shId SheetExercise) "ProMo_Uebung10.pdf"
-    void . insert $ SheetFile shId h102 SheetHint
-    void . insert $ SheetFile shId h103 SheetSolution
-    void . insert $ SheetFile shId pdf10 SheetExercise
 
     forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do
         subId <- insert $ Submission
@@ -850,8 +847,7 @@ fillDb = do
           }
         void . insert $ SubmissionEdit (Just uid) now subId
         void . insert $ SubmissionUser uid subId
-        fId <- insertFile "AbgabeH10-1.hs"
+        void $ insertFile (SubmissionFileResidual subId False False) "AbgabeH10-1.hs"
-        void . insert $ SubmissionFile subId fId False False
   tut1 <- insert Tutorial
     { tutorialName = "Di08"
     , tutorialCourse = pmo
@@ -1017,7 +1013,7 @@ fillDb = do
     , (jost, CourseParticipantActive)
     ]
 
-  void $ insertFile "H10-2.hs" -- unreferenced
+  -- void $ insertFile "H10-2.hs" -- unreferenced
 
   -- -- betriebssysteme
   bs <- insert' Course