fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exams): re-introduce ExamBonusManual

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-26 11:01:32 +02:00
parent c553414b38
commit 54e94a6670
7 changed files with 60 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

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

16
src/Application.hs
View File

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

49
src/Handler/Exam/Users.hs
View File

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

10
src/Handler/Utils/Exam.hs
View File

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

10
src/Handler/Utils/Form.hs
View File

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

5
src/Model/Types/Exam.hs
View File

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

2
templates/widgets/bonusRule.hamlet
View File

@ -1,5 +1,7 @@
$newline never
$case bonusRule
$of ExamBonusManual _
_{MsgExamBonusManualParticipants}
$of ExamBonusPoints ps False _
_{MsgExamBonusPoints ps}
$of ExamBonusPoints ps True _