fix(files): allow clobbering files during form submission
This commit is contained in:
Gregor Kleen
parent
d770afd2c6
commit
a60ad1abae
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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}|]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user