feat(caching): aggressively cache nav items

config/settings.yml

@@ -196,3 +196,9 @@ allocation-grade-ordinal-proportion: 0.075
 
 instance-id: "_env:INSTANCE_ID:instance"
 ribbon: "_env:RIBBON:"
+
+
+favourites-quick-actions-burstsize: 40
+favourites-quick-actions-avg-inverse-rate: 50e3 # µs/token
+favourites-quick-actions-timeout: 40e-3 # s
+favourites-quick-actions-cache-ttl: 120 # s

frontend/src/utils/asidenav/asidenav.sass

@@ -232,12 +232,22 @@
 .asidenav__nested-list
   min-width: 200px
 
+.asidenav__nested-list--unavailable
+ font-size: 0.9rem
+ color: var(--color-fontsec)
+ font-weight: 600
+ padding: 7px
+ min-width: 200px
+
 @media (max-width: 425px)
   .asidenav__list-item
     padding-left: 10px
 
   .asidenav__nested-list
     display: none
+    
+  .asidenav__nested-list--unavailable
+    display: none
 
 .asidenav__nested-list-item
   position: relative
@@ -317,10 +327,9 @@
       color: var(--color-font)
       padding: 0
 
-    .asidenav__nested-list,
+    .asidenav__nested-list, .asidenav__link-label, .asidenav__nested-list--unavailable
-    .asidenav__link-label
       display: none
-
+      
     .asidenav__list-item--active
       .asidenav__link-wrapper
         background-color: var(--color-lightwhite)

messages/uniworx/de-de-formal.msg

@@ -2247,6 +2247,8 @@ FavouriteParticipant: Ihre Kurse
 FavouriteManual: Favoriten
 FavouriteCurrent: Aktueller Kurs
 
+FavouritesUnavailableTip: Das Schnellzugriffsmenü für diesen Kurs ist aktuell nicht verfügbar.
+
 CourseEvents: Termine
 CourseEventType: Art
 CourseEventTypePlaceholder: Vorlesung, Zentralübung, ...

messages/uniworx/en-eu.msg

@@ -2247,6 +2247,8 @@ FavouriteParticipant: Your courses
 FavouriteManual: Favourites
 FavouriteCurrent: Current course
 
+FavouritesUnavailableTip: Quick Actions for this course are currently not available.
+
 CourseEvents: Occurrences
 CourseEventType: Type
 CourseEventTypePlaceholder: Lecture, Exercise discussion, ...

src/Foundation.hs

@@ -9,6 +9,7 @@ module Foundation
   ) where
 
 import Foundation.Type as Foundation
+import Foundation.Types as Foundation
 import Foundation.I18n as Foundation
 import Foundation.Routes as Foundation
 
@@ -72,6 +73,7 @@ import Handler.Utils.ExamOffice.ExternalExam
 import Handler.Utils.ExamOffice.Course
 import Handler.Utils.Profile
 import Handler.Utils.Routes
+import Handler.Utils.Memcached
 import Utils.Form
 import Utils.Sheet
 import Utils.SystemMessage
@@ -121,8 +123,7 @@ data NavQuickView
   = NavQuickViewFavourite
   | NavQuickViewPageActionSecondary
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-instance Universe NavQuickView
+  deriving (Universe, Finite)
-instance Finite NavQuickView
 
 navQuick :: NavQuickView -> (NavQuickView -> Any)
 navQuick x x' = Any $ x == x'
@@ -134,7 +135,9 @@ data NavType
   | NavTypeButton
     { navMethod :: StdMethod
     , navData   :: [(Text, Text)]
-    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Binary)
 
 makeLenses_ ''NavType
 makePrisms ''NavType
@@ -211,7 +214,10 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
     shortCircuit _ = return False
     
     accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
-    accessCheck nt (urlRoute -> route) = bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
+    accessCheck nt (urlRoute -> route) = do
+      authCtx <- getAuthContext
+      $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
+        bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
   
 
 getTimeLocale' :: [Lang] -> TimeLocale
@@ -304,12 +310,31 @@ trueAP  = APPure . const . const . const $ trueAR <$> ask
 falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
 
 
