diff --git a/src/Cron.hs b/src/Cron.hs index a17230f15..2620aec12 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -165,37 +165,66 @@ nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry -> UTCTime -- ^ Current time, used only for `CronCalendar` -> Cron -> CronNextMatch UTCTime -nextCronMatch tz mPrev now c@Cron{..} - | isNothing mPrev - = execRef now False cronInitial - | Just prevT <- mPrev - = case cronRepeat of - CronRepeatOnChange - | not $ matchesCron tz Nothing prevT c - -> let - cutoffTime = addUTCTime cronRateLimit prevT - in case execRef now False cronInitial of - MatchAsap - | now < cutoffTime -> MatchAt cutoffTime - MatchAt ts - | ts < cutoffTime -> MatchAt cutoffTime - other -> other - CronRepeatScheduled cronNext - -> case cronNext of - CronAsap - | addUTCTime cronRateLimit prevT <= now - -> MatchAsap - | otherwise - -> MatchAt $ addUTCTime cronRateLimit prevT - cronNext - -> execRef (addUTCTime cronRateLimit prevT) True cronNext - _other -> MatchNone +nextCronMatch tz mPrev now c@Cron{..} = case notAfter of + MatchAsap -> MatchNone + MatchAt ts + | MatchAt ts' <- nextMatch + , ts' <= ts -> MatchAt ts' + | MatchAsap <- nextMatch + , now <= ts -> MatchAsap + | otherwise -> MatchNone + MatchNone -> nextMatch where - execRef ref wasExecd cronAbsolute = case cronAbsolute of - CronAsap -> MatchAsap + nextMatch = nextCronMatch' tz mPrev now c + notAfter + | Right c' <- cronNotAfter + , Just ref <- notAfterRef + = execRef' ref False c' + | Left diff <- cronNotAfter + , Just ref <- notAfterRef + = MatchAt $ diff `addUTCTime` ref + | otherwise = MatchNone + notAfterRef + | Just prevT <- mPrev = Just prevT + | otherwise = case execRef' now False cronInitial of + MatchAt t -> Just t + MatchNone -> Nothing + + nextCronMatch' tz mPrev now c@Cron{..} + | isNothing mPrev + = execRef now False cronInitial + | Just prevT <- mPrev + = case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + other -> other + CronRepeatScheduled cronNext + -> case cronNext of + CronAsap + | addUTCTime cronRateLimit prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronRateLimit prevT + cronNext + -> execRef (addUTCTime cronRateLimit prevT) True cronNext + _other -> MatchNone + + execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of + MatchAt t + | t <= ref -> MatchAsap + other -> other + + execRef' ref wasExecd cronAbsolute = case cronAbsolute of + CronAsap -> MatchAt ref CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } - | ref <= ts -> MatchAt ts - | not wasExecd -> MatchAsap + | ref <= ts || not wasExecd -> MatchAt ts | otherwise -> MatchNone CronCalendar{..} -> listToMatch $ do let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref @@ -213,6 +242,7 @@ nextCronMatch tz mPrev now c@Cron{..} localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) return $ localTimeToUTCTZ tz LocalTime{..} + CronNotScheduled -> MatchNone matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry -> Maybe UTCTime -- ^ Previous execution of the job diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index bb6753f73..fa95477f0 100644 --- a/src/Cron/Types.hs +++ b/src/Cron/Types.hs @@ -57,6 +57,7 @@ data Cron = Cron { cronInitial :: CronAbsolute , cronRepeat :: CronRepeat , cronRateLimit :: NominalDiffTime + , cronNotAfter :: Either NominalDiffTime CronAbsolute } deriving (Eq, Show) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 78ad460c8..9814f6d75 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -184,18 +184,23 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_ cell [whamlet|#{review pseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a)))) -colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell +colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b)))) +colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done)) + +colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b)))) +colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone) $ formCell (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of - NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints) - _other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) + NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) + _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) ) -colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text)))) +colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text)))) colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) @@ -497,11 +502,12 @@ postCorrectionR tid ssh csh shn cid = do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of - NotGraded -> bool Nothing (Just 0) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) - _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) + NotGraded -> pure Nothing + _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints) - ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) - <$> pointsForm + ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) + <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) + <*> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <* submitButton @@ -512,13 +518,11 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (ratingPoints, ratingComment) -> do + FormSuccess (rated, ratingPoints, ratingComment) -> do runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - let rated = isJust ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating - Submission{submissionRatingTime} <- getJust sub update sub [ SubmissionRatingBy =. (uid <$ guard rated) @@ -742,12 +746,13 @@ postCorrectionsGradeR = do , colPseudonyms , colSubmissionLink , colRated + , colRatedField , colPointsField , colCommentField ] -- Continue here psValidator = def - & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text))) - unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment) + & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) + unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do cID <- encrypt subId @@ -760,15 +765,14 @@ postCorrectionsGradeR = do FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess resMap -> do now <- liftIO getCurrentTime - subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (mPoints, mComment)) -> do - let mPoints' = either (bool Nothing $ return 0) return =<< mPoints - Submission{..} <- get404 subId + subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do + s@Submission{..} <- get404 subId if - | submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment - -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints' + | submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s + -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints , SubmissionRatingComment =. mComment , SubmissionRatingBy =. Just uid - , SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment) + , SubmissionRatingTime =. now <$ guard rated ] | otherwise -> return $ Nothing subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 361c6005b..9740ddda6 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -40,6 +40,7 @@ determineCrontab = execWriterT $ do { cronInitial = CronAsap , cronRepeat = CronRepeatScheduled CronAsap , cronRateLimit = interval + , cronNotAfter = Right CronNotScheduled } Nothing -> return () @@ -49,6 +50,7 @@ determineCrontab = execWriterT $ do { cronInitial = CronAsap , cronRepeat = CronRepeatScheduled CronAsap , cronRateLimit = appJobCronInterval + , cronNotAfter = Right CronNotScheduled } let @@ -59,6 +61,7 @@ determineCrontab = execWriterT $ do { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo } tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..}) @@ -66,6 +69,7 @@ determineCrontab = execWriterT $ do { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo , cronRepeat = CronRepeatOnChange , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo } tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..}) diff --git a/src/Model.hs b/src/Model.hs index 70f66d5d9..76a543723 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -51,4 +51,4 @@ data PWEntry = PWEntry $(deriveJSON defaultOptions ''PWEntry) submissionRatingDone :: Submission -> Bool -submissionRatingDone Submission{..} = isJust submissionRatingPoints +submissionRatingDone Submission{..} = isJust submissionRatingTime