fix(files): allow clobbering files during form submission

src/Handler/Allocation/Application.hs

@@ -18,9 +18,6 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as C
 
-import Control.Monad.Trans.State (execStateT)
-import Control.Monad.State.Class (modify) 
-
 
 data AllocationApplicationButton = BtnAllocationApply
                                  | BtnAllocationApplicationEdit
@@ -298,17 +295,9 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
           now <- liftIO getCurrentTime
 
           changes <- if
-            | afmApplicantEdit afMode -> do
+            | afmApplicantEdit afMode
-              oldFiles <- Set.fromList . map (courseApplicationFileTitle . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
+              -> let mkFilter CourseApplicationFileResidual{..} = [ CourseApplicationFileApplication ==. courseApplicationFileResidualApplication ]
-              changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
+                  in view _2 <$> replaceFileReferences mkFilter (CourseApplicationFileResidual appId) (forM_ afFiles id)
-                let sinkAppFile fRef@FileReference{..}
-                      | fileReferenceTitle `Set.member` oldFiles = modify $ Set.delete fileReferenceTitle
-                      | otherwise = do
-                          lift . insert_ $ _FileReference # (fRef, CourseApplicationFileResidual appId)
-                          modify $ Set.insert fileReferenceTitle
-                in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkAppFile
-              deleteWhere [ CourseApplicationFileApplication ==. appId, CourseApplicationFileTitle <-. Set.toList (oldFiles `Set.intersection` changes) ]
-              return changes
             | otherwise
               -> return Set.empty
 

src/Handler/Course/Edit.hs

@@ -520,15 +520,8 @@ courseEditHandler miButtonAction mbCourseForm = do
 
                     insert_ $ CourseEdit aid now cid
 
-                    let
+                    let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
-                      finsert fRef@FileReference{..} = do
+                     in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
-                        tell $ Set.singleton fileReferenceTitle
-                        void . lift $ upsertBy (UniqueCourseAppInstructionFile cid fileReferenceTitle) (_FileReference # (fRef, CourseAppInstructionFileResidual cid))
-                          [ CourseAppInstructionFileModified =. fileReferenceModified
-                          , CourseAppInstructionFileContent =. fileReferenceContent
-                          ]
-                    keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
-                    deleteWhere [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileTitle /<-. Set.toList keep ]
 
                     upsertAllocationCourse cid $ cfAllocation res
 

src/Handler/Course/News/Edit.hs

@@ -7,10 +7,6 @@ import Handler.Utils
 
 import Handler.Course.News.Form
 
-import qualified Data.Set as Set
-
-import qualified Data.Conduit.List as C
-
 
 getCNEditR, postCNEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
 getCNEditR = postCNEditR
@@ -37,13 +33,8 @@ postCNEditR tid ssh csh cID = do
         , courseNewsSummary          = cnfSummary
         , courseNewsLastEdit         = now
         }
-      let
+      let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ]
-        insertFile fRef@FileReference{..} = fileReferenceTitle <$ upsertBy (UniqueCourseNewsFile nId fileReferenceTitle) (_FileReference # (fRef, CourseNewsFileResidual nId))
+       in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
-          [ CourseNewsFileModified =. fileReferenceModified
-          , CourseNewsFileContent =. fileReferenceContent
-          ]
-      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/Material.hs

@@ -10,7 +10,6 @@ import qualified Data.CaseInsensitive as CI
 -- import qualified Data.Text.Encoding as Text
 
 import qualified Database.Esqueleto as E
-import Database.Esqueleto.Utils.TH
 
 import Utils.Form
 import Handler.Utils
@@ -295,20 +294,8 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
         $ CourseR tid ssh csh (MaterialR mfName MShowR)
 
     insertMaterialFile' :: MaterialId -> FileUploads -> DB ()
-    insertMaterialFile' mid fs = do
+    insertMaterialFile' mid = (void . ) . replaceFileReferences mkFilter $ MaterialFileResidual mid
-      oldFiles <- fmap (Map.fromList . map $(unValueN 2)) . E.select . E.from $ \materialFile -> do
+      where mkFilter MaterialFileResidual{..} = [ MaterialFileMaterial ==. materialFileResidualMaterial ]
-        E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
-        return (materialFile E.^. MaterialFileTitle, materialFile E.^. MaterialFileId)
-      keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
-      deleteWhere [ MaterialFileMaterial ==. mid, MaterialFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
-      where
-        finsert oldFiles fRef
-          | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
-          = tell $ Set.singleton sfId
-          | otherwise
-          = do
-              sfId <- lift . insert $ _FileReference # (fRef, MaterialFileResidual mid)
-              tell $ Set.singleton sfId
 
 getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand ->  MaterialName -> Handler Html
 getMDelR = postMDelR

src/Handler/Sheet/Edit.hs

@@ -10,11 +10,6 @@ import Jobs.Queue
 import Handler.Utils
 import Handler.Utils.Invitations
 
-import qualified Data.Conduit.List as C
-
-import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Utils as E
-
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -143,18 +138,5 @@ handleSheetEdit tid ssh csh msId template dbAction = do
     $(i18nWidgetFile "sheet-edit")
 
 insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX ()
-insertSheetFile' sid ftype fs = do
+insertSheetFile' sid ftype = (void . ) . replaceFileReferences mkFilter $ SheetFileResidual sid ftype
-    oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do
+  where mkFilter SheetFileResidual{..} = [ SheetFileSheet ==. sheetFileResidualSheet, SheetFileType ==. sheetFileResidualType ]
-      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
-           E.&&. sheetFile E.^. SheetFileType  E.==. E.val ftype
-      return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId)
-    keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
-    deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
-  where
-    finsert oldFiles fRef
-      | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
-      = tell $ Set.singleton sfId
-      | otherwise
-      = do
-          sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype)
-          tell $ Set.singleton sfId

