diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2c68d028a..3ae8c8885 100644 --- a/src/Handler/Users.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1ff03ffde..f7a43dd6a 100644 --- a/src/Handler/Utils.hs +++ b/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) \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10b90e28f..076b1ac29 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9ad82b29f..c5f8ef383 100644 --- a/src/Utils/Form.hs +++ b/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") diff --git a/templates/widgets/form/form.hamlet b/templates/widgets/form/form.hamlet index 7d4a7901f..371a7c701 100644 --- a/templates/widgets/form/form.hamlet +++ b/templates/widgets/form/form.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $# Wrapper for all kinds of forms -
+ $# Distinguish different falvours of submit button layouts here: $case formSubmit $of FormNoSubmit