140 lines
5.8 KiB
Haskell
140 lines
5.8 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-|
|
|
Module : Handler.Utils.Delete
|
|
Description : Generic deletion from database after confirmation
|
|
|
|
`postDeleteR`, `getDeleteR`, and `deleteR` provide handlers for calling
|
|
`deleteCascade` on a `Set` of Record-`Key`s after asking for confirmation, which
|
|
currently entails asking the user to copy a text, which is dependent on the
|
|
records to be deleted (i.e. a comma-separated list of user names), into a
|
|
`Textarea`.
|
|
-}
|
|
module Handler.Utils.Delete
|
|
( DeleteRoute(..)
|
|
, deleteR
|
|
, postDeleteR, getDeleteR
|
|
, JobDB
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.Memcached
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Char (isAlphaNum)
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect)
|
|
|
|
import Jobs.Queue
|
|
|
|
{-# ANN deleteR ("HLint: ignore Use const" :: String) #-}
|
|
|
|
|
|
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From tables) => DeleteRoute
|
|
{ drRecords :: Set (Key record) -- ^ Records to be deleted
|
|
, drGetInfo :: tables -> E.SqlQuery infoExpr -- ^ SQL-Query to get necessary information to render identifing information about records to the user (`drRenderRecord`, `drRecordConfirmString`); @tables@ is an arbitrary join, see `E.from`; @infoExpr@ gets converted to @info@ by esqueleto
|
|
, drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically
|
|
, drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
|
|
, drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
|
|
, drFormMessage :: [info] -> DB (Maybe Message)
|
|
, drCaption
|
|
, drSuccessMessage :: SomeMessage UniWorX
|
|
, drAbort
|
|
, drSuccess :: SomeRoute UniWorX
|
|
, drDelete :: forall a. Key record -> JobDB a -> JobDB a
|
|
}
|
|
|
|
confirmForm :: ( MonadHandler m, HandlerSite m ~ UniWorX )
|
|
=> Text -- ^ Confirmation string
|
|
-> AForm m Bool
|
|
confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelete) -> if
|
|
| ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
|
|
-> return $ pure True
|
|
| otherwise
|
|
-> formFailure [MsgDeleteConfirmationWrong]
|
|
where
|
|
aform = (,)
|
|
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
|
|
<*> pure BtnDelete
|
|
confirmField
|
|
| multiple = convertField unTextarea Textarea textareaField
|
|
| otherwise = textField
|
|
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
|
|
|
|
confirmFormReduced :: Monad m => AForm m Bool
|
|
confirmFormReduced = pure True
|
|
|
|
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Maybe Message -> Form Bool
|
|
confirmForm' drRecords confirmString mmsg = identifyForm FIDDelete . addDeleteTargets . renderAForm FormStandard . maybe id ((*>) . aformMessage) mmsg . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString
|
|
where
|
|
addDeleteTargets :: Form a -> Form a
|
|
addDeleteTargets form csrf = do
|
|
(_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
|
|
over _2 (mappend $ fvInput fvTargets) <$> form csrf
|
|
|
|
|
|
postDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend)
|
|
=> (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
|
|
-> Handler ()
|
|
-- | Perform deletion
|
|
postDeleteR mkRoute = do
|
|
drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
|
|
|
|
traverse_ deleteR' drResult
|
|
|
|
getDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend)
|
|
=> DeleteRoute record -> Handler a
|
|
getDeleteR = deleteR'
|
|
|
|
deleteR' :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend)
|
|
=> DeleteRoute record -> Handler a
|
|
deleteR' DeleteRoute{..} = do
|
|
(targets, confirmString, message) <- runDB $ do
|
|
infos <- E.select . E.from $ \t -> do
|
|
E.where_ $ drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords)
|
|
drGetInfo t
|
|
|
|
targets <- mapM (runKleisli $ Kleisli drRenderRecord &&& Kleisli drRecordConfirmString) infos
|
|
let confirmString = Text.unlines $ view _2 <$> targets
|
|
message <- drFormMessage infos
|
|
|
|
return (targets, confirmString, message)
|
|
|
|
((confirmRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost $ confirmForm' drRecords confirmString message
|
|
|
|
formResult confirmRes $ \case
|
|
True -> do
|
|
runDBJobs $ do
|
|
forM_ drRecords $ \k -> drDelete k $ delete k
|
|
memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences
|
|
addMessageI Success drSuccessMessage
|
|
redirect drSuccess
|
|
False ->
|
|
redirect drAbort
|
|
|
|
targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
|
|
let deleteForm = wrapForm' BtnDelete deleteFormWdgt def
|
|
{ formAction = Just $ SomeRoute targetRoute
|
|
, formEncoding = deleteFormEnctype
|
|
, formSubmit = FormSubmit
|
|
}
|
|
|
|
sendResponse =<<
|
|
defaultLayout $(widgetFile "widgets/delete-confirmation/delete-confirmation")
|
|
|
|
|
|
|
|
deleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend)
|
|
=> DeleteRoute record -> Handler Html
|
|
deleteR dr = do
|
|
postDeleteR $ \drRecords -> dr {drRecords}
|
|
getDeleteR dr
|