fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(memcached): add key classes for easy invalidation

Browse Source
This commit is contained in:
Steffen Jost 2024-09-23 17:09:47 +02:00 committed by Sarah Vaupel
parent cac0a47d01
commit 74c330bd24
8 changed files with 117 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Handler/Course/Edit.hs
View File

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

40
src/Handler/School/DayTasks.hs
View File

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

13
src/Handler/Term.hs
View File

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

1
src/Handler/Tutorial/Edit.hs
View File

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

2
src/Handler/Utils/Delete.hs
View File

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

79
src/Handler/Utils/Memcached.hs
View File

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

13
src/Handler/Utils/Occurrences.hs
View File

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

2
src/Utils.hs
View File

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