From 282e0615cb6669b4ae9e9a1c89dddad1d41e4de3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 20 Dec 2018 12:12:38 +0100 Subject: [PATCH] Split deleteR for use with correctionsR --- messages/button/de.msg | 3 + src/Auth/Dummy.hs | 2 + src/Auth/LDAP.hs | 2 + src/Auth/PWHash.hs | 2 + src/Foundation.hs | 1 + src/Handler/Utils/Delete.hs | 114 ++++++++++++------- src/Handler/Utils/Table/Pagination.hs | 5 +- src/Utils.hs | 14 +++ src/Utils/Form.hs | 102 ++++++++++++++--- templates/table/form-wrap.hamlet | 2 +- templates/widgets/delete-confirmation.hamlet | 2 +- templates/widgets/form.hamlet | 4 +- 12 files changed, 191 insertions(+), 62 deletions(-) create mode 100644 messages/button/de.msg diff --git a/messages/button/de.msg b/messages/button/de.msg new file mode 100644 index 000000000..de25fb0c6 --- /dev/null +++ b/messages/button/de.msg @@ -0,0 +1,3 @@ +AmbiguousButtons: Mehrere Submit-Buttons aktiv +WrongButtonValue: Submit-Button hat falschen Wert +MultipleButtonValues: Submit-Button hat mehrere Werte \ No newline at end of file diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index df4ab5e40..b8debc0ca 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -17,6 +17,7 @@ data DummyMessage = MsgDummyIdent dummyForm :: ( RenderMessage site FormMessage , RenderMessage site DummyMessage + , RenderMessage site ButtonMessage , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) , Button site SubmitButton @@ -33,6 +34,7 @@ dummyLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site DummyMessage + , RenderMessage site ButtonMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => AuthPlugin site diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index ce07bb83c..0eebdd5f3 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -53,6 +53,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName" campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage + , RenderMessage site ButtonMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => AForm (HandlerT site IO) CampusLogin @@ -65,6 +66,7 @@ campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage , RenderMessage site CampusMessage + , RenderMessage site ButtonMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => LdapConf -> LdapPool -> AuthPlugin site diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index 3efad0d32..53001ce92 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -27,6 +27,7 @@ data PWHashMessage = MsgPWHashIdent hashForm :: ( RenderMessage site FormMessage , RenderMessage site PWHashMessage + , RenderMessage site ButtonMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => AForm (HandlerT site IO) HashLogin @@ -41,6 +42,7 @@ hashLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site PWHashMessage + , RenderMessage site ButtonMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => PWHashAlgorithm -> AuthPlugin site diff --git a/src/Foundation.hs b/src/Foundation.hs index b63830a54..14b182683 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -160,6 +160,7 @@ mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" +mkMessageVariant "UniWorX" "Button" "messages/button" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 756fc5da9..57877d2ed 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -1,6 +1,7 @@ module Handler.Utils.Delete ( DeleteRoute(..) , deleteR + , postDeleteR, getDeleteR ) where import Import @@ -13,63 +14,90 @@ 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 - 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 = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute + +data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute { drRecords :: Set (Key record) - , drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget - , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text + , 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 $ \case + (inpConfirmStr, BtnDelete) + | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr + -> return $ pure True + | otherwise + -> formFailure [MsgDeleteConfirmationWrong] + (_, BtnAbort) + -> return $ pure False + 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 -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 +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 - 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 "" + 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)) - formResult deleteFormRes $ \case - (_, catMaybes -> [BtnAbort]) -> - redirect drAbort - (inpConfirmStr, catMaybes -> [BtnDelete]) - | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr - -> do - runDB $ do - forM_ drRecords deleteCascade - addMessageI Success drSuccessMessage - redirect drSuccess - | otherwise - -> addMessageI Error MsgDeleteConfirmationWrong - _other -> return () + let + addDeleteTargets :: Form a -> Form a + addDeleteTargets form csrf = do + (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords) + over _2 (mappend $ fvInput fvTargets) <$> form csrf + + ((confirmRes, _), _) <- runFormPost . identForm FIDDelete . addDeleteTargets . renderAForm FormStandard $ confirmForm 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) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString Just targetRoute <- getCurrentRoute - defaultLayout - $(widgetFile "widgets/delete-confirmation") + sendResponse =<< + defaultLayout $(widgetFile "widgets/delete-confirmation") + + + +deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html +deleteR dr = do + postDeleteR $ \drRecords -> dr {drRecords} + getDeleteR dr diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 14a613f59..86fddd4ee 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -471,7 +471,10 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do return . (res,) $ do btnId <- newIdent act <- traverse toTextUrl dbParamsFormAction - let submitField = buttonField BtnSubmit + let submitField :: Field Handler SubmitButton + submitField = buttonField BtnSubmit + submitView :: Widget + submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype $(widgetFile "table/form-wrap") diff --git a/src/Utils.hs b/src/Utils.hs index 045d4d19c..08a26fc99 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -542,6 +542,20 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) + +data GlobalPostParam = PostDeleteTarget + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe GlobalPostParam +instance Finite GlobalPostParam +nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1) + +lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result) +lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident) + +hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool +hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) + --------------------------------- -- Custom HTTP Request-Headers -- --------------------------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6f2b9b078..4fa122282 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,6 +1,6 @@ module Utils.Form where -import ClassyPrelude.Yesod hiding (addMessage) +import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..)) import Settings import qualified Text.Blaze.Internal as Blaze (null) @@ -19,7 +19,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.List ((!!)) -import Control.Lens ((&)) +import Control.Lens import Web.PathPieces @@ -27,6 +27,8 @@ import Data.UUID import Utils.Message +import Data.Proxy + ------------------- -- Form Renderer -- ------------------- @@ -36,7 +38,7 @@ data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize renderAForm :: Monad m => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do - (res, ($ []) -> views) <- aFormToForm aform + (res, ($ []) -> fieldViews) <- aFormToForm aform let widget = $(widgetFile "widgets/form") return (res, widget) @@ -206,32 +208,51 @@ class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where cssClass :: a -> ButtonCssClass site +data ButtonMessage = MsgAmbiguousButtons + | MsgWrongButtonValue + | MsgMultipleButtonValues + data SubmitButton = BtnSubmit deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe SubmitButton +instance Finite SubmitButton + instance PathPiece SubmitButton where toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField) +buttonField :: forall a m. + ( Button (HandlerSite m) a + , Show (ButtonCssClass (HandlerSite m)) + , RenderMessage (HandlerSite m) ButtonMessage + , Monad m + ) => a -> Field m a +-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField) buttonField btn = Field {fieldParse, fieldView, fieldEnctype} where fieldEnctype = UrlEncoded + fieldView :: FieldViewFunc m a fieldView fid name attrs _val _ = let - cssClass' :: ButtonCssClass site + cssClass' :: ButtonCssClass (HandlerSite m) cssClass' = cssClass btn in [whamlet|