From 4f1b2886cdb60cdd0ac79fd0d008b685d98c743f Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Sun, 16 Jun 2019 13:16:01 +0200
Subject: [PATCH] guards added as needed for plan generartion without
 exceptions

---
 src/Handler/Corrections.hs      | 33 +++++++++++++++++++++++++--------
 src/Handler/Utils/Submission.hs |  1 +
 src/Utils.hs                    | 13 +++++++++++++
 3 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 6a9c1b7aa..a251ddf56 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -1164,14 +1164,29 @@ assignHandler tid ssh csh cid assignSids = do
                             }
               in Map.insertWith (Map.unionWith (<>)) shnm cinf m
       -- plan or assign unassigned submissions for given sheets
-      -- assignment :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)
-      assignment <- fmap Map.fromList $ forM assignSids $ \sid -> do
-          plan <- planSubmissions sid Nothing
-          let shn = sheetName $ sheets ! sid
-          status <- case btnResult of
-            Nothing -> return (Set.empty, Set.empty)
-            (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan
-          return (shn, (status, countMapElems plan))
+      let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int))
+          buildA acc sid = maybeT (return acc) $ do
+            let shn = sheetName $ sheets ! sid
+            -- is sheet closed?
+            guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR  -- we must check, whether the submission is already closed and thus assignable
+            -- has at least one submisison?
+            [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission ->
+              E.where_ $ submission E.^. SubmissionSheet    E.==. E.val sid
+            guard hasSubmission
+            -- has at least one active corrector?
+            [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do
+              E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid
+              E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal
+              -- E.where_ $ corrector E.^. SheetCorrectorLoad  E./=. E.val (Load {byTutorial = Nothing, byProportion = 0})
+            guard hasCorrector
+            -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea
+            -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead!
+            plan <- lift $ planSubmissions sid Nothing
+            status <- lift $ case btnResult of
+              Nothing -> return (Set.empty, Set.empty)
+              (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan
+            return $ Map.insert shn (status, countMapElems plan) acc
+      assignment <- foldM buildA Map.empty assignSids
 
       return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
 
@@ -1194,6 +1209,8 @@ assignHandler tid ssh csh cid assignSids = do
       showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
       showAvgsDays Nothing   _ = mempty
       showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
+      heat :: Double -> Double -> Double
+      heat achieved full = roundToDigits 3 $ cutOffPercent 0.4 full achieved
   let headingShort = MsgMenuCorrectionsAssign
       headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
   siteLayoutMsg headingShort $ do
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 61bb7ee53..7cb28cfa5 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -86,6 +86,7 @@ writeSubmissionPlan newSubmissionData = do
         tell (mempty, Set.singleton subId)
 
 -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet!
+--   May throw an exception if there are no suitable correctors
 planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
                   -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
                   -> YesodDB UniWorX (Map SubmissionId (Maybe UserId))
diff --git a/src/Utils.hs b/src/Utils.hs
index da5d7f0c4..a6fa63d38 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -379,6 +379,19 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
 roundDiv digits numerator denominator
   = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
 
+-- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all
+--   `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved)
+--   Useful for heat maps, with offset giving a visual step between completed and not yet completed
+cutOffPercent :: Double -> Double -> Double -> Double
+cutOffPercent offset full achieved
+  | full <= achieved = 0
+  | full <= 0        = 0
+  | otherwise        = offset + (1-offset * (1 - percent))
+  where
+    percent = achieved / full
+
+
+
 ------------
 -- Monoid --
 ------------