diff --git a/config/settings.yml b/config/settings.yml index 71554542b..a810f4c83 100644 --- a/config/settings.yml +++ b/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 diff --git a/frontend/src/utils/asidenav/asidenav.sass b/frontend/src/utils/asidenav/asidenav.sass index 4ed526a21..c6d6b070e 100644 --- a/frontend/src/utils/asidenav/asidenav.sass +++ b/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__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) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index da03651c3..ed5d44317 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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, ... diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index ea28a16a6..c66f2cdd2 100644 --- a/messages/uniworx/en-eu.msg +++ b/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, ... diff --git a/src/Foundation.hs b/src/Foundation.hs index 2a15e13c8..9fce5c092 100644 --- a/src/Foundation.hs +++ b/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 -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 diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs new file mode 100644 index 000000000..4e21dce2f --- /dev/null +++ b/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 diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 5701fbe99..4e463c970 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 044838cd3..43b7d09d1 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index 807dad35b..c2231f0f9 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index ad6a4c8dc..d292fb525 100644 --- a/src/Model/Types/Security.hs +++ b/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) - -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 diff --git a/src/Network/HTTP/Types/Method/Instances.hs b/src/Network/HTTP/Types/Method/Instances.hs new file mode 100644 index 000000000..144f901a3 --- /dev/null +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index 6e502928b..ce756983e 100644 --- a/src/Settings.hs +++ b/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 diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 2e8b8239c..8f2cfcfa9 100644 --- a/src/Utils/Metrics.hs +++ b/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 diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 7485d2e4b..8d17bfc13 100644 --- a/src/Utils/PathPiece.hs +++ b/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 + |] diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index d40a61264..c27bd7696 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -21,16 +21,20 @@ $newline never

_{favReason}