Handle AuthPredsR more elegantly

src/Foundation.hs

@@ -227,25 +227,6 @@ embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <
 data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
-class RedirectUrl site url => HasRoute site url where
-  urlRoute :: url -> Route site
-
-instance HasRoute site (Route site) where
-  urlRoute = id
-instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where
-  urlRoute = view _1
-instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where
-  urlRoute = view _1
-instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
-  urlRoute (a :#: _) = urlRoute a
-
-data SomeRoute site = forall url. HasRoute site url => SomeRoute url
-
-instance RedirectUrl site (SomeRoute site) where
-  toTextUrl (SomeRoute url) = toTextUrl url
-instance HasRoute site (SomeRoute site) where
-  urlRoute (SomeRoute url) = urlRoute url
-
 data MenuItem = MenuItem
   { menuItemLabel :: UniWorXMessage
   , menuItemIcon  :: Maybe Text     -- currently from: https://fontawesome.com/icons?d=gallery
@@ -601,7 +582,7 @@ evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route
 evalAccess route isWrite = do
   tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
   dnf <- either throwM return $ routeAuthTags route
-  (result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
+  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
   result <$ tellSessionJson SessionInactiveAuthTags deactivated
 
 evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
@@ -811,7 +792,8 @@ siteLayout headingOverride widget = do
     | otherwise -> do
         applySystemMessages
         authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
-        forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR)
+        forM_ authTagPivots $
+          \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
         getMessages
 
   let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority

src/Handler/Home.hs

@@ -4,6 +4,7 @@ import Import
 import Handler.Utils
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import Data.Time hiding (formatTime)
 
@@ -281,20 +282,24 @@ postHelpR = do
 getAuthPredsR, postAuthPredsR :: Handler Html
 getAuthPredsR = postAuthPredsR
 postAuthPredsR = do
-  AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+  (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
   
-  let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag)
+  let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
   
   ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
     $ AuthTagActive
       <$> funcForm taForm (fslI MsgActiveAuthTags) True
       <*  submitButton
 
-  formResultModal authActiveRes AuthPredsR $ \authTagActive -> do
+  mReferer <- runMaybeT $ do
+    param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
+    MaybeT . return $ fromPathPiece param
+  formResult authActiveRes $ \authTagActive -> do
     setSessionJson SessionActiveAuthTags authTagActive
-    tell . pure =<< messageI Success MsgAuthPredsActiveChanged
+    modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
+    addMessageI Success MsgAuthPredsActiveChanged
+    redirect $ fromMaybe AuthPredsR mReferer
 
   defaultLayout $ do
     setTitleI MsgAuthPredsActive
-    isModal <- hasCustomHeader HeaderIsModal
     $(widgetFile "authpreds")

src/Handler/Utils/Templates.hs

@@ -7,12 +7,14 @@ import Import.NoFoundation
 lipsum :: WidgetT site IO ()
 lipsum = $(widgetFile "widgets/lipsum")
 
-modal :: WidgetT site IO () -> Either (Route site) (WidgetT site IO ()) -> WidgetT site IO ()
+modal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO ()
 modal modalTrigger modalContent = do
   let modalDynamic = isLeft modalContent
   modalId <- newIdent
   triggerId <- newIdent
   $(widgetFile "widgets/modal")
   case modalContent of
-    Left  route -> [whamlet|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
+    Left  route -> do
+      route' <- toTextUrl route
+      [whamlet|<a .btn ##{triggerId} href=#{route'}>^{modalTrigger}|]
     Right _     -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]

src/Utils.hs

@@ -100,6 +100,25 @@ unsupportedAuthPredicate = do
     |]
 
 
+class RedirectUrl site url => HasRoute site url where
+  urlRoute :: url -> Route site
+
+instance HasRoute site (Route site) where
+  urlRoute = id
+instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where
+  urlRoute = view _1
+instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where
+  urlRoute = view _1
+instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
+  urlRoute (a :#: _) = urlRoute a
+
+data SomeRoute site = forall url. HasRoute site url => SomeRoute url
+
+instance RedirectUrl site (SomeRoute site) where
+  toTextUrl (SomeRoute url) = toTextUrl url
+instance HasRoute site (SomeRoute site) where
+  urlRoute (SomeRoute url) = urlRoute url
+
 
 ---------------------
 -- Text and String --

templates/adminTest.hamlet

@@ -32,7 +32,7 @@
           ^{btnWdgt}
     <li><br>
       Modals:
-      ^{modal "Klick mich für Ajax-Test" (Left UsersR)}
+      ^{modal "Klick mich für Ajax-Test" (Left $ SomeRoute UsersR)}
       ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
     <li>
       ^{modal "Email-Test" (Right emailWidget')}

templates/authpreds.hamlet

@@ -1,2 +1,4 @@
-<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype} :isModal:data-ajax-submit>
+<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
+  $maybe referer <- mReferer
+    <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
   ^{authActiveWidget}