fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(submission-helper): reduce number of db transactions

Browse Source
This commit is contained in:
Gregor Kleen 2021-08-06 12:26:44 +02:00
parent f454df2069
commit 625caa10b5
3 changed files with 318 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

467
src/Handler/Submission/Helper.hs
View File

@ -10,11 +10,12 @@ import Handler.Utils
import Handler.Utils.Submission import Handler.Utils.Submission
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Submission.Helper.ArchiveTable
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils 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 qualified Data.Set as Set
import Data.Map ((!), (!?)) 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, ...) -- @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 -- Therefore we do not restrict upload behaviour in any way in that case
((res,formWidget'), formEnctype) <- runDB $ do ((formWidget', formEnctype), mAct) <- runDBJobs . setSerializable $ do
(sheet@(Entity _ Sheet{..}), buddies, _, _, isLecturer, isOwner, _, _) <- getSheetInfo (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) 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 let formWidget = wrapForm' BtnHandIn formWidget' def
{ formAction = Just $ SomeRoute actionUrl { formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype , formEncoding = formEnctype
} }
mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do ((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget) <- runDB $ do
(Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo sheetInfo@(Entity shid Sheet{..}, _, _, _, _, _, msubmission, _) <- getSheetInfo
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> do
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
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 return (showCorrection, correctionInvisible)
&& is _Nothing msubmission
&& not isLecturer
)
notAuthenticated
-- Determine old submission users -- Maybe construct a table to display uploaded archive files
subUsersOld <- if mFileTable' <- for msmid $ mkSubmissionArchiveTable tid ssh csh shn showCorrection
| Just smid <- msmid -> Set.union let filesCorrected = maybe False (view _1) mFileTable'
<$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) mFileTable = view _2 <$> mFileTable'
<*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
| otherwise -> return Set.empty
res' <- case res of sheetTypeDesc <- sheetTypeDescription sheetCourse sheetType
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 multipleSubmissionWarnWidget <- runMaybeT $ do
subId <- hoistMaybe msmid
mr <- getMessageRender cID <- hoistMaybe mcid
let guardM . lift $ orM
failmsgs = (concat :: [[Text]] -> [Text]) [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR
[ flip Map.foldMapWithKey participants $ \email -> \case , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR
-- Nothing -> pure . mr $ MsgEMailUnknown email , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh , hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
(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
] ]
subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle' guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do
submissionFiles :: _ -> _ -> E.SqlQuery _ E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission
E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser
E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId E.&&. submission E.^. SubmissionId E.!=. E.val subId
E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
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 return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget)
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
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn

112
src/Handler/Submission/Helper/ArchiveTable.hs Normal file
View 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{..}

4
src/Handler/Utils/Submission.hs
View File

@ -453,7 +453,9 @@ extractRatingsMsg = do
(Right $(widgetFile "messages/submissionFilesIgnored")) (Right $(widgetFile "messages/submissionFilesIgnored"))
addMessageWidget Warning ignoredModal 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 :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
msgSubmissionErrors = flip catches msgSubmissionErrors = flip catches
[ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)