feat: persist bearer tokens in session

src/Foundation.hs

@@ -100,6 +100,8 @@ import UnliftIO.Pool
 import qualified Web.ServerSession.Core as ServerSession
 import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
 
+import Jose.Jwt (Jwt(..))
+
 -- | Convenient Type Synonyms:
 type DB = YesodDB UniWorX
 type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
@@ -1511,7 +1513,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 = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
+    yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware . storeBearerMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
@@ -1545,6 +1547,13 @@ instance Yesod UniWorX where
             addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
         observeYesodCacheSizeMiddleware :: Handler a -> Handler a
         observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
+        storeBearerMiddleware :: Handler a -> Handler a
+        storeBearerMiddleware handler = do
+          askBearer >>= \case
+            Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
+            Nothing       ->  return ()
+
+          handler
 
     -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"