perf: cache system-message visibility times

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

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