chore(memcached): add key classes for easy invalidation

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

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

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 
+                  , tftStart        = Just tStart
-                  , tftEnd          = Just tEnd  
+                  , 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

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
 

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 ->

src/Handler/Utils/Memcached.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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
+memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet
-  pRes <- doGet
-  maybe id (const . return) pRes $ do
-    res <- act
-    doSet res
 
 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

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
+-- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptins
-occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day)
+occurrencesCompute :: Term -> Occurrences -> Set Day
-occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays)
+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

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