fix(submissions): take care when to display corrections
Also cleanup usage of Utils via hlint
This commit is contained in:
Gregor Kleen
parent
1763237d5a
commit
a6390eccbd
10
.hlint.yaml
10
.hlint.yaml
@ -181,3 +181,13 @@
|
||||
- fixity: "infix 4 <.>="
|
||||
- fixity: "infix 4 <<.>="
|
||||
- fixity: "infix 4 <<<.>="
|
||||
|
||||
- suggest: { lhs: maybeT (return ()), rhs: maybeT_ }
|
||||
- warn: { lhs: length xs >= n, rhs: minLength n xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: n <= length xs, rhs: minLength n xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: length xs > n, rhs: minLength (n + 1) xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: n < length xs, rhs: minLength (n + 1) xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: length xs <= n, rhs: maxLength n xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: n >= length xs, rhs: maxLength n xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: length xs < n, rhs: maxLength (n - 1) xs, note: IncreasesLaziness }
|
||||
- warn: { lhs: n > length xs, rhs: maxLength (n - 1) xs, note: IncreasesLaziness }
|
||||
|
||||
@ -1076,11 +1076,11 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route o
|
||||
r -> $unsupportedAuthPredicate AuthCourseTime r
|
||||
tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of
|
||||
CSubmissionR tid ssh csh shn _cID CorrectionR -> maybeT (unauthorizedI MsgUnauthorizedCorrectionExamTime) $ do
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
|
||||
whenIsJust (sheetType ^? _examPart . from _SqlKey) $ \epId -> do
|
||||
ExamPart{examPartExam} <- $cachedHereBinary epId . MaybeT $ get epId
|
||||
Exam{..} <- $cachedHereBinary examPartExam . MaybeT $ get examPartExam
|
||||
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
||||
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
||||
now <- liftIO getCurrentTime
|
||||
guard $ NTop (Just now) >= NTop examFinished
|
||||
return Authorized
|
||||
|
||||
@ -61,7 +61,7 @@ postAAddUserR tid ssh ash = do
|
||||
unless (courseApplicationCourse `Map.member` aauApplications) $
|
||||
audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId
|
||||
|
||||
iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT (return ()) $ do
|
||||
iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT_ $ do
|
||||
prio <- hoistMaybe afPriority
|
||||
let rated = afRatingVeto || is _Just afRatingPoints
|
||||
appId <- lift $ insert CourseApplication
|
||||
|
||||
@ -81,7 +81,7 @@ postEECorrectR tid ssh coursen examn = do
|
||||
, GuessUserSurname (ident :: UserSurname)
|
||||
, GuessUserFirstName (ident :: UserFirstName)
|
||||
]
|
||||
in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1)
|
||||
in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf . Just $ succ maxCountUserMatches)
|
||||
|
||||
if
|
||||
| is _Nothing ciqResults, is _Nothing ciqGrade -> do
|
||||
|
||||
@ -52,8 +52,11 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
ur <- getUrlRenderParams
|
||||
tr <- getTranslate
|
||||
case results of
|
||||
[(Entity cId Course{}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
sheetTypeDesc <- runDB $ sheetTypeDescription cId sheetType
|
||||
[(Entity cId Course{}, Entity shId Sheet{..}, subEnt@(Entity _ subm@Submission{..}), corrector, E.Value filesCorrected)] -> do
|
||||
(sheetTypeDesc, invisibleWidget) <- runDB $ do
|
||||
sheetTypeDesc <- sheetTypeDescription cId sheetType
|
||||
invisibleWidget <- correctionInvisibleWidget tid ssh csh shn cid subEnt
|
||||
return (sheetTypeDesc, invisibleWidget)
|
||||
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
||||
pointsForm = case sheetType of
|
||||
NotGraded
|
||||
@ -115,10 +118,6 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
, SubmissionRatingComment =. ratingComment'
|
||||
]
|
||||
|
||||
when (rated && is _Nothing submissionRatingTime) $ do
|
||||
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
|
||||
|
||||
addMessageI Success $ if
|
||||
| rated -> MsgRatingUpdated
|
||||
| is _Nothing ratingComment'
|
||||
@ -142,7 +141,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
headingWgt = [whamlet|
|
||||
$newline never
|
||||
_{heading}
|
||||
$if not (submissionRatingDone subm)
|
||||
$if is _Just invisibleWidget || not (submissionRatingDone subm)
|
||||
\ ^{isVisibleWidget False}
|
||||
|]
|
||||
|
||||
@ -150,6 +149,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
setTitleI heading
|
||||
urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
|
||||
let userCorrection = $(widgetFile "correction-user")
|
||||
fromMaybe (return ()) invisibleWidget
|
||||
$(widgetFile "correction")
|
||||
_ -> notFound
|
||||
getCorrectionUserR tid ssh csh shn cid = do
|
||||
|
||||
@ -17,7 +17,7 @@ import qualified Data.Conduit.Combinators as Conduit
|
||||
|
||||
|
||||
subDownloadSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> ConduitT () SubmissionFile (YesodDB UniWorX) ()
|
||||
subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = maybeT (return ()) $ do
|
||||
subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = maybeT_ $ do
|
||||
(submissionID, isRating) <- hoist lift $ do
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
@ -57,7 +57,7 @@ getSubDownloadR tid ssh csh shn cID sft@(submissionFileTypeIsUpdate -> isUpdate)
|
||||
|
||||
|
||||
subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) ()
|
||||
subArchiveSource tid ssh csh shn cID sfType = maybeT (return ()) $ do
|
||||
subArchiveSource tid ssh csh shn cID sfType = maybeT_ $ do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardM . lift . lift . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
|
||||
|
||||
|
||||
@ -30,14 +30,6 @@ import Data.Aeson.Lens
|
||||
import Handler.Submission.SubmissionUserInvite
|
||||
|
||||
|
||||
data CorrectionInvisibleReason
|
||||
= CorrectionInvisibleExamUnfinished
|
||||
| CorrectionInvisibleRatingNotDone
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id
|
||||
|
||||
|
||||
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
|
||||
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
|
||||
<$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
|
||||
@ -484,26 +476,13 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
||||
Nothing -> return ()
|
||||
|
||||
(Entity _ Sheet{..}, buddies, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
|
||||
(Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
|
||||
|
||||
(showCorrection, correctionVisible, correctionInvisibleReasons) <- fmap (fromMaybe (False, False, Set.empty)) . for mcid $ \cid -> runDB $ do
|
||||
(showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ do
|
||||
showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
correctionVisible <- allMOf (folded . _Right) buddies $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cid CorrectionR) False
|
||||
correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
|
||||
|
||||
correctionInvisibleReasons <- if
|
||||
| correctionVisible -> return Set.empty
|
||||
| otherwise -> mapReaderT execWriterT $ do
|
||||
unless (maybe True submissionRatingDone msubmission) $
|
||||
tellPoint CorrectionInvisibleRatingNotDone
|
||||
maybeT (return ()) $ do
|
||||
epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey
|
||||
ExamPart{examPartExam} <- MaybeT $ get epId
|
||||
Exam{..} <- MaybeT $ get examPartExam
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop (Just now) >= NTop examFinished) $
|
||||
tellPoint CorrectionInvisibleExamUnfinished
|
||||
|
||||
return (showCorrection, correctionVisible, correctionInvisibleReasons)
|
||||
return (showCorrection, correctionInvisible)
|
||||
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
|
||||
@ -589,5 +568,5 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
[ submissionRatingDone sub
|
||||
, is _Just submissionRatingPoints, is _Just submissionRatingComment
|
||||
]
|
||||
correctionVisibleWarnWidget = guardOn (is _Just msubmission && is _Just mcid && showCorrection && not correctionVisible) $ notificationWidget NotificationBroad Warning $(widgetFile "submission-correction-invisible")
|
||||
correctionVisibleWarnWidget = guardOnM (is _Just msubmission && is _Just mcid && showCorrection) correctionInvisible
|
||||
$(widgetFile "submission")
|
||||
|
||||
@ -121,7 +121,7 @@ ensureApprootUserGeneratedMaybe'
|
||||
)
|
||||
=> Maybe (ConduitT () (Either FileReference DBFile) m ())
|
||||
-> m ()
|
||||
ensureApprootUserGeneratedMaybe' source = maybeT (return ()) $ do
|
||||
ensureApprootUserGeneratedMaybe' source = maybeT_ $ do
|
||||
route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest
|
||||
$logDebugS "ensureApproot" $ tshow route
|
||||
rApproot <- hoistMaybe <=< lift . runMaybeT $ do
|
||||
|
||||
@ -10,13 +10,14 @@ module Handler.Utils.Submission
|
||||
, sinkSubmission, sinkMultiSubmission
|
||||
, submissionMatchesSheet
|
||||
, submissionDeleteRoute
|
||||
, correctionInvisibleWidget
|
||||
) where
|
||||
|
||||
import Import hiding (joinPath)
|
||||
import Jobs.Queue
|
||||
import Yesod.Core.Types (HandlerContents(..))
|
||||
|
||||
import Control.Monad.State.Class as State
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
@ -229,7 +230,7 @@ planSubmissions sid restriction = do
|
||||
targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions
|
||||
|
||||
(newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do
|
||||
tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
|
||||
tutors <- State.gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
|
||||
let acceptableCorrectors
|
||||
| correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors
|
||||
, not $ null correctorsByTut
|
||||
@ -395,7 +396,6 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
data SubmissionSinkState = SubmissionSinkState
|
||||
{ sinkSeenRating :: Last Rating'
|
||||
, sinkSubmissionTouched :: Any
|
||||
, sinkSubmissionNotifyRating :: Any
|
||||
, sinkFilenames :: Set FilePath
|
||||
} deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
@ -554,7 +554,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
|
||||
sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId)
|
||||
where
|
||||
tellSt = modify . mappend
|
||||
tellSt = State.modify . mappend
|
||||
|
||||
guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m ()
|
||||
guardFileTitles SubmissionMode{..}
|
||||
@ -576,7 +576,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
Left file@FileReference{..} -> do
|
||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
||||
|
||||
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
|
||||
alreadySeen <- State.gets (Set.member fileReferenceTitle . sinkFilenames)
|
||||
when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle
|
||||
tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle }
|
||||
|
||||
@ -632,7 +632,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
unless (submissionId' == submissionId) $
|
||||
throwM $ ForeignRating cID
|
||||
|
||||
alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating
|
||||
alreadySeen <- State.gets $ is (_Wrapped . _Just) . sinkSeenRating
|
||||
when alreadySeen $ throwM DuplicateRating
|
||||
|
||||
submission <- lift $ getJust submissionId
|
||||
@ -671,8 +671,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
|
||||
mapM_ (throwM . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r'
|
||||
|
||||
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
|
||||
tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
||||
lift $ replace submissionId submission'
|
||||
sheetId <- lift getSheetId
|
||||
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
||||
@ -697,7 +695,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
|
||||
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
|
||||
touchSubmission = do
|
||||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||||
alreadyTouched <- State.gets $ getAny . sinkSubmissionTouched
|
||||
unless alreadyTouched $ do
|
||||
now <- liftIO getCurrentTime
|
||||
if
|
||||
@ -769,9 +767,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
update submissionId [ SubmissionRatingTime =. Nothing, SubmissionRatingPoints =. Nothing, SubmissionRatingComment =. Nothing]
|
||||
sheetId <- getSheetId
|
||||
audit $ TransactionSubmissionEdit submissionId sheetId
|
||||
| isUpdate
|
||||
, getAny sinkSubmissionNotifyRating
|
||||
-> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
|
||||
| not isUpdate
|
||||
, getAny sinkSubmissionTouched
|
||||
, is _Right mExists
|
||||
@ -801,7 +796,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
(YesodJobDB UniWorX)
|
||||
()
|
||||
feed sId val = do
|
||||
mSink <- gets $ Map.lookup sId
|
||||
mSink <- State.gets $ Map.lookup sId
|
||||
sink <- case mSink of
|
||||
Just sink -> return sink
|
||||
Nothing -> do
|
||||
@ -816,7 +811,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
Left _ -> error "sinkSubmission returned prematurely"
|
||||
Right nSink -> modify $ Map.insert sId nSink
|
||||
Right nSink -> State.modify $ Map.insert sId nSink
|
||||
(sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case
|
||||
v@(Right (sId, _)) -> do
|
||||
cID <- encrypt sId
|
||||
@ -930,3 +925,36 @@ submissionDeleteRoute drRecords = DeleteRoute
|
||||
|
||||
del
|
||||
}
|
||||
|
||||
|
||||
data CorrectionInvisibleReason
|
||||
= CorrectionInvisibleExamUnfinished
|
||||
| CorrectionInvisibleRatingNotDone
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id
|
||||
|
||||
correctionInvisibleWidget :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission
|
||||
-> Entity Submission
|
||||
-> DB (Maybe Widget)
|
||||
correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ do
|
||||
submittors <- lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \submissionUser -> do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
||||
return $ submissionUser E.^. SubmissionUserUser
|
||||
|
||||
corrVisible <- lift . allM submittors $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
guard $ not corrVisible
|
||||
|
||||
reasons <- lift . mapReaderT execWriterT $ do
|
||||
unless (submissionRatingDone sub) $
|
||||
tellPoint @(Set _) CorrectionInvisibleRatingNotDone
|
||||
maybeT_ $ do
|
||||
Sheet{..} <- MaybeT . get $ submissionSheet sub
|
||||
epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey
|
||||
ExamPart{examPartExam} <- MaybeT $ get epId
|
||||
Exam{..} <- MaybeT $ get examPartExam
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop (Just now) >= NTop examFinished) $
|
||||
tellPoint CorrectionInvisibleExamUnfinished
|
||||
|
||||
return $ notificationWidget NotificationBroad Warning $(widgetFile "submission-correction-invisible")
|
||||
|
||||
@ -695,7 +695,8 @@ withCsvExtraRep :: forall exportData csv sheetName r' k'.
|
||||
-> exportData
|
||||
-> Maybe (DBTCsvEncode r' k' csv)
|
||||
-> [DBTExtraRep r' k'] -> [DBTExtraRep r' k']
|
||||
withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv) <> maybe id (flip snoc) (csvExtraRep FormatXlsx)
|
||||
withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv)
|
||||
. maybe id (flip snoc) (csvExtraRep FormatXlsx)
|
||||
where
|
||||
csvExtraRep fmt = do
|
||||
DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode
|
||||
|
||||
@ -644,7 +644,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector
|
||||
|
||||
let getQueuedJobs = selectSource [] []
|
||||
updateQueuedJob (Entity jId QueuedJob{..}) = maybeT (return ()) $ do
|
||||
updateQueuedJob (Entity jId QueuedJob{..}) = maybeT_ $ do
|
||||
(content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent
|
||||
let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content'
|
||||
guard $ uContent' /= content'
|
||||
|
||||
@ -371,7 +371,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) ()
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT (return ()) $ do
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT_ $ do
|
||||
stCID <- encryptWorkflowStateIndex wwId stIx
|
||||
|
||||
rScope <- hoistMaybe $ res ^. resultRouteScope
|
||||
|
||||
@ -121,7 +121,7 @@ workflowR rScope cID = do
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT (return ()) $ do
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT_ $ do
|
||||
mAuthId <- maybeAuthId
|
||||
|
||||
stCID <- encryptWorkflowStateIndex wwId stIx
|
||||
|
||||
@ -617,7 +617,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
|
||||
E.where_ $ matchesPrewarmSource eRef jcPrewarmSource
|
||||
return cRef
|
||||
sinkChunkCache lh (cRef, (c, range)) = insertLRUHandle lh (cRef, range) jcTargetTime (c, ByteString.length c)
|
||||
handleCmd JobCtlInhibitInject{..} = maybeT (return ()) $ do
|
||||
handleCmd JobCtlInhibitInject{..} = maybeT_ $ do
|
||||
PrewarmCacheConf{..} <- MaybeT . getsYesod $ view _appFileSourcePrewarmConf
|
||||
let inhibitInterval = IntervalMap.ClosedInterval
|
||||
(addUTCTime (-precStart) jcTargetTime)
|
||||
|
||||
@ -20,6 +20,7 @@ import Handler.Utils.DateTime
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs.Handler.Intervals.Utils
|
||||
|
||||
@ -62,7 +63,7 @@ determineCrontab = execWriterT $ do
|
||||
|
||||
let
|
||||
tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
||||
tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT (return ()) $ do
|
||||
tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT_ $ do
|
||||
PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf
|
||||
|
||||
let
|
||||
@ -89,7 +90,7 @@ determineCrontab = execWriterT $ do
|
||||
| ts' <- iterate (addUTCTime step') $ addUTCTime (subtract precStart . realToFrac $ toRational (precStart - precEnd) * (1 - recip precMaxSpeedup)) jcTargetTime
|
||||
]
|
||||
|
||||
lift . maybeT (return ()) $ do
|
||||
lift . maybeT_ $ do
|
||||
injectInterval <- fmap abs . MaybeT . getsYesod $ view _appInjectFiles
|
||||
tell $ HashMap.singleton
|
||||
JobCtlInhibitInject{..}
|
||||
@ -117,7 +118,7 @@ determineCrontab = execWriterT $ do
|
||||
for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> do
|
||||
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetHint) hFrom
|
||||
|
||||
when (isn't _JobsOffload appJobMode) . maybeT (return ()) $ do
|
||||
when (isn't _JobsOffload appJobMode) . maybeT_ $ do
|
||||
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom
|
||||
guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom)
|
||||
(fmap not . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet])
|
||||
@ -133,7 +134,7 @@ determineCrontab = execWriterT $ do
|
||||
for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> do
|
||||
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetSolution) sFrom
|
||||
|
||||
when (isn't _JobsOffload appJobMode) . maybeT (return ()) $ do
|
||||
when (isn't _JobsOffload appJobMode) . maybeT_ $ do
|
||||
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom
|
||||
guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]
|
||||
tell $ HashMap.singleton
|
||||
@ -386,6 +387,28 @@ determineCrontab = execWriterT $ do
|
||||
)
|
||||
.| C.fold collateSubmissionsByCorrector Map.empty
|
||||
|
||||
submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification
|
||||
whenIsJust submissionRatedNotificationsSince $ \notifySince
|
||||
-> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ sqlSubmissionRatingDone submission
|
||||
E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince
|
||||
return (submission, sheet E.^. SheetType)
|
||||
submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
|
||||
examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
|
||||
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
||||
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
||||
return examFinished
|
||||
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
|
||||
, cronRepeat = CronRepeatNever
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = Left appNotificationExpiration
|
||||
}
|
||||
in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
|
||||
|
||||
let
|
||||
examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||
|
||||
@ -268,7 +268,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
|
||||
|
||||
|
||||
dispatchJobInjectFiles :: JobHandler UniWorX
|
||||
dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
|
||||
dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do
|
||||
uploadBucket <- getsYesod $ view _appUploadCacheBucket
|
||||
interval <- getsYesod $ view _appInjectFiles
|
||||
|
||||
@ -338,7 +338,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
|
||||
Just <$> waitAsync dbAsync
|
||||
let matchesFRef = is _Just $ assertM (== fRef) fRef'
|
||||
if | matchesFRef ->
|
||||
maybeT (return ()) . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj
|
||||
maybeT_ . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj
|
||||
| otherwise ->
|
||||
$logErrorS "InjectFiles" [st|Minio object “#{obj}”'s content does not match it's name (content hash: #{tshow fRef'} /= name hash: #{tshow fRef})|]
|
||||
return . bool mempty (Sum 1, Sum sz) $ is _Just fRef'
|
||||
|
||||
@ -14,29 +14,34 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc) <- liftHandler . runDB $ do
|
||||
dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do
|
||||
submission@Submission{submissionRatingBy} <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
sheet@Sheet{sheetName} <- belongsToJust submissionSheet submission
|
||||
course@Course{..} <- belongsToJust sheetCourse sheet
|
||||
corrector <- traverse getJust submissionRatingBy
|
||||
sheetTypeDesc <- sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
|
||||
return (course, sheet, submission, corrector, sheetTypeDesc)
|
||||
csid <- encrypt nSubmission
|
||||
|
||||
whenIsJust corrector $ \corrector' ->
|
||||
addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector'
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
|
||||
hasAccess <- is _Authorized <$> evalAccessForDB (Just jRecipient) (CSubmissionR courseTerm courseSchool courseShorthand sheetName csid CorrectionR) False
|
||||
return (course, sheet, submission, corrector, sheetTypeDesc, hasAccess, csid)
|
||||
|
||||
csid <- encrypt nSubmission
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
|
||||
let tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
guard hasAccess
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
lift . userMailT jRecipient $ do
|
||||
whenIsJust corrector $ \corrector' ->
|
||||
addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector'
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
|
||||
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
|
||||
let tid = courseTerm
|
||||
ssh = courseSchool
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
module Model.Migration
|
||||
( migrateAll
|
||||
, requiresMigration
|
||||
, ManualMigration(..), getMigrationTime
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding (Max(..), Last(..))
|
||||
@ -184,3 +185,11 @@ getMissingMigrations = do
|
||||
E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF
|
||||
return $ appliedMigration E.^. AppliedMigrationMigration
|
||||
return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
||||
|
||||
getMigrationTime :: ( MonadIO m
|
||||
, BaseBackend backend ~ SqlBackend
|
||||
, PersistStoreRead backend
|
||||
)
|
||||
=> ManualMigration
|
||||
-> ReaderT backend m (Maybe UTCTime)
|
||||
getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey
|
||||
|
||||
@ -101,6 +101,7 @@ data ManualMigration
|
||||
| Migration20210115ExamPartsFrom
|
||||
| Migration20210201SharedWorkflowGraphs
|
||||
| Migration20210208StudyFeaturesRelevanceCachedUUIDs
|
||||
| Migration20210318CrontabSubmissionRatedNotification
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -142,6 +143,7 @@ migrateManual = do
|
||||
, ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)")
|
||||
, ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" )
|
||||
, ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" )
|
||||
, ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" )
|
||||
]
|
||||
where
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
@ -1042,6 +1044,9 @@ customMigrations = mapF $ \case
|
||||
ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached";
|
||||
|]
|
||||
|
||||
-- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected
|
||||
Migration20210318CrontabSubmissionRatedNotification -> return ()
|
||||
|
||||
|
||||
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
||||
tableExists table = do
|
||||
|
||||
@ -993,7 +993,7 @@ maxLength l = not . minLength (succ l)
|
||||
tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
|
||||
tellM = tell <=< lift
|
||||
|
||||
tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
|
||||
tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
|
||||
tellPoint = tell . opoint
|
||||
|
||||
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
|
||||
|
||||
@ -216,7 +216,7 @@ replaceFileReferences' mkFilter residual = do
|
||||
= modify $ Map.mapMaybe (assertM' (not . Set.null) . (\\ sfIds))
|
||||
| otherwise = do
|
||||
let fRef' = _FileReference # (fRef, residual)
|
||||
forM_ (persistUniqueKeys fRef') $ \u -> maybeT (return ()) $ do
|
||||
forM_ (persistUniqueKeys fRef') $ \u -> maybeT_ $ do
|
||||
Entity cKey cVal <- MaybeT . lift $ getBy u
|
||||
deleted <- lift . lift . deleteWhereCount $ resFilter <> [ persistIdField ==. cKey ]
|
||||
unless (deleted == 1) $
|
||||
|
||||
@ -2,9 +2,9 @@ $newline never
|
||||
|
||||
_{MsgCorrectionInvisibleWarning}
|
||||
|
||||
$if not (null correctionInvisibleReasons)
|
||||
$if not (null reasons)
|
||||
<br />
|
||||
_{MsgCorrectionInvisibleReasons}
|
||||
<ul>
|
||||
$forall reason <- correctionInvisibleReasons
|
||||
$forall reason <- reasons
|
||||
<li>_{reason}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user