diff --git a/src/Foundation.hs b/src/Foundation.hs index 284fe8ae1..30498f0f3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1977,6 +1977,8 @@ siteLayout' headingOverride widget = do -- isParent r = r == (fst parents) isAuth <- isJust <$> maybeAuthId + + now <- liftIO getCurrentTime -- Lookup Favourites & Theme if possible (favourites', maxFavouriteTerms, currentTheme) <- do @@ -2021,7 +2023,14 @@ siteLayout' headingOverride widget = do E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent - return (course, reason) + E.where_ $ (E.isJust (course E.^. CourseVisibleFrom) + E.&&. course E.^. CourseVisibleFrom E.<=. E.val (Just now) + E.&&. (E.isNothing (course E.^. CourseVisibleTo) + E.||. E.val (Just now) E.<=. course E.^. CourseVisibleTo + ) + ) E.||. isAssociated + + return (course, reason, isLecturer) return ( favCourses , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid @@ -2029,9 +2038,9 @@ siteLayout' headingOverride widget = do ) let favouriteTerms :: [TermIdentifier] - favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites' + 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) + favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, E.Value isLecturer) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do @@ -2053,7 +2062,7 @@ siteLayout' headingOverride widget = do $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) - return (c, courseRoute, items, favouriteReason) + return (c, courseRoute, items, favouriteReason, isLecturer) nav'' <- mconcat <$> sequence [ defaultLinks @@ -2085,10 +2094,10 @@ 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 - favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason)] + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool)] favouriteTermReason tid favReason' = favourites - & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason') - & sortOn (\(Course{..}, _, _, _) -> courseName) + & filter (\(Course{..}, _, _, favReason, _) -> unTermKey courseTerm == tid && favReason == favReason') + & sortOn (\(Course{..}, _, _, _, _) -> courseName) -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -2187,7 +2196,9 @@ siteLayout' headingOverride widget = do isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav/asidenav") - where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") + where + logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") + courseIsVisible Course{courseVisibleFrom,courseVisibleTo} = NTop courseVisibleFrom <= NTop (Just now) && NTop (Just now) <= NTop courseVisibleTo footer :: Widget footer = $(widgetFile "widgets/footer/footer") where isNavFooter = has $ _1 . _NavFooter diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index c27bd7696..d765c5b66 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -21,11 +21,14 @@ $newline never