Generic and "safe" deletion widget

messages/uniworx/de.msg

@@ -74,6 +74,8 @@ CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
 CourseFilterSearch: Volltext-Suche
 CourseFilterRegistered: Registriert
+CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
+CourseDeleted: Kurs gelöscht
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@@ -89,10 +91,12 @@ SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand
 SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
 SheetEditOk        tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
 SheetNameDup       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
-SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
-SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
+SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
 SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
 
+SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
+SheetDeleted: Übungsblatt gelöscht
+
 SheetUploadMode: Abgabe von Dateien
 SheetSubmissionMode: Abgabe-Modus
 SheetExercise: Aufgabenstellung
@@ -545,17 +549,19 @@ MenuCorrections: Abgaben
 MenuSheetNew: Neues Übungsblatt anlegen
 MenuCourseEdit: Kurs editieren
 MenuCourseNewTemplate: Als neuen Kurs klonen
+MenuCourseDelete: Kurs löschen
 MenuSubmissionNew: Abgabe anlegen
 MenuSubmissionOwn: Abgabe
 MenuCorrectors: Korrektoren
 MenuSheetEdit: Übungsblatt editieren
+MenuSheetDelete: Übungsblatt löschen
 MenuCorrectionsUpload: Korrekturen hochladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben bewerten
 
 AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
-AuthTagFree: Seite ist generell zugänglich
+AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
 AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
 AuthTagDeprecated: Seite ist nicht überholt
@@ -573,4 +579,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
 AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
 AuthTagRead: Zugriff ist nur lesend
-AuthTagWrite: Zugriff ist i.A. schreibend
+AuthTagWrite: Zugriff ist i.A. schreibend
+
+DeleteCopyStringIfSure count@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE count "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
+DeleteConfirmation: Bestätigung
+DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.

src/Data/CaseInsensitive/Instances.hs

@@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI
 import Database.Persist.Sql
 
 import Text.Blaze (ToMarkup(..))
+import Text.Shakespeare.Text (ToText(..))
 
 import Data.Text (Text)
 import qualified Data.Text.Encoding as Text
@@ -63,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where
   toMarkup = toMarkup . CI.original
   preEscapedToMarkup = preEscapedToMarkup . CI.original
 
+instance ToText a => ToText (CI a) where
+  toText = toText . CI.original
+
 instance ToWidget site a => ToWidget site (CI a) where
   toWidget = toWidget . CI.original
 

src/Foundation.hs

@@ -146,6 +146,15 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
 pattern CSubmissionR tid ssh csh shn cid ptn
   = CSheetR tid ssh csh shn (SubmissionR cid ptn)
 