+data AuthContext = AuthContext
+  { authCtxAuth    :: Maybe UserId
+  , authCtxBearer  :: Maybe (BearerToken UniWorX)
+  , authActiveTags :: Set AuthTag
+  } deriving (Eq, Read, Show, Generic, Typeable)
+    deriving anyclass (Hashable, Binary)
+
+getAuthContext :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  )
+               => m AuthContext
+getAuthContext = AuthContext
+  <$> maybeAuthId
+  <*> runMaybeT (exceptTMaybe askBearerUnsafe)
+  <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
+
+
 askBearerUnsafe :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
                   )
-               => ExceptT AuthResult m (BearerToken (UniWorX))
+               => ExceptT AuthResult m (BearerToken UniWorX)
 -- | This performs /no/ meaningful validation of the `BearerToken`
 --
 -- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
@@ -1462,47 +1487,17 @@ data instance ButtonClass UniWorX
   | BCLink
   | BCMassInputAdd | BCMassInputDelete
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe (ButtonClass UniWorX)
+  deriving anyclass (Universe, Finite)
-instance Finite (ButtonClass UniWorX)
 
 instance PathPiece (ButtonClass UniWorX) where
   toPathPiece BCIsButton = "btn"
   toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
   fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
 
-embedRenderMessage ''UniWorX ''ButtonSubmit id
 instance Button UniWorX ButtonSubmit where
   btnClasses BtnSubmit = [BCIsButton, BCPrimary]
 
 
-updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
-                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
-                 -> ReaderT SqlBackend m ()
-updateFavourites cData = void . runMaybeT $ do
-  $logDebugS "updateFavourites" "Updating favourites"
-
-  now <- liftIO $ getCurrentTime
-  uid <- MaybeT $ liftHandler maybeAuthId
-  mcid  <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-  User{userMaxFavourites} <- MaybeT $ get uid
-
-  -- update Favourites
-  for_ mcid $ \cid ->
-    void . lift $ upsertBy
-      (UniqueCourseFavourite uid cid)
-      (CourseFavourite uid cid FavouriteVisited now)
-      [CourseFavouriteLastVisit =. now]
-  -- prune Favourites to user-defined size
-  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
-  let deleteFavs = oldFavs
-        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
-        & drop userMaxFavourites
-        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
-        & map entityKey
-  unless (null deleteFavs) $
-    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
-
-
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
@@ -1717,6 +1712,45 @@ instance Yesod UniWorX where
 --     (Just lang)
 --   return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView)
 
+data MemcachedKeyFavourites
+  = MemcachedKeyFavouriteQuickActions CourseId AuthContext
+  deriving (Eq, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, Binary)
+
+data MemcachedLimitKeyFavourites
+  = MemcachedLimitKeyFavourites
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, Binary)
+
+
+updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
+                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
+                 -> ReaderT SqlBackend m ()
+updateFavourites cData = void . runMaybeT $ do
+  $logDebugS "updateFavourites" "Updating favourites"
+
+  now <- liftIO $ getCurrentTime
+  uid <- MaybeT $ liftHandler maybeAuthId
+  mcid  <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+  User{userMaxFavourites} <- MaybeT $ get uid
+
+  -- update Favourites
+  for_ mcid $ \cid ->
+    void . lift $ upsertBy
+      (UniqueCourseFavourite uid cid)
+      (CourseFavourite uid cid FavouriteVisited now)
+      [CourseFavouriteLastVisit =. now]
+  -- prune Favourites to user-defined size
+  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
+  let deleteFavs = oldFavs
+        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
+        & drop userMaxFavourites
+        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
+        & map entityKey
+  unless (null deleteFavs) $
+    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
+
+
 siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
 siteLayoutMsg msg widget = do
   mr <- getMessageRender
@@ -1812,13 +1846,32 @@ siteLayout' headingOverride widget = do
              , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
              , maybe userDefaultTheme userTheme $ view _2 <$> muid
              )
-  favourites <- forM favourites' $ \(Entity _ c@Course{..}, E.Value mFavourite)
+
+  let favouriteTerms :: [TermIdentifier]
+      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites'
+  
+  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite)
       -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
              favouriteReason = fromMaybe FavouriteCurrent mFavourite
