diff --git a/.hlint.yaml b/.hlint.yaml index d85663f7a..c499a227c 100644 --- a/.hlint.yaml +++ b/.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 } diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 1d1ab7717..6c9a8369b 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index 93f3a0179..046a4c33b 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/src/Handler/Allocation/AddUser.hs @@ -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 diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs index 8e4987be4..156aaa091 100644 --- a/src/Handler/ExternalExam/Correct.hs +++ b/src/Handler/ExternalExam/Correct.hs @@ -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 diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 9c00514ae..059606809 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -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 diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 5c12dcfc2..59adad1c1 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -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 diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index f47afda21..f0fe0f853 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -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") diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index 03fcbd738..28d723bb8 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 1627a2f51..adddb8c79 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index fa6a8ac43..8cae1f08b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index cfd159c74..ca64817a8 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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' diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index adbd79d95..7417af3b2 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -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 diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index f185340c8..a0b024330 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 02f207bf6..c58b9f444 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -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) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index d96247af0..c6f6abc9a 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index f4e06a475..ecf6a2924 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -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' diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 06e0073c2..493a72e25 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -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)) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index ea88dbbdc..72b13b3ab 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -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 diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index adf98575d..c0fb48b78 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index e2a820d87..c78b3e337 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 () diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index fb8c340dc..1e3ebb620 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -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) $ diff --git a/templates/submission-correction-invisible.hamlet b/templates/submission-correction-invisible.hamlet index c9e7c92f2..6bf31659f 100644 --- a/templates/submission-correction-invisible.hamlet +++ b/templates/submission-correction-invisible.hamlet @@ -2,9 +2,9 @@ $newline never _{MsgCorrectionInvisibleWarning} -$if not (null correctionInvisibleReasons) +$if not (null reasons)
_{MsgCorrectionInvisibleReasons}