Split deleteR for use with correctionsR

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

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

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

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

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.

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
+  , drUnjoin :: tables -> E.SqlExpr (Entity record)
-  , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
+  , 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
+  void . for drResult $ \DeleteRoute{..} -> do
-      confirmString = Text.unlines $ map (Text.strip . view _2) sTargets
+    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))
-      confirmField
-        | Set.size drRecords <= 1 = textField
-        | otherwise = convertField unTextarea Textarea textareaField
 
-  ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,)
+    let
-    <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
+      addDeleteTargets :: Form a -> Form a
-    <*> combinedButtonFieldF ""
+      addDeleteTargets form csrf = do
+        (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
+        over _2 (mappend $ fvInput fvTargets) <$> form csrf
 
-  formResult deleteFormRes $ \case
+    ((confirmRes, _), _) <- runFormPost . identForm FIDDelete . addDeleteTargets . renderAForm FormStandard $ confirmForm confirmString
-    (_, catMaybes -> [BtnAbort]) ->
+
-      redirect drAbort
+    formResult confirmRes $ \case
-    (inpConfirmStr, catMaybes -> [BtnDelete])
+      True -> do
-      | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
+        runDB $ do
-        -> do
+          forM_ drRecords deleteCascade
-          runDB $ do
+          addMessageI Success drSuccessMessage
-            forM_ drRecords deleteCascade
+        redirect drSuccess
-            addMessageI Success drSuccessMessage
+      False ->
-          redirect drSuccess
+        redirect drAbort
-      | otherwise
+
-        -> addMessageI Error MsgDeleteConfirmationWrong
+
-    _other -> return ()
+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
+  sendResponse =<<
-    $(widgetFile "widgets/delete-confirmation")
+    defaultLayout $(widgetFile "widgets/delete-confirmation")
+
+
+
+deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
+deleteR dr = do
+  postDeleteR $ \drRecords -> dr {drRecords}
+  getDeleteR dr

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")
 

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 --
 ---------------------------------

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|
         <button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
       |]
 
-    fieldParse []    _ = return $ Right Nothing
+    fieldParse []    [] = return $ Right Nothing
-    fieldParse [str] _
+    fieldParse [str] []
       | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
+      | otherwise  = return . Left $ SomeMessage MsgWrongButtonValue
-    fieldParse _ _ = return $ Left "Multiple button values"
+    fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues
 
-combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonField :: forall a m.
+                     ( Button (HandlerSite m) a
+                     , Show (ButtonCssClass (HandlerSite m))
+                     , RenderMessage (HandlerSite m) ButtonMessage
+                     , MonadHandler m
+                     ) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
 combinedButtonField bs FieldSettings{..} = formToAForm $ do
   mr <- getMessageRender
   fvId <- maybe newIdent return fsId
@@ -250,13 +271,45 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
              }
          )
 
-combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonFieldF :: forall m a.
+                      ( Button (HandlerSite m) a
+                      , Show (ButtonCssClass (HandlerSite m))
+                      , RenderMessage (HandlerSite m) ButtonMessage
+                      , Finite a
+                      , MonadHandler m
+                      ) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
 combinedButtonFieldF = combinedButtonField (universeF :: [a])
 
-submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
+disambiguateButtons :: forall m a.
-submitButton = void $ combinedButtonField [BtnSubmit] ""
+                     ( MonadHandler m
+                     , RenderMessage (HandlerSite m) ButtonMessage
+                     ) => AForm m [Maybe a] -> AForm m a
+disambiguateButtons = traverseAForm $ \case
+  (catMaybes -> [bRes]) -> return $ FormSuccess bRes
+  (catMaybes -> []    ) -> return FormMissing
+  _other                -> formFailure [MsgAmbiguousButtons]
 
-autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
+combinedButtonField_ :: forall a m.
+                      ( Button (HandlerSite m) a
+                      , Show (ButtonCssClass (HandlerSite m))
+                      , RenderMessage (HandlerSite m) ButtonMessage
+                      , MonadHandler m
+                      ) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
+combinedButtonField_ bs fs = void . disambiguateButtons $ combinedButtonField bs fs
+
+combinedButtonFieldF_ :: forall m a p.
+                       ( Button (HandlerSite m) a
+                       , Show (ButtonCssClass (HandlerSite m))
+                       , RenderMessage (HandlerSite m) ButtonMessage
+                       , MonadHandler m
+                       , Finite a
+                       ) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
+combinedButtonFieldF_ _ fs = void . disambiguateButtons $ combinedButtonFieldF @m @a fs
+
+submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
+submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
+
+autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
 autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing
 
 -------------------
@@ -331,6 +384,27 @@ optionsFinite = do
 -- Form evaluation --
 ---------------------
 
+traverseAForm :: forall m a b. Monad m => (a -> m (FormResult b)) -> (AForm m a -> AForm m b)
+traverseAForm adj (AForm f) = AForm $ \mr env ints -> do
+  ret@(res, _, _, _) <- f mr env ints
+  case res of
+    FormFailure errs
+      -> return $ ret & _1 .~ FormFailure errs
+    FormMissing
+      -> return $ ret & _1 .~ FormMissing
+    FormSuccess a -> do
+      a' <- adj a
+      return $ ret & _1 .~ a'
+
+formFailure :: forall msg m a.
+             ( MonadHandler m
+             , RenderMessage (HandlerSite m) msg
+             ) => [msg] -> m (FormResult a)
+formFailure errs' = do
+  mr <- getMessageRender
+  return . FormFailure $ map mr errs'
+
+
 formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
 formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
 

templates/table/form-wrap.hamlet

@@ -2,4 +2,4 @@ $newline never
 <form method=#{decodeUtf8 (renderStdMethod dbParamsFormMethod)} action=#{fromMaybe "" act} *{dbParamsFormAttrs} enctype=#{enctype'}>
   ^{fWidget}
   $if dbParamsFormAddSubmit
-    ^{fieldView submitField btnId "" mempty (Right BtnSubmit) False}
+    ^{submitView}

templates/widgets/delete-confirmation.hamlet

@@ -1,6 +1,6 @@
 <p>_{drCaption}
 <ul>
-  $forall (wdgt, _) <- sTargets
+  $forall (wdgt, _) <- targets
     <li>
       ^{wdgt}
 

templates/widgets/form.hamlet

@@ -2,10 +2,10 @@ $newline never
 #{fragment}
 $case formLayout
   $of FormDBTablePagesize
-    $forall view <- views
+    $forall view <- fieldViews
       ^{fvInput view}
   $of _
-    $forall view <- views
+    $forall view <- fieldViews
       $# TODO: add class 'form-group--submit' if this is the submit-button view
       <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
         $if not (Blaze.null $ fvLabel view)