From cabecec99d38467543982bc67c27e06a168f737d Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Tue, 17 Jan 2023 18:45:06 +0100
Subject: [PATCH] chore(avs): preparations for avs synch confirmation

---
 src/Handler/Admin/Avs.hs                      |  1 -
 src/Handler/Admin/Test.hs                     |  3 ++
 src/Handler/LMS.hs                            |  3 +-
 src/Utils/Form.hs                             | 30 ++++++++++++++++---
 src/Utils/Frontend/Modal.hs                   | 14 ++++++++-
 templates/i18n/admin-test/de-de-formal.hamlet |  5 ++++
 6 files changed, 48 insertions(+), 8 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 8f1ecd254..d06081f09 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -100,7 +100,6 @@ validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
-
 avsLicenceOptions :: OptionList AvsLicence
 avsLicenceOptions = mkOptionList
   [ Option
diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs
index 3b077240e..77b1da476 100644
--- a/src/Handler/Admin/Test.hs
+++ b/src/Handler/Admin/Test.hs
@@ -214,6 +214,9 @@ postAdminTestR = do
   testHamlet1 <- withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
   --let testHamlet2 = $(i18nHamletFile "test")
   let testHamlet2 = testHamlet1
+      btnModalText = [whamlet|<button type="button" class=#{unwords $ map toPathPiece [BCIsButton, BCDanger]}>
+                                Button-Modal
+                     |]
 
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index 133c5fa4f..f1e37c3fa 100644
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@@ -594,8 +594,7 @@ postLmsR sid qsh = do
       when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal       numExaminees
       when (isNotifyAct action)   $ addMessageI Success $ MsgLmsNotificationSend numExaminees
       when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
-      redirect currentRoute
-    
+      redirect currentRoute    
 
   let heading = citext2widget $ qualificationName quali
   siteLayout heading $ do
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index c4e38bd5a..3878aa51e 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -303,6 +303,7 @@ data FormIdentifier
   | FIDAvsQueryLicenceDiffs
   | FIDAvsQueryLicence
   | FIDAvsSetLicence
+  | FIDAvsRemoveLicences
   | FIDLmsLetter
   | FIDAbsUnknownLicences
   deriving (Eq, Ord, Read, Show)
@@ -570,9 +571,9 @@ runButtonFormHash (hash -> hVal) fid = do
       hForm = aopt hiddenField "" $ Just $ Just hVal      
   ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> 
     flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
-  let btnForm = wrapForm btnWdgt def  { formAction = SomeRoute <$> currentRoute
-                                      , formEncoding = btnEnctype
-                                      , formSubmit = FormNoSubmit
+  let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
+                                      , formEncoding  = btnEnctype
+                                      , formSubmit    = FormNoSubmit
                                       }
   res <- formResultMaybe btnResult $ \case 
     (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
@@ -582,8 +583,29 @@ runButtonFormHash (hash -> hVal) fid = do
       return Nothing
   return (btnForm, res)
 
+-- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
+runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site                    
+                      , Button site ButtonSubmit, Button site a, Hashable h)
+  => h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
+runButtonFormHash' (hash -> hVal) btns fid = do
+  currentRoute <- getCurrentRoute
+  let bForm = disambiguateButtons $ combinedButtonField btns ""
+      hForm = aopt hiddenField "" $ Just $ Just hVal      
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> 
+    flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
+  let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
+                                      , formEncoding  = btnEnctype
+                                      , formSubmit    = FormNoSubmit
+                                      }
+  res <- formResultMaybe btnResult $ \case 
+    (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
+    _ -> do 
+      addMessageI Error MsgBtnFormOutdated 
+      whenIsJust currentRoute redirect                    -- redirect is needed to reset hidden-field value
+      return Nothing
+  return (btnForm, res)
 
-
+  
 -------------------
 -- Custom Fields --
 -------------------
diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs
index f78cc51bb..8709b7314 100644
--- a/src/Utils/Frontend/Modal.hs
+++ b/src/Utils/Frontend/Modal.hs
@@ -5,7 +5,7 @@
 module Utils.Frontend.Modal
   ( Modal(..)
   , customModal
-  , modal, msgModal
+  , modal, btnModal, msgModal
   , addMessageModal
   ) where
 
@@ -14,6 +14,7 @@ import ClassyPrelude.Yesod
 import Control.Lens
 import Utils.Route
 import Utils.Message
+import Utils.Form (ButtonClass())
 
 import Settings (widgetFile)
 
@@ -47,6 +48,17 @@ modal modalTrigger' modalContent = customModal Modal{..}
     modalId = Nothing
     modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
 
+-- | Variant of `modal` that looks like a button
+btnModal :: (PathPiece (ButtonClass site))
+      => Text                                         -- ^ Button Text       
+      -> [ButtonClass site]                           -- ^ Button class 
+      -> Either (SomeRoute site) (WidgetFor site ())  -- ^ Modal contant: either dynamic link or static widget
+      -> WidgetFor site ()                            -- ^ result widget
+btnModal btl bcs = modal fakeBtn 
+  where 
+    fakeBtn = [whamlet|<button :not (onull bcs):class=#{unwords $ map toPathPiece bcs}>
+                #{btl}
+              |]
 
 -- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions)
 msgModal :: WidgetFor site ()
diff --git a/templates/i18n/admin-test/de-de-formal.hamlet b/templates/i18n/admin-test/de-de-formal.hamlet
index 7ac34700c..59b560330 100644
--- a/templates/i18n/admin-test/de-de-formal.hamlet
+++ b/templates/i18n/admin-test/de-de-formal.hamlet
@@ -69,6 +69,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <li>^{modal "Klick mich für Ajax-Test" (Left $ SomeRoute UsersR)}
         <li>^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
         <li>^{modal "Email-Test" (Right emailWidget')}
+    <li>
+      Modal as button 
+      <ul>
+        <li>^{modal btnModalText (Right "Noch ein Test-Inhalt für ein Button Modal")}
+        <li>^{btnModal "Another Button" [BCIsButton, BCDanger] (Right "anderer Text")}
     <li>
       Some icons: ^{isVisible False} ^{hasComment True}