From f9b545952d29701e128fcf77d379a51a69c08f33 Mon Sep 17 00:00:00 2001
From: Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
Date: Wed, 24 Mar 2021 11:44:55 +0100
Subject: [PATCH] chore: disable accept button for failing results

---
 src/Handler/Exam/AutoOccurrence.hs | 10 +++++++---
 src/Utils/Form.hs                  |  8 ++++++--
 2 files changed, 13 insertions(+), 5 deletions(-)

diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs
index c8fc15398..933fd3db3 100644
--- a/src/Handler/Exam/AutoOccurrence.hs
+++ b/src/Handler/Exam/AutoOccurrence.hs
@@ -26,6 +26,7 @@ makeLenses_ ''ExamAutoOccurrenceCalculateForm
 data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
   { eaofMapping    :: ExamOccurrenceMapping ExamOccurrenceId
   , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
+  , eaofSuccess :: Bool
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -153,7 +154,9 @@ examAutoOccurrenceIgnoreRoomsForm occId calculateRes protoForm html = do
 examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
 examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
   (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
-  (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty
+  let fs :: FieldSettings UniWorX
+      fs = (if maybe False eaofSuccess confirmData then id else set _fsAttrs [("disabled", "")]) ""
+  (acceptRes, acceptView) <- buttonForm'' [BtnExamAutoOccurrenceAccept] fs mempty
   return (acceptRes *> confirmDataRes, toWidget html <> fvWidget confirmDataView <> acceptView)
 
 
@@ -199,7 +202,7 @@ postEAutoOccurrenceR tid ssh csh examn = do
 
   calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do
     let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
-    (eaofMapping, eaofAssignment) <- case autoOccurrenceResult of
+    (eaofMapping, eaofAssignment, eaofSuccess) <- case autoOccurrenceResult of
       (Left e) -> do
         addMessageI Error e
         pure ( ExamOccurrenceMapping {
@@ -207,8 +210,9 @@ postEAutoOccurrenceR tid ssh csh examn = do
               examOccurrenceMappingMapping = Map.empty
             }
            , Map.map (view _2) participants'
+           , False
            )
-      (Right r) -> pure r
+      (Right res) -> pure $ uncurry (,,True) res
     return $ Just ExamAutoOccurrenceAcceptForm{..}
 
   ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 6bbdf33bd..4f28d482d 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -415,8 +415,12 @@ buttonForm = buttonForm' universeF
 
 -- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass
 buttonForm' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
-buttonForm' btns csrf = do
-  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
+buttonForm' btns = buttonForm'' btns ""
+
+-- | like `buttonForm'`, but for a given list of FieldSettings
+buttonForm'' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> FieldSettings (HandlerSite m) -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
+buttonForm'' btns settings csrf = do
+  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns settings
   return (res, [whamlet|
       $newline never
       #{csrf}