fix(submissions): take care when to display corrections

Also cleanup usage of Utils via hlint

.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 }

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
+    cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
+    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
+      ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
-      Exam{..} <- $cachedHereBinary examPartExam . MaybeT $ get examPartExam
+      Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
       now <- liftIO getCurrentTime
       guard $ NTop (Just now) >= NTop examFinished
     return Authorized

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

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

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
+    [(Entity cId Course{}, Entity shId Sheet{..}, subEnt@(Entity _ subm@Submission{..}), corrector, E.Value filesCorrected)] -> do
-      sheetTypeDesc <- runDB $ sheetTypeDescription cId sheetType
+      (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

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
 

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
+    return (showCorrection, correctionInvisible)
-      | 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)
 
   -- 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")

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

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")

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

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'

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

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

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)

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

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'

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
+dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do
-  (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc) <- liftHandler . runDB $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do
     submission@Submission{submissionRatingBy} <- getJust nSubmission
-    sheet <- belongsToJust submissionSheet submission
+    sheet@Sheet{sheetName} <- belongsToJust submissionSheet submission
-    course <- belongsToJust sheetCourse sheet
+    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' ->
+    hasAccess <- is _Authorized <$> evalAccessForDB (Just jRecipient) (CSubmissionR courseTerm courseSchool courseShorthand sheetName csid CorrectionR) False
-    addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector'
+    return (course, sheet, submission, corrector, sheetTypeDesc, hasAccess, csid)
-  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-  setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
 
-  csid <- encrypt nSubmission
+  guard hasAccess
-  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
+  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))

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

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

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 ()

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) $

templates/submission-correction-invisible.hamlet

@@ -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}