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,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
|
||||
|
||||
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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user