-         in do
+         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
-           items' <- pageQuickActions NavQuickViewFavourite courseRoute
+              ctx <- getAuthContext
-           items <- forM items' $ \n -> (n,) <$> toTextUrl n
+              MsgRenderer mr <- getMsgRenderer
-           return (c, courseRoute, items, favouriteReason)
+              let cK = MemcachedKeyFavouriteQuickActions cId ctx
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
+              items <- memcachedLimitedKeyTimeoutBy
+                MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
+                (Right <$> appFavouritesQuickActionsCacheTTL) 
+                appFavouritesQuickActionsTimeout
+                cK
+                cK
+                . observeFavouritesQuickActionsDuration $ do
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
+                  items' <- pageQuickActions NavQuickViewFavourite courseRoute
+                  items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
+                  return items
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
+              return (c, courseRoute, items, favouriteReason)
 
   nav'' <- mconcat <$> sequence
     [ defaultLinks
@@ -1850,9 +1903,7 @@ siteLayout' headingOverride widget = do
               navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
               highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
       highlightNav = (||) <$> navForceActive <*> highlight
-      favouriteTerms :: [TermIdentifier]
+      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason)]
-      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
-      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(NavLink, Text)], FavouriteReason)]
       favouriteTermReason tid favReason' = favourites
         & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason')
         & sortOn (\(Course{..}, _, _, _) -> courseName)
@@ -4325,17 +4376,7 @@ data CampusUserConversionException
   | CampusUserInvalidFeaturesOfStudy Text
   | CampusUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-instance Exception CampusUserConversionException
+  deriving anyclass (Exception)
-
-embedRenderMessage ''UniWorX ''CampusUserConversionException id
-
-data UpsertCampusUserMode
-  = UpsertCampusUser
-  | UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-makeLenses_ ''UpsertCampusUserMode
-makePrisms ''UpsertCampusUserMode
 
 _upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
 _upsertCampusUserMode mMode cs@Creds{..}
@@ -4812,6 +4853,7 @@ instance YesodAuth UniWorX where
 
 instance YesodAuthPersist UniWorX
 
+  
 unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler f h = do
   logger <- makeLogger f
@@ -4852,3 +4894,8 @@ instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX)
 -- https://github.com/yesodweb/yesod/wiki/Sending-email
 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
+
+
+embedRenderMessage ''UniWorX ''ButtonSubmit id
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id

src/Foundation/Types.hs

@@ -0,0 +1,17 @@
+module Foundation.Types
+  ( UpsertCampusUserMode(..)
+  , _UpsertCampusUser, _UpsertCampusUserDummy, _UpsertCampusUserOther
+  , _upsertCampusUserIdent
+  ) where
+
+import Import.NoFoundation
+
+
+data UpsertCampusUserMode
+  = UpsertCampusUser
+  | UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLenses_ ''UpsertCampusUserMode
+makePrisms ''UpsertCampusUserMode

src/Handler/Utils/Memcached.hs

@@ -2,6 +2,7 @@ module Handler.Utils.Memcached
   ( memcached, memcachedBy
   , memcachedHere, memcachedByHere
   , memcachedSet, memcachedGet
+  , memcachedInvalidate, memcachedByInvalidate
   , memcachedByGet, memcachedBySet
   , memcachedTimeout, memcachedTimeoutBy
   , memcachedTimeoutHere, memcachedTimeoutByHere
@@ -13,7 +14,8 @@ module Handler.Utils.Memcached
   , MemcachedException(..), AsyncTimeoutException(..)
   ) where
 
-import Import hiding (utc, exp)
+import Import.NoFoundation hiding (utc, exp)
+import Foundation.Type
 
 
 import qualified Database.Memcached.Binary.IO as Memcached
