diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index b7eebebb0..c5229cbfb 100644 --- a/src/Handler/Allocation/Application.hs +++ b/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 - oldFiles <- Set.fromList . map (courseApplicationFileTitle . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] [] - changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' -> - 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 + | afmApplicantEdit afMode + -> let mkFilter CourseApplicationFileResidual{..} = [ CourseApplicationFileApplication ==. courseApplicationFileResidualApplication ] + in view _2 <$> replaceFileReferences mkFilter (CourseApplicationFileResidual appId) (forM_ afFiles id) | otherwise -> return Set.empty diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d7a774586..03d867a6b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -520,15 +520,8 @@ courseEditHandler miButtonAction mbCourseForm = do insert_ $ CourseEdit aid now cid - let - finsert fRef@FileReference{..} = do - 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 ] + let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ] + in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res upsertAllocationCourse cid $ cfAllocation res diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs index 61c92a49d..d982e890e 100644 --- a/src/Handler/Course/News/Edit.hs +++ b/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 - insertFile fRef@FileReference{..} = fileReferenceTitle <$ upsertBy (UniqueCourseNewsFile nId fileReferenceTitle) (_FileReference # (fRef, CourseNewsFileResidual nId)) - [ 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 ] + let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ] + in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles addMessageI Success MsgCourseNewsEdited redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 31c04121f..817ae41f9 100644 --- a/src/Handler/Material.hs +++ b/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 - oldFiles <- fmap (Map.fromList . map $(unValueN 2)) . E.select . E.from $ \materialFile -> do - 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 + insertMaterialFile' mid = (void . ) . replaceFileReferences mkFilter $ MaterialFileResidual mid + where mkFilter MaterialFileResidual{..} = [ MaterialFileMaterial ==. materialFileResidualMaterial ] getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 8a6510129..c7cde432e 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/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 - oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do - 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 +insertSheetFile' sid ftype = (void . ) . replaceFileReferences mkFilter $ SheetFileResidual sid ftype + where mkFilter SheetFileResidual{..} = [ SheetFileSheet ==. sheetFileResidualSheet, SheetFileType ==. sheetFileResidualType ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4018bbb32..25f2e70f4 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 8e16ea1a2..d33c5703f 100644 --- a/src/Utils/DB.hs +++ b/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 diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index e171dba0d..b9121904e 100644 --- a/src/Utils/Files.hs +++ b/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)