Fancy exception handling

src/Foundation.hs

@@ -5,6 +5,7 @@
 module Foundation where
 
 import Import.NoFoundation
+import qualified ClassyPrelude.Yesod as Yesod (addMessage)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 
@@ -816,7 +817,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 . headerMessagesMiddleware
+    yesodMiddleware = headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
@@ -857,13 +858,15 @@ instance Yesod UniWorX where
             $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
             redirectWith movedPermanently301 route'
         headerMessagesMiddleware :: Handler a -> Handler a
-        headerMessagesMiddleware handler = (handler <*) . runMaybeT $ do
+        headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
           isModal <- hasCustomHeader HeaderIsModal
           dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
+          $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit)
           guard $ isModal || dbTableShortcircuit
 
-          msgs <- MaybeT $ mapM (\(msgState, content) -> Message <$> fromPathPiece msgState <*> Just content) <$> getMessages 
-          addCustomHeader HeaderAlerts . decodeUtf8 $ JSON.encode msgs
+          lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
+            Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
+            addCustomHeader HeaderAlerts . decodeUtf8 $ JSON.encode msgs'
 
     -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"