refactor(submission-helper): reduce number of db transactions
This commit is contained in:
Gregor Kleen
parent
f454df2069
commit
625caa10b5
@ -10,11 +10,12 @@ import Handler.Utils
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Handler.Submission.Helper.ArchiveTable
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map ((!), (!?))
|
||||
@ -367,18 +368,13 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
|
||||
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
|
||||
-- Therefore we do not restrict upload behaviour in any way in that case
|
||||
((res,formWidget'), formEnctype) <- runDB $ do
|
||||
(sheet@(Entity _ Sheet{..}), buddies, _, _, isLecturer, isOwner, _, _) <- getSheetInfo
|
||||
((formWidget', formEnctype), mAct) <- runDBJobs . setSerializable $ do
|
||||
(sheet@(Entity shid Sheet{..}), buddies, _, _, isLecturer, isOwner, msubmission, _) <- hoist lift getSheetInfo
|
||||
let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1)
|
||||
runFormPost . makeSubmissionForm sheetCourse sheet msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
|
||||
mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do
|
||||
(Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo
|
||||
((res, formWidget'), formEnctype) <- hoist lift . runFormPost . makeSubmissionForm sheetCourse sheet msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
||||
|
||||
-- Calling `msgSubmissionErrors` within a `runDB` is okay as long as we handle `transactionUndo` ourselves iff it returns nothing
|
||||
mAct' <- msgSubmissionErrors $ do
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
||||
E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
|
||||
@ -533,100 +529,41 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
| subUsers == subUsersOld -> addMessageI Info MsgSubmissionUnchanged
|
||||
| otherwise -> addMessageI Success MsgSubmissionUsersUpdated
|
||||
|
||||
Just <$> encrypt smid
|
||||
|
||||
case mCID of
|
||||
Just cID -> do
|
||||
cID <- encrypt smid
|
||||
let showRoute = CSubmissionR tid ssh csh shn cID SubShowR
|
||||
mayShow <- hasReadAccessTo showRoute
|
||||
if
|
||||
mayShow <- hoist lift $ hasReadAccessTo showRoute
|
||||
|
||||
return . Just $ if
|
||||
| mayShow -> redirect showRoute
|
||||
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
||||
Nothing -> return ()
|
||||
|
||||
(Entity shid Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
|
||||
case mAct' of
|
||||
Nothing -> ((formWidget', formEnctype), Nothing) <$ E.transactionUndo -- manual rollback because we are calling `msgSubmissionErrors` within a `runDB`
|
||||
Just mAct -> return ((formWidget', formEnctype), mAct)
|
||||
|
||||
(showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ do
|
||||
sequence_ mAct
|
||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
|
||||
((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget) <- runDB $ do
|
||||
sheetInfo@(Entity shid Sheet{..}, _, _, _, _, _, msubmission, _) <- getSheetInfo
|
||||
|
||||
(showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> do
|
||||
showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
|
||||
|
||||
return (showCorrection, correctionInvisible)
|
||||
|
||||
-- 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 MsgTableFileTitle) $ \(mOrig, mCorr) -> let
|
||||
fileTitle'' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
|
||||
origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
|
||||
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
|
||||
isFile' = origIsFile <|> corrIsFile
|
||||
in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
|
||||
| Just True <- origIsFile -> anchorCell (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \(_, mCorr) -> case mCorr of
|
||||
Nothing -> cell mempty
|
||||
Just (Entity _ SubmissionFile{..})
|
||||
| isJust submissionFileContent -> anchorCell (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
||||
| otherwise -> i18nCell MsgCorrected
|
||||
, Just . sortable (Just "time") (i18nCell MsgTableFileModified) $ \(mOrig, mCorr) -> let
|
||||
origTime = submissionFileModified . entityVal <$> mOrig
|
||||
corrTime = submissionFileModified . entityVal <$> mCorr
|
||||
fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
||||
in maybeCell fileTime dateTimeCell
|
||||
]
|
||||
subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
|
||||
submissionFiles :: _ -> _ -> E.SqlQuery _
|
||||
submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
|
||||
E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
|
||||
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.&&. E.val showCorrection -- Do not correlate files if we don't show correction; together with `may-access` this treats corrected files like they literally don't exist
|
||||
mFileTable' <- for msmid $ mkSubmissionArchiveTable tid ssh csh shn showCorrection
|
||||
let filesCorrected = maybe False (view _1) mFileTable'
|
||||
mFileTable = view _2 <$> mFileTable'
|
||||
|
||||
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))
|
||||
sheetTypeDesc <- sheetTypeDescription sheetCourse sheetType
|
||||
|
||||
return (sf1, sf2)
|
||||
smid2ArchiveTable (smid,cid) = DBTable
|
||||
{ dbtSQLQuery = submissionFiles smid
|
||||
, dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
|
||||
, dbtColonnade = colonnadeFiles cid
|
||||
, dbtProj = dbrOutput <$> dbtProjId
|
||||
, dbtStyle = def
|
||||
, dbtIdent = "files" :: Text
|
||||
, dbtSorting = mconcat
|
||||
[ singletonMap "path" . SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "string_to_array" :: (E.SqlExpr (E.Value (Maybe String)), E.SqlExpr (E.Value String)) -> E.SqlExpr (E.Value [String])) (E.coalesce [sf1 E.?. SubmissionFileTitle, sf2 E.?. SubmissionFileTitle], E.val "/" :: E.SqlExpr (E.Value String))
|
||||
, singletonMap "time" . 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 = mconcat
|
||||
[ singletonMap "may-access" . FilterColumn $ \(Any b) (sf1 `E.FullOuterJoin` (_ :: E.SqlExpr (Maybe (Entity SubmissionFile))))
|
||||
-> E.val b E.==. (E.val showCorrection E.||. E.isJust (sf1 E.?. SubmissionFileId))
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtParams = def
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
, dbtExtraReps = []
|
||||
}
|
||||
archiveTableValidator = def
|
||||
& defaultSorting [SortAscBy "path"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
mFileTable <- traverse (runDB . dbTableWidget' archiveTableValidator) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||
|
||||
|
||||
filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do
|
||||
E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle
|
||||
E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission
|
||||
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.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
|
||||
E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId)
|
||||
|
||||
sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
|
||||
|
||||
multipleSubmissionWarnWidget <- runDB . runMaybeT $ do
|
||||
multipleSubmissionWarnWidget <- runMaybeT $ do
|
||||
subId <- hoistMaybe msmid
|
||||
cID <- hoistMaybe mcid
|
||||
guardM . lift $ orM
|
||||
@ -644,6 +581,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
||||
return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
|
||||
|
||||
return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget)
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn
|
||||
(urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
|
||||
|
||||
112
src/Handler/Submission/Helper/ArchiveTable.hs
Normal file
112
src/Handler/Submission/Helper/ArchiveTable.hs
Normal file
@ -0,0 +1,112 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Submission.Helper.ArchiveTable
|
||||
( mkSubmissionArchiveTable
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction)
|
||||
|
||||
|
||||
type SubmissionArchiveExpr = E.SqlExpr (Maybe (Entity SubmissionFile)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity SubmissionFile))
|
||||
|
||||
queryOriginal, queryCorrected :: Getter SubmissionArchiveExpr (E.SqlExpr (Maybe (Entity SubmissionFile)))
|
||||
queryOriginal = to $(E.sqlFOJproj 2 1)
|
||||
queryCorrected = to $(E.sqlFOJproj 2 2)
|
||||
|
||||
|
||||
type SubmissionArchiveData = DBRow ( Maybe (Entity SubmissionFile)
|
||||
, Maybe (Entity SubmissionFile)
|
||||
)
|
||||
|
||||
resultOriginal, resultCorrected :: Traversal' SubmissionArchiveData (Entity SubmissionFile)
|
||||
resultOriginal = _dbrOutput . _1 . _Just
|
||||
resultCorrected = _dbrOutput . _2 . _Just
|
||||
|
||||
|
||||
mkSubmissionArchiveTable :: TermId -> SchoolId -> CourseShorthand -> SheetName
|
||||
-> Bool -- ^ @showCorrection@
|
||||
-> SubmissionId
|
||||
-> DB (Bool, Widget)
|
||||
mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do
|
||||
cID <- encrypt smid :: DB CryptoFileNameSubmission -- shouldn't be expensive due to caching
|
||||
|
||||
let
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "files"
|
||||
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
original <- view queryOriginal
|
||||
corrected <- view queryCorrected
|
||||
|
||||
lift . E.on $
|
||||
original E.?. SubmissionFileTitle E.==. corrected E.?. SubmissionFileTitle
|
||||
E.&&. original E.?. SubmissionFileSubmission E.==. corrected E.?. SubmissionFileSubmission
|
||||
E.&&. original E.?. SubmissionFileId E.!=. corrected E.?. SubmissionFileId
|
||||
E.&&. corrected E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
|
||||
E.&&. E.val showCorrection -- Do not correlate files if we don't show correction; together with `may-access` this treats corrected files like they literally don't exist
|
||||
|
||||
lift . E.where_ $ original E.?. SubmissionFileSubmission E.==. E.val (Just smid)
|
||||
E.||. corrected E.?. SubmissionFileSubmission E.==. E.val (Just smid)
|
||||
|
||||
lift . E.where_ . E.maybe E.true E.not_ $ original E.?. SubmissionFileIsUpdate -- @original@ is unset or not an update
|
||||
lift . E.where_ . E.maybe E.true id $ corrected E.?. SubmissionFileIsUpdate -- @corrected@ is unset or an update
|
||||
lift . E.where_ . E.maybe E.true E.not_ $ corrected E.?. SubmissionFileIsDeletion -- @corrected@ is unset or not a deletion
|
||||
return (original, corrected)
|
||||
dbtRowKey = (,) <$> views queryOriginal (E.?. SubmissionFileId) <*> views queryCorrected (E.?. SubmissionFileId)
|
||||
|
||||
dbtProj = dbtProjId
|
||||
|
||||
dbtColonnade = mconcat $ catMaybes
|
||||
[ Just . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \t -> let
|
||||
mOrig = t ^? resultOriginal
|
||||
mCorr = t ^? resultCorrected
|
||||
fileTitle'' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
|
||||
origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
|
||||
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
|
||||
isFile' = origIsFile <|> corrIsFile
|
||||
in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
|
||||
| Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of
|
||||
Nothing -> cell mempty
|
||||
Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if
|
||||
| isJust submissionFileContent -> anchorCell (subDownloadLink SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
||||
| otherwise -> i18nCell MsgCorrected
|
||||
, Just . sortable (Just "time") (i18nCell MsgTableFileModified) $ \t -> let
|
||||
mOrig = t ^? resultOriginal
|
||||
mCorr = t ^? resultCorrected
|
||||
origTime = submissionFileModified . entityVal <$> mOrig
|
||||
corrTime = submissionFileModified . entityVal <$> mCorr
|
||||
fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
||||
in maybeCell fileTime dateTimeCell
|
||||
]
|
||||
where
|
||||
subDownloadLink sft fileTitle' = CSubmissionR tid ssh csh shn cID $ SubDownloadR sft fileTitle'
|
||||
|
||||
dbtStyle = def
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "path" . SortColumn $ \r -> (E.unsafeSqlFunction "string_to_array" :: (E.SqlExpr (E.Value (Maybe String)), E.SqlExpr (E.Value String)) -> E.SqlExpr (E.Value [String])) (E.coalesce [views queryOriginal (E.?. SubmissionFileTitle) r, views queryCorrected (E.?. SubmissionFileTitle) r], E.val "/" :: E.SqlExpr (E.Value String))
|
||||
, singletonMap "time" . SortColumn $ \r -> (E.unsafeSqlFunction "GREATEST" ([views queryOriginal (E.?. SubmissionFileModified) r, views queryCorrected (E.?. SubmissionFileModified) r] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterColumn $ \(Any b) r
|
||||
-> E.val b E.==. (E.val showCorrection E.||. E.isJust (views queryOriginal (E.?. SubmissionFileId) r))
|
||||
]
|
||||
|
||||
dbtFilterUI = mempty
|
||||
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
|
||||
archiveTableValidator = def
|
||||
& defaultSorting [SortAscBy "path"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
in over _1 getAny <$> dbTableWidget archiveTableValidator DBTable{..}
|
||||
@ -453,7 +453,9 @@ extractRatingsMsg = do
|
||||
(Right $(widgetFile "messages/submissionFilesIgnored"))
|
||||
addMessageWidget Warning ignoredModal
|
||||
|
||||
-- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
|
||||
-- | Needs to *not* be called from within `runDB` so db transaction rollback can happen properly
|
||||
--
|
||||
-- Nontheless: we do assume elsewhere, that we can call `msgSubmissionErrors` from within `runDB` as long as we do `transactionUndo` iff it returns `Nothing`.
|
||||
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
|
||||
msgSubmissionErrors = flip catches
|
||||
[ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
|
||||
|
||||
Reference in New Issue
Block a user