src/Handler/Utils/Form.hs

@@ -832,8 +832,6 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
 
-type FileUploads = ConduitT () FileReference Handler ()
-
 uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m ()
 uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybe fileContent
 

src/Utils/DB.hs

@@ -125,3 +125,14 @@ checkUniqueKeys (x:xs) = do
     case y of
         Nothing -> checkUniqueKeys xs
         Just _ -> return (Just x)
+
+
+put :: ( MonadIO m
+       , PersistUniqueWrite backend
+       , PersistRecordBackend record backend
+       )
+    => record -> ReaderT backend m (Key record)
+-- ^ `insert`, but remove all records with matching uniqueness constraints first
+put v = do
+  forM_ (persistUniqueKeys v) deleteBy
+  insert v

src/Utils/Files.hs

@@ -1,6 +1,8 @@
 module Utils.Files
   ( sinkFile, sinkFiles
   , sinkFile', sinkFiles'
+  , FileUploads
+  , replaceFileReferences
   ) where
 
 import Import.NoFoundation
@@ -15,6 +17,13 @@ import qualified Data.Conduit.Combinators as C
 import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.ByteArray as ByteArray
 
+import qualified Data.Map.Lazy as Map
+import qualified Data.Set as Set
+import Control.Monad.Trans.State.Lazy (execStateT)
+import Control.Monad.State.Class (modify)
+
+import Database.Persist.Sql (deleteWhereCount)
+
 
 sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
 sinkFiles = C.mapM sinkFile
@@ -58,3 +67,42 @@ sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileRefe
 sinkFile' file residual = do
   reference <- sinkFile file
   return $ _FileReference # (reference, residual)
+
+
+type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) ()
+
+replaceFileReferences :: ( MonadHandler m, MonadThrow m
+                         , HandlerSite m ~ UniWorX
+                         , HasFileReference record
+                         , PersistEntityBackend record ~ SqlBackend
+                         )
+                      => (FileReferenceResidual record -> [Filter record])
+                      -> FileReferenceResidual record
+                      -> FileUploads
+                      -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
+replaceFileReferences mkFilter residual fs = do
+  let resFilter = mkFilter residual
+
+  oldFiles <- Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter []
+  let oldFiles' = setOf (folded . folded) oldFiles
+
+  let
+    finsert fRef
+      | Just sfIds <- fRef `Map.lookup` oldFiles
+      = modify $ Map.mapMaybe (assertM' (not . Set.null) . (\\ sfIds))
+      | otherwise = do
+          let fRef' = _FileReference # (fRef, residual)
+          forM_ (persistUniqueKeys fRef') $ \u -> maybeT (return ()) $ do
+            Entity cKey cVal <- MaybeT . lift $ getBy u
+            deleted <- lift . lift . deleteWhereCount $ resFilter <> [ persistIdField ==. cKey ]
+            unless (deleted == 1) $
+              throwM . userError $ "replaceFileReferences tried to delete outside of filter/database inconsistency: deleted=" <> show deleted
+            lift . modify $ Map.alter (Just . maybe (Set.singleton cKey) (Set.insert cKey)) (cVal ^. _FileReference . _1)
+          fId <- lift $ insert fRef'
+          modify $ Map.alter (Just . maybe (Set.singleton fId) (Set.insert fId)) fRef
+
+  changes <- fmap (setOf $ folded . folded) . flip execStateT oldFiles . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
+
+  deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ]
+
+  return (oldFiles', changes)