From 625caa10b596d9a1ec135ef8bd88c6c26ae683bf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Aug 2021 12:26:44 +0200 Subject: [PATCH] refactor(submission-helper): reduce number of db transactions --- src/Handler/Submission/Helper.hs | 467 ++++++++---------- src/Handler/Submission/Helper/ArchiveTable.hs | 112 +++++ src/Handler/Utils/Submission.hs | 4 +- 3 files changed, 318 insertions(+), 265 deletions(-) create mode 100644 src/Handler/Submission/Helper/ArchiveTable.hs diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index ae5ecb8fb..9b0727e7a 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -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,282 +368,220 @@ 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 + ((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 + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ submission E.^. SubmissionId + case (msmid, submissions) of + (Nothing, E.Value smid : _) -> do + cID <- encrypt smid + addMessageI Info MsgSubmissionAlreadyExists + redirect $ CSubmissionR tid ssh csh shn cID SubShowR + _other -> return () + + when ( is _Nothing muid + && is _Nothing msubmission + && not isLecturer + ) + notAuthenticated + + -- Determine old submission users + subUsersOld <- if + | Just smid <- msmid -> Set.union + <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) + <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)) + | otherwise -> return Set.empty + + res' <- case res of + FormMissing -> return FormMissing + (FormFailure failmsgs) -> return $ FormFailure failmsgs + (FormSuccess res'@(_, groupMembers, _)) + | groupMembers == subUsersOld -> return $ FormSuccess res' + | isLecturer -> return $ FormSuccess res' + | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members + let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers + prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) + prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] + participants <- fmap prep . E.select . E.from $ \user -> do + E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds + let + isParticipant = E.exists . E.from $ \courseParticipant -> do + E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 + Nothing -> return () + Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) + + $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants + + mr <- getMessageRender + let + failmsgs = (concat :: [[Text]] -> [Text]) + [ flip Map.foldMapWithKey participants $ \email -> \case + -- Nothing -> pure . mr $ MsgEMailUnknown email + (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh + (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email + _other -> mempty + , case fromIntegral (Map.size participants) `compare` maxParticipants of + GT | not isLecturer -> pure $ mr MsgTooManyParticipants + _ -> mempty + ] + return $ if null failmsgs + then FormSuccess res' + else FormFailure failmsgs + | otherwise -> return $ FormSuccess res' + + + formResultMaybe res' $ \(mFiles, adhocMembers, mASDId) -> do + now <- liftIO getCurrentTime + + smid <- case (mFiles, msmid) of + (Nothing, Just smid) -- no new files, existing submission partners updated + -> return smid + (Just files, _) -> -- new files + 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 + { submissionSheet = shid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Nothing + , submissionRatingAssigned = Nothing + , submissionRatingTime = Nothing + } + audit $ TransactionSubmissionEdit sid shid + + insert_ $ SubmissionEdit muid now sid + + return sid + + -- Determine new submission users + subUsers <- if + | isLecturer -> return adhocMembers + | RegisteredGroups <- sheetGrouping -> do + -- Determine members of pre-registered group + groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup + E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid + E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + + E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid + E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser + E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + + return $ submissionGroupUser' E.^. SubmissionGroupUserUser + -- SubmissionUser for all group members (pre-registered & ad-hoc) + return $ maybe id (Set.insert . Right) muid groupUids + | otherwise -> return adhocMembers + + -- Since invitations carry no data we only need to consider changes to + -- the set of users/invited emails + -- Otherwise we would have to update old invitations (via + -- `sinkInvitationsF`) because their associated @DBData@ might have + -- changed + + forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if + -- change is a new user being added to the submission users => send invitation / insert + | change `Set.member` subUsers -> case change of + Left subEmail -> do + -- user does not exist yet => send invitation + sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))] + return () + Right subUid -> do + -- user exists and has an id => insert as SubmissionUser and audit + insert_ $ SubmissionUser subUid smid + audit $ TransactionSubmissionUserEdit smid subUid + unless (Just subUid == muid) $ + queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid + -- change is an old user that is not a submission user anymore => delete invitation / delete + | otherwise -> case change of + Left subEmail -> deleteInvitation @SubmissionUser smid subEmail + Right subUid -> do + deleteBy $ UniqueSubmissionUser subUid smid + audit $ TransactionSubmissionUserDelete smid subUid + unless (Just subUid == muid) $ + queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid + + forM_ mASDId $ \asdId -> do + uid <- maybe notAuthenticated return muid + insert_ $ AuthorshipStatementSubmission asdId smid uid now + + if | is _Nothing msmid -> addMessageI Success MsgSubmissionCreated + | is _Just mFiles -> addMessageI Success MsgSubmissionUpdated + | subUsers == subUsersOld -> addMessageI Info MsgSubmissionUnchanged + | otherwise -> addMessageI Success MsgSubmissionUsersUpdated + + cID <- encrypt smid + let showRoute = CSubmissionR tid ssh csh shn cID SubShowR + mayShow <- hoist lift $ hasReadAccessTo showRoute + + return . Just $ if + | mayShow -> redirect showRoute + | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR + + 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) + + sequence_ mAct 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 + ((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget) <- runDB $ do + sheetInfo@(Entity shid Sheet{..}, _, _, _, _, _, msubmission, _) <- getSheetInfo - 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 - E.&&. submission E.^. SubmissionSheet E.==. E.val shid - return $ submission E.^. SubmissionId - case (msmid, submissions) of - (Nothing, E.Value smid : _) -> do - cID <- encrypt smid - addMessageI Info MsgSubmissionAlreadyExists - redirect $ CSubmissionR tid ssh csh shn cID SubShowR - _other -> return () + (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 - when ( is _Nothing muid - && is _Nothing msubmission - && not isLecturer - ) - notAuthenticated + return (showCorrection, correctionInvisible) - -- Determine old submission users - subUsersOld <- if - | Just smid <- msmid -> Set.union - <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) - <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)) - | otherwise -> return Set.empty + -- Maybe construct a table to display uploaded archive files + mFileTable' <- for msmid $ mkSubmissionArchiveTable tid ssh csh shn showCorrection + let filesCorrected = maybe False (view _1) mFileTable' + mFileTable = view _2 <$> mFileTable' - res' <- case res of - FormMissing -> return FormMissing - (FormFailure failmsgs) -> return $ FormFailure failmsgs - (FormSuccess res'@(_, groupMembers, _)) - | groupMembers == subUsersOld -> return $ FormSuccess res' - | isLecturer -> return $ FormSuccess res' - | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members - let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers - prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) - prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] - participants <- fmap prep . E.select . E.from $ \user -> do - E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds - let - isParticipant = E.exists . E.from $ \courseParticipant -> do - E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser - E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.&&. submission E.^. SubmissionSheet E.==. E.val shid - case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 - Nothing -> return () - Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid - return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) + sheetTypeDesc <- sheetTypeDescription sheetCourse sheetType - $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants - - mr <- getMessageRender - let - failmsgs = (concat :: [[Text]] -> [Text]) - [ flip Map.foldMapWithKey participants $ \email -> \case - -- Nothing -> pure . mr $ MsgEMailUnknown email - (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh - (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email - _other -> mempty - , case fromIntegral (Map.size participants) `compare` maxParticipants of - GT | not isLecturer -> pure $ mr MsgTooManyParticipants - _ -> mempty - ] - return $ if null failmsgs - then FormSuccess res' - else FormFailure failmsgs - | otherwise -> return $ FormSuccess res' - - - formResultMaybe res' $ \(mFiles, adhocMembers, mASDId) -> do - now <- liftIO getCurrentTime - - smid <- case (mFiles, msmid) of - (Nothing, Just smid) -- no new files, existing submission partners updated - -> return smid - (Just files, _) -> -- new files - 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 - { submissionSheet = shid - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Nothing - , submissionRatingAssigned = Nothing - , submissionRatingTime = Nothing - } - audit $ TransactionSubmissionEdit sid shid - - insert_ $ SubmissionEdit muid now sid - - return sid - - -- Determine new submission users - subUsers <- if - | isLecturer -> return adhocMembers - | RegisteredGroups <- sheetGrouping -> do - -- Determine members of pre-registered group - groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid - E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - - E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid - E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser - E.where_ $ submission E.^. SubmissionId E.!=. E.val smid - - return $ submissionGroupUser' E.^. SubmissionGroupUserUser - -- SubmissionUser for all group members (pre-registered & ad-hoc) - return $ maybe id (Set.insert . Right) muid groupUids - | otherwise -> return adhocMembers - - -- Since invitations carry no data we only need to consider changes to - -- the set of users/invited emails - -- Otherwise we would have to update old invitations (via - -- `sinkInvitationsF`) because their associated @DBData@ might have - -- changed - - forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if - -- change is a new user being added to the submission users => send invitation / insert - | change `Set.member` subUsers -> case change of - Left subEmail -> do - -- user does not exist yet => send invitation - sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))] - return () - Right subUid -> do - -- user exists and has an id => insert as SubmissionUser and audit - insert_ $ SubmissionUser subUid smid - audit $ TransactionSubmissionUserEdit smid subUid - unless (Just subUid == muid) $ - queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid - -- change is an old user that is not a submission user anymore => delete invitation / delete - | otherwise -> case change of - Left subEmail -> deleteInvitation @SubmissionUser smid subEmail - Right subUid -> do - deleteBy $ UniqueSubmissionUser subUid smid - audit $ TransactionSubmissionUserDelete smid subUid - unless (Just subUid == muid) $ - queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid - - forM_ mASDId $ \asdId -> do - uid <- maybe notAuthenticated return muid - insert_ $ AuthorshipStatementSubmission asdId smid uid now - - if | is _Nothing msmid -> addMessageI Success MsgSubmissionCreated - | is _Just mFiles -> addMessageI Success MsgSubmissionUpdated - | subUsers == subUsersOld -> addMessageI Info MsgSubmissionUnchanged - | otherwise -> addMessageI Success MsgSubmissionUsersUpdated - - Just <$> encrypt smid - - case mCID of - Just cID -> do - let showRoute = CSubmissionR tid ssh csh shn cID SubShowR - mayShow <- hasReadAccessTo showRoute - if - | mayShow -> redirect showRoute - | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR - Nothing -> return () - - (Entity shid Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo - - (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ 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 + multipleSubmissionWarnWidget <- runMaybeT $ do + subId <- hoistMaybe msmid + cID <- hoistMaybe mcid + guardM . lift $ orM + [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR + , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR + , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR + , hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR ] - 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 + guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do + E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission + E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid + E.&&. submission E.^. SubmissionId E.!=. E.val subId + E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning - 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, 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 - subId <- hoistMaybe msmid - cID <- hoistMaybe mcid - guardM . lift $ orM - [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR - , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR - , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR - , hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR - ] - guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do - E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission - E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser - E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid - E.&&. submission E.^. SubmissionId E.!=. E.val subId - 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 diff --git a/src/Handler/Submission/Helper/ArchiveTable.hs b/src/Handler/Submission/Helper/ArchiveTable.hs new file mode 100644 index 000000000..d7e9c4fc1 --- /dev/null +++ b/src/Handler/Submission/Helper/ArchiveTable.hs @@ -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{..} diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 32ed19560..c49d6d99a 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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)