103 lines
3.8 KiB
Haskell
103 lines
3.8 KiB
Haskell
module Handler.Utils.Delete
|
|
( DeleteRoute(..)
|
|
, deleteR
|
|
, postDeleteR, getDeleteR
|
|
) 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 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)
|
|
, drUnjoin :: tables -> E.SqlExpr (Entity record)
|
|
, drGetInfo :: tables -> E.SqlQuery infoExpr
|
|
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
|
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
|
|
, drCaption
|
|
, drSuccessMessage :: SomeMessage UniWorX
|
|
, drAbort
|
|
, drSuccess :: SomeRoute UniWorX
|
|
}
|
|
|
|
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 . identForm 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 deleteCascade
|
|
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
|
|
|
|
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
|