From 62dd7b9f047e504db783b2ceef19307c21d5550b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Wed, 24 Jun 2020 14:01:52 +0200
Subject: [PATCH] fix(rating-files): support integral points values

Fixes #604
---
 src/Handler/Utils/Rating/Format.hs |  7 ++++++-
 src/Utils.hs                       |  3 +++
 src/Utils/Lens.hs                  |  2 +-
 test/Handler/Utils/RatingSpec.hs   | 10 +++++++++-
 4 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs
index b26e022fa..c0059c2f9 100644
--- a/src/Handler/Utils/Rating/Format.hs
+++ b/src/Handler/Utils/Rating/Format.hs
@@ -91,6 +91,8 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R
                 -> mempty
               | has (_passingBound . _Left) mode
                 -> mapEvents (str' "passed") (YAML.Scalar () . maybe YAML.SNull YAML.SBool $ gradingPassed mode =<< ratingPoints)
+              | Just ratingPoints' <- ratingPoints ^? _Just . _Integer
+                -> mapEvents (str' "points") (YAML.Scalar () $ YAML.SInt ratingPoints')
               | otherwise
                 -> mapEvents (str' "points") (YAML.Scalar () $ maybe YAML.SNull (YAML.SFloat . realToFrac) ratingPoints)
         , mapEvents (str' "rating_done") (YAML.Scalar () $ YAML.SBool ratingDone)
@@ -177,7 +179,10 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R
 instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (Maybe UTCTime -> Maybe Text -> (Rating', Maybe (Explicit.CryptoFileName ns))) where
   parseYAML = YAML.withMap "Rating'" $ \m -> do
     ratingDone <- m YAML..:? "rating_done" YAML..!= False
-    ratingPoints' <- fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points"
+    ratingPoints' <- asum
+      [ fmap (fromIntegral :: Integer -> Points) <$> m YAML..:? "points"
+      , fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points"
+      ]
     ratingPassed  <- fmap (bool 0 1) <$> m YAML..:? "passed"
     let ratingPoints = ratingPoints' <|> ratingPassed
         cIDNode = listToMaybe . Map.elems $ Map.filterWithKey isCIDNode m
diff --git a/src/Utils.hs b/src/Utils.hs
index 62b9f088f..8624748ab 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -359,6 +359,9 @@ cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
   where
     percent = achieved / full
 
+_Integer :: (RealFrac a, Integral b) => Prism' a b
+_Integer = prism' fromIntegral $ fmap (view _1) . assertM' (has $ _2 . only 0) . properFraction
+
 ------------
 -- Monoid --
 ------------
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 449ad431b..737f9d713 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -232,8 +232,8 @@ makeLenses_ ''ExternalExamOfficeSchool
 makeLenses_ ''ExternalExamStaff
 makeLenses_ ''ExternalExamResult
 
+makeLenses_ ''Rating
 makeLenses_ ''Rating'
-  
 
 -- makeClassy_ ''Load
 
diff --git a/test/Handler/Utils/RatingSpec.hs b/test/Handler/Utils/RatingSpec.hs
index 8c147006b..23b674f57 100644
--- a/test/Handler/Utils/RatingSpec.hs
+++ b/test/Handler/Utils/RatingSpec.hs
@@ -10,16 +10,24 @@ import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.Text as Text
 
-import Utils (assertM, MsgRendererS(..))
+import Utils (assertM, MsgRendererS(..), _Integer)
 import Text.Shakespeare.I18N (renderMessage)
 
+import Utils.Lens (_ratingValues, _ratingPoints)
+
 
 spec :: Spec
 spec = describe "Rating file parsing/pretty-printing" $ do
   it "roundtrips" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) ->
     parseRating' (formatRating mr' def subId rating) === Just (ratingValues rating)
+  it "roundtrips for integral points" . property $ \(_ :: SubmissionId, subId) (over (_ratingValues . _ratingPoints . _Just) (fromInteger . round) . mRating -> rating) ->
+    has (_ratingValues . _ratingPoints . _Just . _Integer) rating
+      ==> parseRating' (formatRating mr' def subId rating) === Just (ratingValues rating)
   it "has idempotent formatting" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) ->
     fmap (\r' -> formatRating mr' def subId $ rating { ratingValues = r' }) (parseRating' $ formatRating mr' def subId rating) === Just (formatRating mr' def subId rating)
+  it "has idempotent formatting for integral points" . property $ \(_ :: SubmissionId, subId) (over (_ratingValues . _ratingPoints . _Just) (fromInteger . round) . mRating -> rating) ->
+    has (_ratingValues . _ratingPoints . _Just . _Integer) rating
+      ==> fmap (\r' -> formatRating mr' def subId $ rating { ratingValues = r' }) (parseRating' $ formatRating mr' def subId rating) === Just (formatRating mr' def subId rating)
   where
     mr' :: forall site. MsgRendererS site
     mr' = MsgRenderer $ renderMessage (error "foundation inspected" :: site) []