+
+pluralDE :: Int -- ^ Count
+         -> Text -- ^ Singular
+         -> Text -- ^ Plural
+         -> Text
+pluralDE num singularForm pluralForm
+  | num == 1  = singularForm
+  | otherwise = pluralForm
+
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage "UniWorX" "messages/uniworx" "de"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
@@ -1197,6 +1206,14 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuCourseDelete
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CourseR tid ssh csh SheetListR) =
   [ MenuItem
@@ -1257,6 +1274,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuSheetDelete
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SSubsR) =
   [ MenuItem

src/Handler/Course.hs

@@ -6,6 +6,7 @@ import Utils.Lens
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
+import Handler.Utils.Delete
 
 -- import Data.Time
 import qualified Data.Text as T
@@ -386,10 +387,24 @@ pgCEditR isGetReq tid ssh csh = do
   courseEditHandler isGetReq $ courseToForm <$> course
 
 
-getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCDeleteR = error "TODO: implement getCDeleteR"
-postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-postCDeleteR = error "TODO: implement getCDeleteR"
+getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCDeleteR = postCDeleteR
+postCDeleteR tid ssh csh = do
+  Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  deleteR DeleteRoute
+    { drRecords = Set.singleton cId
+    , drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do
+        School{schoolName} <- getJust courseSchool
+        return [whamlet|
+          #{courseName} (_{SomeMessage $ ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName})
+        |]
+    , drRecordConfirmString = \(Entity _ Course{courseShorthand, courseTerm, courseSchool}) -> 
+        return [st|#{unSchoolKey courseSchool}/#{termToText (unTermKey courseTerm)}/#{courseShorthand}|]
+    , drCaption = SomeMessage MsgCourseDeleteQuestion
+    , drSuccessMessage = SomeMessage MsgCourseDeleted
+    , drAbort = SomeRoute $ CourseR tid ssh csh CShowR
+    , drSuccess = SomeRoute CourseListR
+    }
 {- TODO
         | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
         , Just cid <- cfCourseId res -> do

src/Handler/Sheet.hs

@@ -7,6 +7,7 @@ import Handler.Utils
 -- import Handler.Utils.Zip
 import Handler.Utils.Table.Cells
 import Handler.Utils.SheetType
+import Handler.Utils.Delete
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -528,30 +529,26 @@ handleSheetEdit tid ssh csh msId template dbAction = do
     $(widgetFile "formPageI18n")
 
 
-
-getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-getSDelR tid ssh csh shn = do
-  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
-  case result of
-    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
-    (FormSuccess BtnDelete) -> do
-      runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
-      -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
-      redirect $ CourseR tid ssh csh SheetListR
-    _other -> do
-      submissionno <- runDB $ do
-          sid <- fetchSheetId tid ssh csh shn
-          count [SubmissionSheet ==. sid]
-      let formText  = Just $ MsgSheetDelText submissionno
-      let actionUrl = CSheetR tid ssh csh shn SDelR
-      defaultLayout $ do
-        setTitleI $ MsgSheetTitle tid ssh csh shn
-        $(widgetFile "formPageI18n")
-
-postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-postSDelR = getSDelR
-
+getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSDelR = postSDelR
+postSDelR tid ssh csh shn = do
+  sid <- runDB $ fetchSheetId tid ssh csh shn
+  deleteR DeleteRoute
+    { drRecords = Set.singleton sid
+    , drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
+        Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse
+        School{schoolName} <- getJust courseSchool
+        return [whamlet|
+          #{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName})
+        |]
+    , drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
+        Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse
+        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|]
+    , drCaption = SomeMessage MsgSheetDeleteQuestion
+    , drSuccessMessage = SomeMessage MsgSheetDeleted
+    , drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
+    , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
+    }
 
 
 insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()

src/Handler/SystemMessage.hs

@@ -59,7 +59,7 @@ postMessageR cID = do
                   <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
                   <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
               )
-          <*> combinedButtonField (universeF :: [BtnSubmitDelete])
+          <*> combinedButtonFieldF ""
 
       let modifyTranss = Map.map (view $ _1._1) modifyTranss'
 

src/Handler/Utils/Delete.hs

@@ -0,0 +1,73 @@
+module Handler.Utils.Delete
+  ( DeleteRoute(..)
+  , deleteR
+  ) where
+
+import Import
+import Handler.Utils.Form
+
+import Utils.Lens
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Random
+import System.Random (mkStdGen)
+import System.Random.Shuffle (shuffleM)
+import qualified Crypto.Hash as Crypto (hash)
+import Crypto.Hash (Digest, SHAKE128)
+
+import qualified Data.ByteArray as ByteArray
+
+
+data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute
+  { drRecords :: Set (Key record)
+  , drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+  , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
+  , drCaption
+  , drSuccessMessage :: SomeMessage UniWorX
+  , drAbort
+  , drSuccess :: SomeRoute UniWorX
+  }
+
+
+deleteR :: DeleteRoute -> Handler Html
+deleteR DeleteRoute{..} = do
+  targets <- runDB . mconcatForM drRecords $ \rKey -> do
+    ent <- Entity rKey <$> get404 rKey
+    recordWdgt <- drRenderRecord ent
+    recordConfirmString <- drRecordConfirmString ent
+    return $ pure (recordWdgt, recordConfirmString)
+
+  cIDKey <- hash . (ByteArray.convert :: Digest (SHAKE128 64) -> ByteString) . Crypto.hash <$> getsYesod appCryptoIDKey
+
+  let sTargets = evalRand (shuffleM targets) . mkStdGen . hashWithSalt cIDKey $ Set.toList drRecords
+      confirmString = Text.unlines $ map (Text.strip . view _2) sTargets
+      confirmField
+        | Set.size drRecords <= 1 = textField
+        | otherwise = convertField unTextarea Textarea textareaField
+  
+  ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,)
+    <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
+    <*> combinedButtonFieldF ""
+
+  formResult deleteFormRes $ \case
+    (_, catMaybes -> [BtnAbort]) ->
+      redirect drAbort
+    (inpConfirmStr, catMaybes -> [BtnDelete])
+      | ((==) `on` map CI.mk . Text.words) confirmString inpConfirmStr
+        -> do
+          runDB $ do
+            forM_ drRecords deleteCascade
+            addMessageI Success drSuccessMessage
+          redirect drSuccess
+      | otherwise
+        -> addMessageI Error MsgDeleteConfirmationWrong
+    _other -> return ()
+
+  Just targetRoute <- getCurrentRoute
+  
+  defaultLayout
+    $(widgetFile "widgets/delete-confirmation")

