fix(number-input-fields): number inputs made HTML5 compatible

number inputs of rational fields allow rational inputs and optionally
provide min-max attributes for HTML5

Closes #412

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

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

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 limit = pointsFieldMinMax (Just 0) limit
-pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
+
+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

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)

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
-          <input id=#{theId} name=#{name} *{attrs} type=number :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
+          <input id=#{theId} name=#{name} *{attrs} type=number step=any :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
         |]
     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
-          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :isReq:required value=#{either id (pack . showFixed True) val}>
+          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :hasMin:min="#{showF vMin}" :hasMax:max="#{showF vMax}" :isReq:required value=#{either id (pack . showFixed True) val}>
         |]
     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