fix(memcached): navAccess & quick actions cache invalidations

src/Foundation.hs

@@ -313,7 +313,7 @@ falseAP = APPure . const . const . const $ falseAR <$> ask -- included for compl
 data AuthContext = AuthContext
   { authCtxAuth    :: Maybe UserId
   , authCtxBearer  :: Maybe (BearerToken UniWorX)
-  , authActiveTags :: Set AuthTag
+  , authActiveTags :: AuthTagActive
   } deriving (Eq, Read, Show, Generic, Typeable)
     deriving anyclass (Hashable, Binary)
 
@@ -323,10 +323,15 @@ getAuthContext :: forall m.
                   , MonadCatch m
                   )
                => m AuthContext
-getAuthContext = AuthContext
+getAuthContext = do
-  <$> maybeAuthId
+  authCtx <- AuthContext
-  <*> runMaybeT (exceptTMaybe askBearerUnsafe)
+    <$> maybeAuthId
-  <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
+    <*> runMaybeT (exceptTMaybe askBearerUnsafe)
+    <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
+
+  $logDebugS "getAuthContext" $ tshow authCtx
+
+  return authCtx
 
 
 askBearerUnsafe :: forall m.
@@ -1713,7 +1718,7 @@ instance Yesod UniWorX where
 --   return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView)
 
 data MemcachedKeyFavourites
-  = MemcachedKeyFavouriteQuickActions CourseId AuthContext
+  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
   deriving (Eq, Read, Show, Generic, Typeable)
   deriving anyclass (Hashable, Binary)
 
@@ -1856,7 +1861,8 @@ siteLayout' headingOverride widget = do
          in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
               ctx <- getAuthContext
               MsgRenderer mr <- getMsgRenderer
-              let cK = MemcachedKeyFavouriteQuickActions cId ctx
+              langs <- selectLanguages appLanguages <$> languages
+              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
               $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
               items <- memcachedLimitedKeyTimeoutBy
                 MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1

src/Handler/Utils/Memcached.hs

@@ -1,5 +1,6 @@
 module Handler.Utils.Memcached
-  ( memcached, memcachedBy
+  ( memcachedAvailable
+  , memcached, memcachedBy
   , memcachedHere, memcachedByHere
   , memcachedSet, memcachedGet
   , memcachedInvalidate, memcachedByInvalidate
@@ -76,6 +77,12 @@ _MemcachedExpiry = prism' fromExpiry toExpiry
           = Left . posixSecondsToUTCTime $ fromIntegral n
 
 
+memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                      )
+                   => m Bool
+memcachedAvailable = getsYesod $ is _Just . appMemcached
+
+
 data MemcachedException = MemcachedException Memcached.MemcachedException
                         | MemcachedInvalidExpiry Expiry
   deriving (Show, Typeable)
@@ -102,7 +109,7 @@ memcachedByGet k = runMaybeT $ do
   
   encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn
 
-  $logInfoS "memcached" "Cache hit"
+  $logDebugS "memcached" "Cache hit"
 
   guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
   let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
@@ -133,7 +140,7 @@ memcachedBySet mExp k v = do
     let cKey = memcachedKey aeadKey (Proxy @a) k
         encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
     liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
-    $logInfoS "memcached" "Cache store"
+    $logDebugS "memcached" "Cache store"
 
 memcachedByInvalidate :: forall a k m p.
                          ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -365,8 +372,8 @@ memcachedAsync = unsafePerformIO . newTVarIO $ HashMap.empty
 {-# NOINLINE memcachedAsync #-}
 
 liftAsyncTimeout :: forall k'' a m.
-                    ( MonadResource m, MonadUnliftIO m
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
-                    , MonadLogger m
+                    , MonadUnliftIO m
                     , MonadThrow m
                     , Typeable k'', Hashable k'', Eq k''
                     , Typeable a
@@ -374,7 +381,7 @@ liftAsyncTimeout :: forall k'' a m.
                  => DiffTime
                  -> k''
                  -> m a -> MaybeT m a
-liftAsyncTimeout dt (hashableDynamic -> cK) act = do
+liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lift act) $ do
   delay <- liftIO . newDelay . round $ toRational dt * 1e6
 
   act' <- lift $ do
@@ -418,8 +425,8 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = do
       | otherwise
       = throwM AsyncTimeoutReturnTypeDoesNotMatchComputationKey
 
-memcachedTimeoutWith :: ( MonadResource m, MonadUnliftIO m
+memcachedTimeoutWith :: ( MonadHandler m, HandlerSite m ~ UniWorX
-                        , MonadLogger m
+                        , MonadUnliftIO m
                         , MonadThrow m
                         , Typeable k'', Hashable k'', Eq k''
                         , Typeable a

src/Model/Types/Security.hs

@@ -25,6 +25,8 @@ import Database.Persist.Sql
 
 import Utils.Lens.TH
 
+import qualified Data.Binary as Binary
+
 
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
@@ -109,6 +111,13 @@ instance FromJSON AuthTagActive where
     o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
     return . AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n o'
 
+instance Hashable AuthTagActive where
+  hashWithSalt s = foldl' hashWithSalt s . authTagIsActive
+
+instance Binary AuthTagActive where
+  put v = Binary.put . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
+  get = Binary.get <&> \hm -> AuthTagActive (\n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm)
+
 derivePersistFieldJSON ''AuthTagActive