117 lines
5.1 KiB
Haskell
117 lines
5.1 KiB
Haskell
{-|
|
|
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
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Form
|
|
|
|
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 as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
|
|
import qualified Database.Esqueleto.Internal.Language as E (From)
|
|
|
|
|
|
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend 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 -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
|
|
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) 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
|
|
, drCaption
|
|
, drSuccessMessage :: SomeMessage UniWorX
|
|
, drAbort
|
|
, drSuccess :: SomeRoute UniWorX
|
|
, drDelete :: forall a. Key record -> DB a -> DB 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
|
|
<*> disambiguateButtons (combinedButtonFieldF "")
|
|
confirmField
|
|
| multiple = convertField unTextarea Textarea textareaField
|
|
| otherwise = textField
|
|
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
|
|
|
|
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
|
|
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm 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 :: ( DeleteCascade 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
|
|
|
|
void . for drResult $ \DeleteRoute{..} -> do
|
|
confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
|
|
|
|
((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
|
|
|
|
formResult confirmRes $ \case
|
|
True -> do
|
|
runDB $ do
|
|
forM_ drRecords $ \k -> drDelete k $ deleteCascade k
|
|
addMessageI Success drSuccessMessage
|
|
redirect drSuccess
|
|
False ->
|
|
redirect drAbort
|
|
|
|
|
|
getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
|
|
getDeleteR DeleteRoute{..} = do
|
|
targets <- runDB $ mapM (\i -> (,) <$> drRenderRecord i <*> drRecordConfirmString i) <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
|
|
|
|
let confirmString = Text.unlines $ view _2 <$> targets
|
|
|
|
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
|
|
|
|
Just targetRoute <- getCurrentRoute
|
|
let deleteForm = wrapForm deleteFormWdgt def
|
|
{ formAction = Just $ SomeRoute targetRoute
|
|
, formEncoding = deleteFormEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
|
|
sendResponse =<<
|
|
defaultLayout $(widgetFile "widgets/delete-confirmation/delete-confirmation")
|
|
|
|
|
|
|
|
deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
|
|
deleteR dr = do
|
|
postDeleteR $ \drRecords -> dr {drRecords}
|
|
getDeleteR dr
|