From 74c330bd243b429ff8fe905a987dacf875426d16 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 23 Sep 2024 17:09:47 +0200 Subject: [PATCH] chore(memcached): add key classes for easy invalidation --- src/Handler/Course/Edit.hs | 1 + src/Handler/School/DayTasks.hs | 40 +++++++++++++--- src/Handler/Term.hs | 13 +++--- src/Handler/Tutorial/Edit.hs | 1 + src/Handler/Utils/Delete.hs | 2 + src/Handler/Utils/Memcached.hs | 79 +++++++++++++++++++++++++------- src/Handler/Utils/Occurrences.hs | 13 ++++-- src/Utils.hs | 2 +- 8 files changed, 117 insertions(+), 34 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 138fd2c6c..1e06c919b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -452,6 +452,7 @@ courseEditHandler miButtonAction mbCourseForm = do sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid + memcachedFlushClass MemcachedKeyClassTutorialOccurrences memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) addMessageI Success $ MsgCourseEditOk tid ssh csh return True diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 83b1f4f88..0dd956333 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -15,8 +15,9 @@ import Import import Handler.Utils import Handler.Utils.Company +import Handler.Utils.Occurrences --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text @@ -51,10 +52,9 @@ occurrenceDayValue d = Aeson.object ] ] ] -- TODO: ensure that an appropriate GIN index for the jsonb column is set +{- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] getDayTutorials ssh d = E.unValue <<$>> E.select (do --- getDayTutorials :: SchoolId -> Day -> DB [E.Value TutorialId] --- getDayTutorials ssh d = E.select (do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) @@ -63,7 +63,35 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) return $ tut E.^. TutorialId ) - -- CONTINUE HERE: deal with regular schedules and exceptions, filter in Haskell-Land and use memcaching for the result +-} + +-- Datatype to be used for memcaching occurrences +data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Hashable, Binary) + +getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] +getDayTutorials ssh dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + candidates <- E.select $ do + (trm :& crs :& tut) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh + E.&&. trm E.^. TermStart E.<=. E.val dend + E.&&. trm E.^. TermEnd E.>=. E.val dstart + return (trm, tut) + $logErrorS "memcached" $ "***DEBUG*****CACHE*****" <> tshow (ssh,dlimit) <> "***************" -- DEBUG ONLY + return $ mapMaybe checkCandidate candidates + where + period = Set.fromAscList [dstart..dend] + + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) + | not $ Set.null $ Set.intersection period $ occurrencesCompute trm occ + = Just tutId + | otherwise + = Nothing type DailyTableExpr = ( E.SqlExpr (Entity Course) @@ -112,7 +140,7 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do - tuts <- getDayTutorials ssh nd + tuts <- getDayTutorials ssh (nd,nd) let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do @@ -133,7 +161,7 @@ mkDailyTable isAdmin ssh nd = do in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid - , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 345f0d882..7273e8757 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -29,7 +29,7 @@ import qualified Control.Monad.State.Class as State validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator TermForm m () validateTerm = do - TermForm{..} <- State.get + TermForm{..} <- State.get guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart @@ -87,7 +87,7 @@ getTermShowR = do $of Left singleHoliday ^{formatTimeW SelFormatDate singleHoliday} $of Right (startD, endD) - ^{formatTimeRangeW SelFormatDate startD (Just endD)} + ^{formatTimeRangeW SelFormatDate startD (Just endD)} |] ] dbtSorting = Map.fromList @@ -150,11 +150,11 @@ postTermEditR = do Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd] in mempty { tftName = Just ntid - , tftStart = Just tStart - , tftEnd = Just tEnd + , tftStart = Just tStart + , tftEnd = Just tEnd , tftLectureStart = Just tLecStart , tftLectureEnd = Just tLecEnd - , tftHolidays = Just tHolys + , tftHolidays = Just tHolys } termEditHandler Nothing template @@ -201,6 +201,7 @@ termEditHandler mtid template = do , termActiveFor = tafFor } lift . audit $ TransactionTermEdit tid + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success $ MsgTermEdited tid redirect TermShowR FormMissing -> return () @@ -332,7 +333,7 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do (fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing (toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing (forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for") & addPlaceholder (mr MsgTermActiveForPlaceholder)) Nothing - + let res = TermActiveForm <$> fromRes <*> toRes <*> forRes res' = res <&> \newDat oldDat -> if | newDat `elem` oldDat diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index ee65bd4cc..c13c88df0 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -88,6 +88,7 @@ postTEditR tid ssh csh tutn = do case insertRes of Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName Nothing -> do + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success $ MsgTutorialEdited tfName redirect $ CourseR tid ssh csh CTutorialListR diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index dbd062bbb..418972395 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -21,6 +21,7 @@ module Handler.Utils.Delete import Import import Handler.Utils.Form +import Handler.Utils.Memcached import qualified Data.Text as Text import qualified Data.Set as Set @@ -113,6 +114,7 @@ deleteR' DeleteRoute{..} = do True -> do runDBJobs $ do forM_ drRecords $ \k -> drDelete k $ delete k + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success drSuccessMessage redirect drSuccess False -> diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 091e88418..38f00d882 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -7,9 +7,10 @@ module Handler.Utils.Memcached ( memcachedAvailable , memcached, memcachedBy + , memcachedByClass, memcachedFlushClass, MemcachedKeyClass(..) , memcachedHere, memcachedByHere , memcachedSet, memcachedGet - , memcachedInvalidate, memcachedByInvalidate + , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll , manageMemcachedLocalInvalidations , memcachedByGet, memcachedBySet , memcachedTimeout, memcachedTimeoutBy @@ -40,6 +41,8 @@ import qualified Data.Binary.Get as Binary import Crypto.Hash.Algorithms (SHAKE256) +import qualified Data.Set as Set + import qualified Data.ByteArray as BA import qualified Data.ByteString.Base64 as Base64 @@ -204,7 +207,7 @@ memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" - + let withCache = case localARC of Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) Nothing -> fmap (view _1) . ($ Nothing) @@ -231,7 +234,16 @@ memcachedBySet :: forall a k m. , Binary k ) => Maybe Expiry -> k -> a -> m () -memcachedBySet mExp (Binary.encode -> k) v = do +memcachedBySet = ((void .) .) . memcachedBySet' + +memcachedBySet' :: forall a k m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + , Typeable a, Binary a, NFData a + , Binary k + ) + => Maybe Expiry -> k -> a -> m (Maybe ByteString) +memcachedBySet' mExp (Binary.encode -> k) v = do mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry let decrypted = toStrict $ Binary.encode v @@ -240,13 +252,14 @@ memcachedBySet mExp (Binary.encode -> k) v = do Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime mConn <- getsYesod appMemcached - for_ mConn $ \AppMemcached{..} -> do + bsKey <- for mConn $ \AppMemcached{..} -> do mNonce <- liftIO AEAD.newNonce let cKey = toMemcachedKey memcachedKey (Proxy @a) k aad = memcachedAAD cKey mExpiry mCiphertext = AEAD.aead memcachedKey mNonce decrypted aad liftIO . handle (\(_ :: Memcached.MemcachedException) -> return ()) $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry + return cKey mLocal <- getsYesod appMemcachedLocal for_ mLocal $ \AppMemcachedLocal{..} -> do @@ -257,6 +270,7 @@ memcachedBySet mExp (Binary.encode -> k) v = do where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a mLocalInvalidateKey = k $logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv + return bsKey memcachedByInvalidate :: forall a k m p. ( MonadHandler m, HandlerSite m ~ UniWorX @@ -293,7 +307,7 @@ instance Binary MemcachedLocalInvalidateMsg where Binary.putWord64le w1 Binary.putWord64le w2 Binary.putLazyByteString mLocalInvalidateKey - + manageMemcachedLocalInvalidations :: ( MonadUnliftIO m , MonadLogger m ) @@ -318,7 +332,7 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager } -newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } +newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyed a) where rnf = rnf . unMemcachedUnkeyed @@ -343,14 +357,12 @@ memcachedInvalidate :: forall (a :: Type) m p. => p a -> m () memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a) +memcachedFlushAll :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () +memcachedFlushAll = getsYesod appMemcached >>= flip whenIsJust (liftIO . Memcached.flushAll . memcachedConn) memcachedWith :: Monad m => (m (Maybe b), a -> m b) -> m a -> m b -memcachedWith (doGet, doSet) act = do - pRes <- doGet - maybe id (const . return) pRes $ do - res <- act - doSet res +memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -369,7 +381,42 @@ memcachedBy :: forall a m k. memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x) -newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } +data MemcachedKeyClass + = MemcachedKeyClassTutorialOccurrences + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, NFData) + deriving anyclass (Hashable, Binary, Universe, Finite) + +newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStore :: Set ByteString } + deriving newtype (Eq, Ord, Semigroup, Monoid, Show, Binary, NFData) +-- instance NFData MemcachedKeyClassStore where +-- rnf MemcachedKeyClassStore{..} = rnf unMemcachedKeyClassStore + +memcachedByClass :: forall a m k. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + , Typeable a, Binary a, NFData a + , Binary k + ) + => MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a +memcachedByClass mkc mExp k = memcachedWith (memcachedByGet k, setAndAddClass) + where + setAndAddClass v = do + mbKey <- memcachedBySet' mExp k v + whenIsJust mbKey $ \vKey -> do + cl <- maybeMonoid <$> memcachedByGet mkc + memcachedBySet Nothing mkc $ MemcachedKeyClassStore $ Set.insert vKey $ unMemcachedKeyClassStore cl + -- memcachedBySet Nothing mkc $ cl <> MemcachedKeyClassStore $ Set.singleton vKey + return v + +memcachedFlushClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m () +memcachedFlushClass mkc = maybeT_ $ do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + cl <- MaybeT $ memcachedByGet mkc + hoist liftIO $ forM_ (unMemcachedKeyClassStore cl) $ + catchIfMaybeT Memcached.isKeyNotFound . flip Memcached.delete memcachedConn + lift $ memcachedByInvalidate mkc (Proxy @MemcachedKeyClassStore) + +newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyedLoc a) where rnf MemcachedUnkeyedLoc{..} = rnf unMemcachedUnkeyedLoc @@ -379,7 +426,7 @@ memcachedHere = do loc <- location [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |] -newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } +newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedKeyedLoc a) where rnf MemcachedKeyedLoc{..} = rnf unMemcachedKeyedLoc @@ -563,7 +610,7 @@ memcacheAuth' :: forall a m k. -> m a -> m a memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift - + memcacheAuthMax :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -585,7 +632,7 @@ memcacheAuthHere' :: Q Exp memcacheAuthHere' = do loc <- location [e| \exp k -> withMemcachedKeyedLoc (memcacheAuth' exp (loc, k)) |] - + memcacheAuthHereMax :: Q Exp memcacheAuthHereMax = do loc <- location diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 93642d524..f5fc0b9fa 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,6 +4,7 @@ module Handler.Utils.Occurrences ( occurrencesWidget + , occurrencesCompute , occurrencesBounds , occurrencesAddBusinessDays ) where @@ -35,12 +36,10 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | Get bounds for an Occurrences -occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) +-- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptins +occurrencesCompute :: Term -> Occurrences -> Set Day +occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays where - occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already - scdDays = Set.foldr getOccDays mempty occurrencesScheduled (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions @@ -51,6 +50,10 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday +-- | Get bounds for an Occurrences +occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds = (liftM2 (,) Set.lookupMin Set.lookupMax .) . occurrencesCompute + occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions where diff --git a/src/Utils.hs b/src/Utils.hs index 617293cae..5c68ba25a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -655,7 +655,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x --- fold would also do, but is more risky if the Folable isn't Maybe +-- fold would also do, but is more risky if the Foldable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty