Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

src/Foundation.hs

@@ -49,6 +49,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Data.List (foldr1)
+import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
@@ -110,17 +111,6 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils
 pattern CSheetR tid csh shn ptn
   = CourseR tid csh (SheetR shn ptn)
 
--- Change this to use breadcrumbs, but only last breadcrumb should match
-isSubrouteOf :: Maybe (Route UniWorX) -> (Route UniWorX -> Bool) -- DEPRECATED
-isSubrouteOf Nothing _ = False
-isSubrouteOf (Just (CourseR t2 s2 _))  (CourseR t1 s1 _) = t1 == t2 && s1 == s2
-isSubrouteOf (Just (TermEditR))        (TermShowR)  = True
-isSubrouteOf (Just (TermEditExistR _)) (TermShowR)  = True
-isSubrouteOf (Just r2) r1 = r1 == r2
-
--- isSubrouteOf _ _ = False
-
-
 -- Menus and Favourites
 data MenuItem = MenuItem
     { menuItemLabel :: Text
@@ -195,8 +185,8 @@ liftAR op sc apdb          apg@(APHandler _) = liftAR op sc apg apdb
 
 trueAP,falseAP :: AccessPredicate
 trueAP  = APPure . const $ return Authorized
-falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
--- TODO: I believe falseAP := adminAP
+falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
+
 
 adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
 adminAP = APDB $ \case
@@ -363,9 +353,6 @@ evalAccess r = case route2ap r of
   (APHandler p) -> p r
   (APDB      p) -> runDB $ p r
 
--- TODO: isAuthorized = evalAccess'
-
-
 
 
 -- Please see the documentation for the Yesod typeclass. There are a number
@@ -454,10 +441,11 @@ instance Yesod UniWorX where
                    courseRoute = CourseR courseTerm courseShorthand CShowR
                in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
 
-        let highlight :: Route UniWorX -> Bool
-            highlight = isSubrouteOf mcurrentRoute -- TODO
-            -- IDEA: highlight on last route in breadcrumbs only
-            -- toHighlight = undefined -- TODO: last breadcrumb in order only
+        let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs only
+            highlight = let crumbs = mcons mcurrentRoute $ fst <$> parents
+                            actFav = List.intersect (snd3 <$> favourites) crumbs
+                            highRs = if null actFav then crumbs else actFav
+                        in \r -> r `elem` highRs
 
         -- TODO: Lookup theme in Cookie/DB and set variable accordingly
         -- let currentTheme = "theme--default"

src/Utils.hs

@@ -87,6 +87,11 @@ maybeT x m = runMaybeT m >>= maybe x return
 catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
 catchIfMaybeT p act = catchIf p (lift act) (const mzero)
 
+mcons :: Maybe a -> [a] -> [a]
+mcons Nothing  xs = xs
+mcons (Just x) xs = x:xs
+
+
 ---------------
 -- Exception --
 ---------------