@@ -98,16 +100,22 @@ memcachedByGet k = runMaybeT $ do
   (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
   let cKey = memcachedKey aeadKey (Proxy @a) k
   
-  encVal <- fmap toStrict . hoist liftIO . catchIfMaybeT Memcached.isItemNotStored $ Memcached.get_ cKey conn
+  encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn
+
+  $logInfoS "memcached" "Cache hit"
 
   guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
   let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
   nonce <- hoistMaybe $ Saltine.decode nonceBS
   decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey
+
+  $logDebugS "memcached" "Decryption valid"
   
   case Binary.decodeOrFail $ fromStrict decrypted of
     Right (unconsumed, _, v)
-      | null unconsumed -> return v
+      | null unconsumed -> do
+          $logDebugS "memcached" "Deserialization valid"
+          return v
     _other -> mzero
 
 memcachedBySet :: forall a k m.
@@ -124,8 +132,20 @@ memcachedBySet mExp k v = do
     nonce <- liftIO AEAD.newNonce
     let cKey = memcachedKey aeadKey (Proxy @a) k
         encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
-    liftIO $ Memcached.add zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
+    liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
- 
+    $logInfoS "memcached" "Cache store"
+
+memcachedByInvalidate :: forall a k m p.
+                         ( MonadHandler m, HandlerSite m ~ UniWorX
+                         , Typeable a
+                         , Binary k
+                         )
+                      => k -> p a -> m ()
+memcachedByInvalidate k _ = maybeT_ $ do
+  (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
+  let cKey = memcachedKey aeadKey (Proxy @a) k
+  hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn
+
 
 newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
   deriving (Typeable)
@@ -144,6 +164,13 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Maybe Expiry -> a -> m ()
 memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
 
+memcachedInvalidate :: forall (a :: *) m p.
+                       ( MonadHandler m, HandlerSite m ~ UniWorX
+                       , Typeable a
+                       )
+                    => p a -> m ()
+memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)
+
 
 memcachedWith :: Monad m
               => (m (Maybe a), a -> m ()) -> m a -> m a
@@ -208,6 +235,7 @@ memcachedLimit = unsafePerformIO . newTVarIO $ HashMap.empty
 {-# NOINLINE memcachedLimit #-}
 
 memcachedLimitedWith :: ( MonadIO m
+                        , MonadLogger m
                         , Typeable k', Hashable k', Eq k'
                         )
                      => (m (Maybe a), a -> m ())
@@ -231,7 +259,9 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t
           let hm' = HashMap.insertWith (flip const) lK bucket hm
           writeTVar memcachedLimit $! hm'
           return $ HashMap.lookupDefault (error "could not insert new token bucket") lK hm'
-    guardM . liftIO $ tokenBucketTryAlloc bucket burst rate tokens
+    sufficientTokens <- liftIO $ tokenBucketTryAlloc bucket burst rate tokens
+    $logDebugS "memcachedLimitedWith" $ "Sufficient tokens: " <> tshow sufficientTokens
+    guard sufficientTokens
     
     liftAct $ do
       res <- act
@@ -336,6 +366,7 @@ memcachedAsync = unsafePerformIO . newTVarIO $ HashMap.empty
 
 liftAsyncTimeout :: forall k'' a m.
                     ( MonadResource m, MonadUnliftIO m
+                    , MonadLogger m
                     , MonadThrow m
                     , Typeable k'', Hashable k'', Eq k''
                     , Typeable a
@@ -344,7 +375,7 @@ liftAsyncTimeout :: forall k'' a m.
                  -> k''
                  -> m a -> MaybeT m a
 liftAsyncTimeout dt (hashableDynamic -> cK) act = do
-  delay <- liftIO . newDelay . round $ toRational dt / 1e6
+  delay <- liftIO . newDelay . round $ toRational dt * 1e6
 
   act' <- lift $ do
     existing <- traverse castDynamicAsync . HashMap.lookup cK <=< liftIO $ readTVarIO memcachedAsync
@@ -352,8 +383,10 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = do
       Just act' -> return act'
       Nothing -> do
         startAct <- liftIO newEmptyTMVarIO
-        act' <- allocateLinkedAsync $ do
+        act' <- async $ do
+          $logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
           atomically $ takeTMVar startAct
+          $logDebugS "liftAsyncTimeout" $ "Confirmed."
           act
         act'' <- atomically $ do
           hm <- readTVar memcachedAsync
@@ -386,6 +419,7 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = do
       = throwM AsyncTimeoutReturnTypeDoesNotMatchComputationKey
 
 memcachedTimeoutWith :: ( MonadResource m, MonadUnliftIO m
+                        , MonadLogger m
                         , MonadThrow m
                         , Typeable k'', Hashable k'', Eq k''
                         , Typeable a

src/Import/NoModel.hs

@@ -155,6 +155,7 @@ import Prometheus.Instances as Import ()
 import Yesod.Form.Fields.Instances as Import ()
 import Data.MonoTraversable.Instances as Import ()
 import Web.Cookie.Instances as Import ()
+import Network.HTTP.Types.Method.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 

src/Model/Tokens/Bearer.hs

@@ -67,6 +67,8 @@ deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
 deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site)
 deriving instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site)
 
+instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site)
+
 instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
 
 makeLenses_ ''BearerToken

src/Model/Types/Security.hs

@@ -18,8 +18,6 @@ import qualified Data.HashMap.Strict as HashMap
 
 import qualified Data.Aeson.Types as Aeson
 
-import qualified Data.Binary as Binary
-
 import qualified Data.CaseInsensitive as CI
 
 import Model.Types.TH.PathPiece
@@ -86,16 +84,12 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthDevelopment
   | AuthFree
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-
+  deriving anyclass (Universe, Finite, Hashable)
-instance Universe AuthTag
-instance Finite AuthTag
-instance Hashable AuthTag
 
 nullaryPathPiece ''AuthTag $ camelToPathPiece' 1
 pathPieceJSON ''AuthTag
 pathPieceJSONKey ''AuthTag
-
+pathPieceBinary ''AuthTag
-instance Binary AuthTag
 
 
 newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
@@ -120,8 +114,8 @@ derivePersistFieldJSON ''AuthTagActive
 
 data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, Binary)
 
