From 54e94a667027548056a12139ac96512fc4609911 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:01:32 +0200 Subject: [PATCH] feat(exams): re-introduce ExamBonusManual --- messages/uniworx/de.msg | 2 ++ src/Application.hs | 16 ++++++++-- src/Handler/Exam/Users.hs | 49 +++++++++++++++--------------- src/Handler/Utils/Exam.hs | 10 +++--- src/Handler/Utils/Form.hs | 10 ++++-- src/Model/Types/Exam.hs | 5 ++- templates/widgets/bonusRule.hamlet | 2 ++ 7 files changed, 60 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 41e50c599..bee90fb85 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1348,6 +1348,7 @@ ExamBonus: Bonuspunkte-System ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamBonusManual': Manuelle Berechnung ExamBonusAchieved: Bonuspunkte @@ -1417,6 +1418,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet ExamNoShow: Nicht erschienen ExamVoided: Entwertet +ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist diff --git a/src/Application.hs b/src/Application.hs index 1181b9a9f..294e1a206 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettingsSocket, setHost, + runSettings, runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) import Data.Streaming.Network (bindPortTCP) @@ -74,7 +74,7 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import System.Environment (lookupEnv) import System.Posix.Process (getProcessID) -import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) +import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT) import qualified System.Posix.Signals as Signals (Handler(..)) import Network.Socket (socketPort, Socket, PortNumber) @@ -82,6 +82,7 @@ import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay import Control.Monad.STM (retry) +import Control.Monad.Trans.Cont (runContT, callCC) import qualified Data.Set as Set @@ -366,8 +367,17 @@ develMain = runResourceT $ do wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation + let + awaitTermination :: IO () + awaitTermination + = flip runContT return . forever $ do + lift $ threadDelay 100e3 + whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $ + callCC ($ ()) + + void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing runAppLoggingT foundation $ handleJobs foundation - liftIO . develMainHelper $ return (wsettings, app) + void . liftIO $ awaitTermination `race` runSettings wsettings app -- | The @main@ function for an executable running this site. appMain :: forall m. MonadUnliftIO m => m () diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a7f4f71e0..121f430ff 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -160,7 +160,7 @@ resultCourseNote = _dbrOutput . _10 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points -resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> examBonusPossible uid examBonus' <*> examBonusAchieved uid examBonus') +resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade resultAutomaticExamResult exam examBonus' = folding . runReader $ do @@ -396,7 +396,7 @@ postEUsersR tid ssh csh examn = do allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - doBonus = is _Just examGradingRule || is _Just examBonusRule + doBonus = is _Just examBonusRule showPasses = doBonus && numSheetsPasses allBoni /= 0 showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 @@ -494,14 +494,14 @@ postEUsersR tid ssh csh examn = do , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus - SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) - , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus - SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus + in propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus + in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) @@ -612,10 +612,10 @@ postEUsersR tid ssh csh examn = do <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus) <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView @@ -645,7 +645,7 @@ postEUsersR tid ssh csh examn = do when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) - when (is _Just . join $ csvEUserBonus dbCsvNew) $ + when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ @@ -684,15 +684,16 @@ postEUsersR tid ssh csh examn = do newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView - case newBonus of - _ | newBonus == oldBonus - -> return () - _ | is _Nothing newBonus - -> return () - Nothing - -> yield $ ExamUserCsvSetBonusData False uid newBonus - Just _ - -> yield $ ExamUserCsvSetBonusData True uid newBonus + when doBonus $ + case newBonus of + _ | newBonus == oldBonus + -> return () + _ | is _Nothing newBonus + -> return () + Nothing + -> yield $ ExamUserCsvSetBonusData False uid newBonus + Just _ + -> yield $ ExamUserCsvSetBonusData True uid newBonus case newResult of _ | csvEUserExamResult dbCsvNew == oldResult diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 9f6bbe364..ec5d7f5d2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -78,12 +78,12 @@ examBonus (Entity eId Exam{..}) = runConduit $ ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> - Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints in rawData .| accum -examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary -examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap -examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap +examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap examResultBonus :: ExamBonusRule @@ -91,6 +91,8 @@ examResultBonus :: ExamBonusRule -> SheetGradeSummary -- ^ `examBonusAchieved` -> Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of + ExamBonusManual{} + -> 0 ExamBonusPoints{..} -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp where diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6556d1db7..2f8af499c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -520,7 +520,8 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] -data ExamBonusRule' = ExamBonusPoints' +data ExamBonusRule' = ExamBonusManual' + | ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' instance Finite ExamBonusRule' @@ -530,6 +531,7 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case + ExamBonusManual{} -> ExamBonusManual' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule @@ -537,7 +539,11 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList - [ ( ExamBonusPoints' + [ ( ExamBonusManual' + , ExamBonusManual + <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + ) + , ( ExamBonusPoints' , ExamBonusPoints <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 53d900584..1a3f3ec0d 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -116,7 +116,10 @@ instance Universe res => Universe (ExamResult' res) where instance Finite res => Finite (ExamResult' res) -data ExamBonusRule = ExamBonusPoints +data ExamBonusRule = ExamBonusManual + { bonusOnlyPassed :: Bool + } + | ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool , bonusRound :: Points diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index 3a5a2c775..1c59049c0 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,5 +1,7 @@ $newline never $case bonusRule + $of ExamBonusManual _ + _{MsgExamBonusManualParticipants} $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} $of ExamBonusPoints ps True _