Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

2018-10-24 16:44:59 +02:00 · 2018-10-24 16:44:59 +02:00 · a8262a4162
commit a8262a4162
parent 584fc4558e 3342daa0e8
5 changed files with 90 additions and 51 deletions
--- 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
--- 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)

--- 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]
--- 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{..})
--- 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