chore(users): keep filters after table action

src/Handler/Users.hs

@@ -334,7 +334,7 @@ postUsersR = do
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
         { dbParamsFormMethod = POST
-        , dbParamsFormAction = Just $ SomeRoute UsersR
+        , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")])
         , dbParamsFormAttrs  = []
         , dbParamsFormSubmit = FormSubmit
         , dbParamsFormAdditional
@@ -351,21 +351,21 @@ postUsersR = do
       , dbtExtraReps = []
       }
 
+  $logInfoS "UsersFormResult" $ tshow usersRes
   formResult usersRes $ \case
     (act, usersSet)
-      | Set.null usersSet && isNotSetSupervisor act -> do
-          addMessageI Info MsgActionNoUsersSelected
-          redirect UsersR
+      | Set.null usersSet && isNotSetSupervisor act ->
+          addMessageI Info MsgActionNoUsersSelected          
     (UserLdapSyncData, userSet) -> do
       runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
-      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
-      redirect UsersR
+      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet      
+      redirectKeepGetParams UsersR
     (UserHijack, Set.minView -> Just (uid, _)) ->
       hijackUser uid >>= sendResponse
     (UserRemoveSupervisorData, userSet) -> do      
       runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
       addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
-      redirect UsersR
+      redirectKeepGetParams UsersR
     (act, usersSet)
       | isActionSupervisor act -> do 
         avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
@@ -382,8 +382,8 @@ postUsersR = do
         if nrSuperNotFound > 0
           then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound
           else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound)
-        redirect UsersR
-    _other -> error "Should not be possible"
+        redirectKeepGetParams UsersR
+    _other -> addMessageI Warning MsgInvalidInput
 
   ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
 

src/Handler/Utils.hs

@@ -137,3 +137,22 @@ redirectAlternatives = go
       Just xs' -> over _1 (x :) $ nunsnoc xs'
     nsnoc [] x = x :| []
     nsnoc (x' : xs) x = x' :| (xs ++ [x])
+
+-- | redirect to currentRoute, if Just otherwise to given default
+reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
+reload r = getCurrentRoute >>= redirect . fromMaybe r
+
+-- | like `reload`, preserving all GET parameters
+reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
+reloadKeepGetParams r = liftHandler $ do 
+  getps <- reqGetParams <$> getRequest
+  route <- fromMaybe r  <$> getCurrentRoute
+  -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
+  -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
+  redirect (route, getps) 
+
+-- | redirect preserving all GET parameters
+redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
+redirectKeepGetParams route = liftHandler $ do 
+  getps <- reqGetParams <$> getRequest  
+  redirect (route, getps)  

src/Handler/Utils/Table/Pagination.hs

@@ -964,7 +964,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
 instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
   def = DBParamsForm
     { dbParamsFormMethod     = POST
-    , dbParamsFormAction     = Nothing
+    , dbParamsFormAction     = Nothing -- Recall: Nothing preserves GET Parameters
     , dbParamsFormAttrs      = []
     , dbParamsFormSubmit     = FormSubmit
     , dbParamsFormAdditional = \_ -> return (pure (), mempty)

src/Utils/Form.hs

@@ -307,7 +307,7 @@ data FormIdentifier
   | FIDAvsQueryLicence
   | FIDAvsSetLicence
   | FIDBtnAvsImportUnknown
-  | FIDBtnAvsRevokeUnknown  
+  | FIDBtnAvsRevokeUnknown
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -1089,6 +1089,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings
 wrapForm' btn formWidget FormSettings{..} = do
   formId <- maybe newIdent (return . toPathPiece) formAnchor
   formActionUrl <- traverse toTextUrl formAction
+  let hasAction = isJust formActionUrl
   $(widgetFile "widgets/form/form")
 
 

templates/widgets/form/form.hamlet

@@ -5,7 +5,7 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 $# Wrapper for all kinds of forms
-<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
+<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} :hasAction:action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
   $# Distinguish different falvours of submit button layouts here:
   $case formSubmit
     $of FormNoSubmit