-instance Hashable a => Hashable (PredLiteral a)
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
   , sumEncoding = TaggedObject "val" "var"
@@ -134,12 +128,11 @@ instance PathPiece a => PathPiece (PredLiteral a) where
   fromPathPiece t = PLVariable <$> fromPathPiece t
                 <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
 
-instance Binary a => Binary (PredLiteral a)
-
 
 newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (Semigroup, Monoid)
+  deriving anyclass (Binary, Hashable)
 
 $(return [])
 
@@ -148,10 +141,6 @@ instance ToJSON a => ToJSON (PredDNF a) where
 instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
-instance (Ord a, Binary a) => Binary (PredDNF a) where
-  get = PredDNF <$> Binary.get
-  put = Binary.put . dnfTerms
-
 instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
   toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
   fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words

src/Network/HTTP/Types/Method/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Network.HTTP.Types.Method.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Binary (Binary)
+
+import Network.HTTP.Types.Method
+
+
+deriving instance Generic StdMethod
+instance Binary StdMethod

src/Settings.hs

@@ -160,6 +160,11 @@ data AppSettings = AppSettings
 
     , appMemcachedConf          :: Maybe MemcachedConf
 
+    , appFavouritesQuickActionsBurstsize
+    , appFavouritesQuickActionsAvgInverseRate :: Word64
+    , appFavouritesQuickActionsTimeout      :: DiffTime
+    , appFavouritesQuickActionsCacheTTL     :: Maybe DiffTime
+
     , appInitialInstanceID      :: Maybe (Either FilePath UUID)
     , appRibbon                 :: Maybe Text
     } deriving Show
@@ -501,6 +506,11 @@ instance FromJSON AppSettings where
         appSessionTokenExpiration  <- o .:? "session-token-expiration"
         appSessionTokenEncoding    <- o .: "session-token-encoding"
 
+        appFavouritesQuickActionsBurstsize <- o .: "favourites-quick-actions-burstsize"
+        appFavouritesQuickActionsAvgInverseRate <- o .: "favourites-quick-actions-avg-inverse-rate"
+        appFavouritesQuickActionsTimeout <- o .: "favourites-quick-actions-timeout"
+        appFavouritesQuickActionsCacheTTL <- o .: "favourites-quick-actions-cache-ttl"
+
         return AppSettings{..}
 
 makeClassy_ ''AppSettings

