diff --git a/src/Foundation.hs b/src/Foundation.hs index b6db48a8a..8577ae9fd 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2a87a09e8..f4125de79 100644 --- a/src/Handler/Home.hs +++ b/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") diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index 14f8ce38c..89cb2062c 100644 --- a/src/Handler/Utils/Templates.hs +++ b/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|^{modalTrigger}|] + Left route -> do + route' <- toTextUrl route + [whamlet|^{modalTrigger}|] Right _ -> [whamlet|
^{modalTrigger}|] diff --git a/src/Utils.hs b/src/Utils.hs index 05e93753a..8965c0009 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 0693ea1cc..2cc3f24f3 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -32,7 +32,7 @@ ^{btnWdgt}

  • 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")}
  • ^{modal "Email-Test" (Right emailWidget')} diff --git a/templates/authpreds.hamlet b/templates/authpreds.hamlet index abb3042c3..d7430fbae 100644 --- a/templates/authpreds.hamlet +++ b/templates/authpreds.hamlet @@ -1,2 +1,4 @@ -
    + + $maybe referer <- mReferer + ^{authActiveWidget}