feat(caching): aggressively cache nav items
This commit is contained in:
Gregor Kleen
parent
466203d866
commit
b9b090992f
@ -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
|
||||
|
||||
@ -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__link-label
|
||||
.asidenav__nested-list, .asidenav__link-label, .asidenav__nested-list--unavailable
|
||||
display: none
|
||||
|
||||
|
||||
.asidenav__list-item--active
|
||||
.asidenav__link-wrapper
|
||||
background-color: var(--color-lightwhite)
|
||||
|
||||
@ -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, ...
|
||||
|
||||
@ -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, ...
|
||||
|
||||
@ -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
|
||||
instance Finite NavQuickView
|
||||
deriving (Universe, Finite)
|
||||
|
||||
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)
|
||||
instance Finite (ButtonClass UniWorX)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
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
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
items <- forM items' $ \n -> (n,) <$> toTextUrl n
|
||||
return (c, courseRoute, items, favouriteReason)
|
||||
in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
|
||||
ctx <- getAuthContext
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
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]
|
||||
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(NavLink, Text)], FavouriteReason)]
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, 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
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
|
||||
data UpsertCampusUserMode
|
||||
= UpsertCampusUser
|
||||
| UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
|
||||
| UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
makeLenses_ ''UpsertCampusUserMode
|
||||
makePrisms ''UpsertCampusUserMode
|
||||
deriving anyclass (Exception)
|
||||
|
||||
_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
|
||||
|
||||
17
src/Foundation/Types.hs
Normal file
17
src/Foundation/Types.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
instance Universe AuthTag
|
||||
instance Finite AuthTag
|
||||
instance Hashable AuthTag
|
||||
deriving anyclass (Universe, Finite, Hashable)
|
||||
|
||||
nullaryPathPiece ''AuthTag $ camelToPathPiece' 1
|
||||
pathPieceJSON ''AuthTag
|
||||
pathPieceJSONKey ''AuthTag
|
||||
|
||||
instance Binary AuthTag
|
||||
pathPieceBinary ''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
|
||||
|
||||
14
src/Network/HTTP/Types/Method/Instances.hs
Normal file
14
src/Network/HTTP/Types/Method/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|]
|
||||
|
||||
@ -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>
|
||||
$forall (NavLink{navLabel}, route) <- pageActions
|
||||
<li .asidenav__nested-list-item>
|
||||
<a .asidenav__link-wrapper href=#{route}>_{navLabel}
|
||||
$maybe pageActions <- mPageActions
|
||||
<ul .asidenav__nested-list.list--iconless>
|
||||
$forall (label, route) <- pageActions
|
||||
<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}>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user