From 33171a28d78ce11bca550b4c4283e4d39c9b0bd7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Wed, 21 Jul 2021 21:55:25 +0200
Subject: [PATCH] perf: cache system-message visibility times

---
 src/Foundation/Authorization.hs | 21 +++++++++++++++++----
 src/Handler/SystemMessage.hs    | 10 ++++++++++
 2 files changed, 27 insertions(+), 4 deletions(-)

diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 4c5cf6683..b9ee6ad72 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -479,6 +479,7 @@ data AuthorizationCacheKey
   | AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
   | AuthCacheLecturerList | AuthCacheExternalExamStaffList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
   | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
+  | AuthCacheVisibleSystemMessages
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving anyclass (Hashable, Binary)
 
@@ -1053,10 +1054,22 @@ tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrit
 
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
     smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
-    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
-    cTime <- NTop . Just <$> liftIO getCurrentTime
-    guard $ NTop systemMessageFrom <= cTime
-         && NTop systemMessageTo   >= cTime
+    cTime <- liftIO getCurrentTime
+    let cacheTime = diffDay
+        massageVisible = Map.fromList . map (over _1 E.unValue . over (_2 . _1) E.unValue . over (_2 . _2) E.unValue)
+    visibleSystemMessages <- lift . memcacheAuth' @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime)) (Right cacheTime) AuthCacheVisibleSystemMessages . fmap massageVisible . E.select . E.from $ \systemMessage -> do
+      E.where_ $ E.maybe E.true (E.>=. E.val cTime) (systemMessage E.^. SystemMessageTo)
+           E.&&. E.maybe E.false (E.<=. E.val (realToFrac diffDay `addUTCTime` cTime)) (systemMessage E.^. SystemMessageFrom) -- good enough.
+      return
+        ( systemMessage E.^. SystemMessageId
+        , ( systemMessage E.^. SystemMessageFrom
+          , systemMessage E.^. SystemMessageTo
+          )
+        )
+    (msgFrom, msgTo) <- hoistMaybe $ Map.lookup smId visibleSystemMessages
+    let cTime' = NTop $ Just cTime
+    guard $ NTop msgFrom <= cTime'
+         && NTop msgTo   >= cTime'
     return Authorized
 
   MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index f472d932c..521634de4 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -21,6 +21,12 @@ import qualified Database.Esqueleto.Legacy as E
 
 -- htmlField' moved to Handler.Utils.Form/Fields
 
+invalidateVisibleSystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
+                                => m ()
+invalidateVisibleSystemMessages
+  = memcachedByInvalidate AuthCacheVisibleSystemMessages $ Proxy @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime))
+  
+
 getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR
 postMessageR cID = do
@@ -138,6 +144,7 @@ postMessageR cID = do
   where
     modifySystemMessage smId sm = do
       runDB $ replace smId sm
+      invalidateVisibleSystemMessages
       addMessageI Success MsgSystemMessageEditSuccess
       redirect $ MessageR cID
 
@@ -258,18 +265,21 @@ postMessageListR = do
       | not $ null selection -> do
           selection' <- traverse decrypt $ Set.toList selection
           runDB $ deleteWhere [ SystemMessageId <-. selection' ]
+          invalidateVisibleSystemMessages
           $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
           redirect MessageListR
     FormSuccess (SMDActivate ts, selection)
       | not $ null selection -> do
           selection' <- traverse decrypt $ Set.toList selection
           runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
+          invalidateVisibleSystemMessages
           $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
           redirect MessageListR
     FormSuccess (SMDDeactivate ts, selection)
       | not $ null selection -> do
           selection' <- traverse decrypt $ Set.toList selection
           runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
+          invalidateVisibleSystemMessages
           $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
           redirect MessageListR
     FormSuccess (_, _selection) -- prop> null _selection