src/Handler/Utils/Form.hs

@@ -56,6 +56,9 @@ import Data.Aeson.Text (encodeToLazyText)
 data BtnDelete = BtnDelete | BtnAbort
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
+instance Universe BtnDelete
+instance Finite BtnDelete
+
 instance PathPiece BtnDelete where    -- for displaying the button only, not really for paths
   toPathPiece   = showToPathPiece
   fromPathPiece = readFromPathPiece

src/Utils.hs

@@ -498,6 +498,12 @@ partitionM crit = ofoldlM dist mempty
         | okay ->      acc `mappend` (opoint x, mempty)
         | otherwise -> acc `mappend` (mempty, opoint x)
 
+mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
+mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
+
+mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
+mconcatForM = flip mconcatMapM
+
 
 --------------
 -- Sessions --

src/Utils/Form.hs

@@ -172,6 +172,7 @@ data FormIdentifier
   | FIDSystemMessageAddTranslation
   | FIDDBTableFilter
   | FIDDBTablePagesize
+  | FIDDelete
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -230,13 +231,30 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
       | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
 
-combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
-combinedButtonField = traverse b2f
-  where
-    b2f b = aopt (buttonField b) "" Nothing
+combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonField bs FieldSettings{..} = formToAForm $ do
+  mr <- getMessageRender
+  fvId <- maybe newIdent return fsId
+  name <- maybe newIdent return fsName
+  (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
+                                                                      , fsName = Just $ name <> "__" <> toPathPiece b
+                                                                      }) Nothing
+  return ( sequenceA ress
+         , pure FieldView
+             { fvLabel = toHtml $ mr fsLabel
+             , fvTooltip = fmap (toHtml . mr) fsTooltip
+             , fvId
+             , fvInput = foldMap fvInput fvs
+             , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
+             , fvRequired = False
+             }
+         )
+
+combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonFieldF = combinedButtonField (universeF :: [a])
 
 submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
-submitButton = void $ combinedButtonField [BtnSubmit]
+submitButton = void $ combinedButtonField [BtnSubmit] ""
 
 autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
 autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing

templates/widgets/delete-confirmation.hamlet

@@ -0,0 +1,13 @@
+<p>_{drCaption}
+<ul>
+  $forall (wdgt, _) <- sTargets
+    <li>
+      ^{wdgt}
+
+<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
+
+<p .confirmationText>
+  #{confirmString}
+
+<form method=POST action=@{targetRoute} enctype=#{deleteFormEnctype}>
+  ^{deleteFormWdgt}

templates/widgets/delete-confirmation.lucius

@@ -0,0 +1,5 @@
+.confirmationText {
+    white-space: pre-wrap;
+    font-size: 14px;
+    font-family: monospace;
+}