diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b4e372c66..267c17687 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -449,6 +449,7 @@ RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{maxPoints} sein +PointsTooLow minPoints@Points: Punktzahl darf nicht kleiner als #{minPoints} sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist ColumnRatingPoints: Punktzahl Pseudonyms: Pseudonyme diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 28e3a095c..8e192e150 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -215,7 +215,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) - _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints) + _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f35c0a7c1..58ea2ffaf 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -241,30 +241,38 @@ htmlField' = htmlField } natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i -natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg intField +natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField +natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intMinField 0 natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer natIntField = natField posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField +posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") $ intMinField 1 posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i -posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg intField +posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg $ intMinField 0 -- | Field to request integral number > 'm' minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i -minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField +minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intMinField m pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points -pointsField = checkBool (>= 0) MsgPointsNotPositive fixedPrecField +pointsField = pointsFieldMinMax (Just 0) Nothing pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points -pointsFieldMax Nothing = pointsField -pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField +pointsFieldMax limit = pointsFieldMinMax (Just 0) limit + +pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points +pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet + where + checklower | Just 0 <- lower = checkBool (>= 0) MsgPointsNotPositive + | Just minp <- lower = checkBool (>= minp) $ MsgPointsTooLow minp + | otherwise = id + checkupper | Just maxp <- upper = checkBool (<= maxp) $ MsgPointsTooHigh maxp + | otherwise = id matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here @@ -358,7 +366,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp , UploadSpecific <$> specificFileForm ) ] - + extensionRestrictionField :: Field Handler (NonNull (Set Extension)) extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField where @@ -366,7 +374,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp stripDot ext | Just nExt <- Text.stripPrefix "." ext = nExt | otherwise = ext - + specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile)) specificFileForm = wFormToAForm $ do Just currentRoute <- getCurrentRoute @@ -377,7 +385,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp where preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile) preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable - + postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile))) postProcess mapResult = do MsgRenderer mr <- getMsgRenderer @@ -420,7 +428,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp miAddEmpty _ _ _ = Set.empty miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout") - + submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev @@ -524,7 +532,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas ) ] - + gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points] gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do MsgRenderer mr <- getMsgRenderer diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 2e980312f..6e6bebd02 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -67,6 +67,13 @@ validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) = [RatingBinaryExpected] +-- QUICKFIX: Vorkorrektur füllt keine Punkte ein und sollte trotzdem akzeptiert werden! +-- Alternative: Fehler fangen und ignorieren, falls der Benutzer Dozent/Assistent/Admin ist +-- validateRating ratingSheetType Rating'{ .. } +-- | has _grading ratingSheetType +-- , is _Nothing ratingPoints +-- , isn't _Nothing ratingTime +-- = [RatingPointsRequired] validateRating _ _ = [] getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8ada2cc6d..0129b8750 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -503,41 +503,64 @@ fractionalField = Field{..} where scientific' :: Iso' a Scientific scientific' = iso (fromRational . toRational) (fromRational . toRational) - + fieldEnctype = UrlEncoded fieldView theId name attrs (fmap $ view scientific' -> val) isReq = [whamlet| $newline never - + |] fieldParse = parseHelper $ \t -> - maybe (Left $ MsgInvalidNumber t) (Right . review scientific') (readMay t :: Maybe Scientific) + maybe (Left $ MsgInvalidNumber (t<>"HERE")) (Right . review scientific') (readMay t :: Maybe Scientific) fixedPrecField :: forall m p. ( Monad m , RenderMessage (HandlerSite m) FormMessage , HasResolution p ) => Field m (Fixed p) -fixedPrecField = Field{..} +fixedPrecField = fixedPrecMinMaxField Nothing Nothing + +fixedPrecMinMaxField :: forall m p. + ( Monad m + , RenderMessage (HandlerSite m) FormMessage + , HasResolution p + ) => Maybe (Fixed p) -> Maybe (Fixed p) -> Field m (Fixed p) +fixedPrecMinMaxField lower upper = Field{..} where resolution' :: Integer resolution' = resolution $ Proxy @p - step = showFixed True (fromRational $ 1 % resolution' :: Fixed p) - + showF = showFixed True + step = showFixed True (fromRational $ 1 % resolution' :: Fixed p) + fieldEnctype = UrlEncoded fieldView theId name attrs val isReq = [whamlet| $newline never - + |] fieldParse = parseHelper $ \t -> do sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific) return . fromRational $ round (sci * fromIntegral resolution') % resolution' + (hasMin, vMin) = maybe (False, 0) (True,) lower + (hasMax, vMax) = maybe (False, 0) (True,) upper + rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational rationalField = fractionalField +-- | Sepcify lower bound via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function) +intMinField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Field m i +intMinField lower = intMinMaxField (Just lower) Nothing + +-- | Sepcify lower/upper bounds via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function) +intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => Maybe i -> Maybe i -> Field m i +intMinMaxField lower upper = intF{ fieldView=newView } + where + intF@Field{ fieldView=oldView } = intField + newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq + newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ] + data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Exception SecretJSONFieldException