From efac923cc292b938e6aebcc8e0eed75444dba5f8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 21:08:39 +0200
Subject: [PATCH] headerMessagesMiddleware

---
 src/Foundation.hs    | 12 +++++++++++-
 src/Handler/Admin.hs |  1 +
 src/Utils.hs         |  8 ++++++--
 3 files changed, 18 insertions(+), 3 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 0d8e5d909..032d630a2 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -83,6 +83,8 @@ import Data.Bits (Bits(zeroBits))
 
 import Network.Wai.Parse (lbsBackEnd)
 
+import qualified Data.Aeson as JSON
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -814,7 +816,7 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
+    yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware . headerMessagesMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
@@ -854,6 +856,14 @@ instance Yesod UniWorX where
           when changed $ do
             $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
             redirectWith movedPermanently301 route'
+        headerMessagesMiddleware :: Handler a -> Handler a
+        headerMessagesMiddleware handler = (*> handler) . runMaybeT $ do
+          isModal <- hasCustomHeader HeaderIsModal
+          dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
+          guard $ isModal || dbTableShortcircuit
+
+          msgs <- MaybeT $ mapM (\(msgState, content) -> Message <$> fromPathPiece msgState <*> Just content) <$> getMessages 
+          addCustomHeader HeaderAlerts . decodeUtf8 $ JSON.encode msgs
 
     -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 4d53f5eed..855640144 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -117,6 +117,7 @@ postAdminTestR = do
       tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
       return jId
     writeJobCtl $ JobCtlPerform jId
+    addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
 
   let emailWidget' = wrapForm emailWidget def
         { formAction = Just . SomeRoute $ AdminTestR
diff --git a/src/Utils.hs b/src/Utils.hs
index 88adf17e4..ccec0178a 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -624,10 +624,10 @@ takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 -- Moved to Utils.Parameters
 
 ---------------------------------
--- Custom HTTP Request-Headers --
+-- Custom HTTP Headers --
 ---------------------------------
 
-data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit
+data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderAlerts
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe CustomHeader
@@ -640,6 +640,10 @@ lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI
 hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool
 hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)
 
+addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) => CustomHeader -> payload -> m ()
+addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
+replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)
+
 ------------------
 -- Cryptography --
 ------------------