src/Utils/Metrics.hs

@@ -5,6 +5,7 @@ module Utils.Metrics
   , registerReadyMetric
   , withJobWorkerStateLbls
   , observeYesodCacheSize
+  , observeFavouritesQuickActionsDuration
   ) where
 
 import Import.NoFoundation hiding (Vector, Info)
@@ -91,6 +92,13 @@ yesodCacheSize = unsafeRegister $ histogram info buckets
                     "Number of items in Yesod's ghsCache and ghsCacheBy"
         buckets = 0 : histogramBuckets 1 1e6
 
+{-# NOINLINE favouritesQuickActionsDuration #-}
+favouritesQuickActionsDuration :: Histogram
+favouritesQuickActionsDuration = unsafeRegister $ histogram info buckets
+  where info = Info "uni2work_favourites_quick_actions_seconds"
+                    "Duration of time needed to calculate a set of favourite quick actions"
+        buckets = histogramBuckets 500e-6 50
+
 
 withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
 withHealthReportMetrics act = do
@@ -152,3 +160,13 @@ observeYesodCacheSize = do
     GHState{..} <- readIORef handlerState
     let size = fromIntegral $ length ghsCache + length ghsCacheBy
     observe yesodCacheSize size
+
+observeFavouritesQuickActionsDuration :: (MonadIO m, MonadMask m) => m a -> m a
+observeFavouritesQuickActionsDuration act = do
+  start <- liftIO getPOSIXTime
+  res <- handleAll (return . Left) $ Right <$> act
+  end <- liftIO getPOSIXTime
+
+  liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start
+
+  either throwM return res

src/Utils/PathPiece.hs

@@ -6,6 +6,7 @@ module Utils.PathPiece
   , nameToPathPiece, nameToPathPiece'
   , tuplePathPiece
   , pathPieceJSON, pathPieceJSONKey
+  , pathPieceBinary
   ) where
 
 import ClassyPrelude.Yesod
@@ -30,6 +31,9 @@ import Data.Aeson.Types
 import qualified Data.Aeson.Types as Aeson
 
 import Control.Monad.Fail
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
   
 
 mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
@@ -159,3 +163,10 @@ pathPieceJSON tName
         instance FromJSON $(conT tName) where
           parseJSON = Aeson.withText $(TH.lift $ nameBase tName) $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t
       |]
+
+pathPieceBinary :: Name -> DecsQ
+pathPieceBinary tName
+  = [d| instance Binary $(conT tName) where
+          get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece
+          put = Binary.put . toPathPiece
+      |]

templates/widgets/asidenav/asidenav.hamlet

@@ -21,16 +21,20 @@ $newline never
             <h3 .asidenav__box-subtitle>
               _{favReason}
             <ul .asidenav__list.list--iconless>
-              $forall (Course{courseShorthand, courseName}, courseRoute, pageActions, _) <- favouriteTermReason tid favReason
+              $forall (Course{courseShorthand, courseName}, courseRoute, mPageActions, _) <- favouriteTermReason tid favReason
                 <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
                   <a .asidenav__link-wrapper href=@{courseRoute}>
                     <div .asidenav__link-shorthand>#{courseShorthand}
                     <div .asidenav__link-label>#{courseName}
                   <div .asidenav__nested-list-wrapper>
-                    <ul .asidenav__nested-list.list--iconless>
+                    $maybe pageActions <- mPageActions
-                      $forall (NavLink{navLabel}, route) <- pageActions
+                      <ul .asidenav__nested-list.list--iconless>
-                        <li .asidenav__nested-list-item>
+                        $forall (label, route) <- pageActions
-                          <a .asidenav__link-wrapper href=#{route}>_{navLabel}
+                          <li .asidenav__nested-list-item>
+                            <a .asidenav__link-wrapper href=#{route}>#{label}
+                    $nothing
+                      <p .asidenav__nested-list--unavailable>
+                        _{MsgFavouritesUnavailableTip}
 
     <div .asidenav__sigillum>
       <img src=@{StaticR img_lmu_sigillum_svg}>