diff --git a/src/Foundation.hs b/src/Foundation.hs index 9fce5c092..35f129223 100644 --- a/src/Foundation.hs +++ b/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 - <$> maybeAuthId - <*> runMaybeT (exceptTMaybe askBearerUnsafe) - <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags) +getAuthContext = do + authCtx <- AuthContext + <$> maybeAuthId + <*> 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 diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 4e463c970..be68f2d63 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/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 - , MonadLogger m + ( MonadHandler m, HandlerSite m ~ UniWorX + , 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 - , MonadLogger m +memcachedTimeoutWith :: ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadUnliftIO m , MonadThrow m , Typeable k'', Hashable k'', Eq k'' , Typeable a diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index d292fb525..ffb14f0da 100644 --- a/src/Model/Types/Security.hs +++ b/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