diff --git a/fill-db.hs b/fill-db.hs index 12301d0d8..725718792 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -25,6 +25,7 @@ main = db $ do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 + , userTheme = AberdeenReds } fhamann <- insert User { userPlugin = "LDAP" @@ -33,6 +34,7 @@ main = db $ do , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" , userMaxFavourites = defaultFavourites + , userTheme = Default } jost <- insert User { userPlugin = "LDAP" @@ -41,6 +43,7 @@ main = db $ do , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 + , userTheme = MintGreen } void . insert $ Term { termName = summer2017 diff --git a/src/Foundation.hs b/src/Foundation.hs index 01eefae68..b3a007a47 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -425,16 +425,19 @@ instance Yesod UniWorX where menuTypes <- filterM (menuItemAccessCallback . menuItem) menu - -- Lookup Favourites & Theme if possible - favourites' <- do + -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! + (favourites',show -> currentTheme) <- do muid <- maybeAuthId case muid of - Nothing -> return [] - (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - return course + Nothing -> return ([],Default) + (Just uid) -> runDB $ do + cs <- E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do + E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) + E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) + E.orderBy [ E.asc $ course E.^. CourseShorthand ] + return course + mt <- get uid + return (cs, fromMaybe Default (userTheme <$> mt)) favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let @@ -447,10 +450,6 @@ instance Yesod UniWorX where 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" - let currentTheme = "theme--aberdeen-reds" :: Text - -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and -- default-layout-wrapper is the entire page. Since the final diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 35b04099f..366ecd167 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -203,10 +203,9 @@ readTheme :: Map String Theme readTheme = Map.fromList [ (show t,t) | t <- allThemes ] instance Read Theme where -- generic Read-Instance for Show/Bounded --- readPrec = undefined readsPrec _ s | (Just t) <- (Map.lookup s readTheme) = [(t,"")] - | otherwise = [(Default,"")] -- read will always succeed + | otherwise = [(Default,"")] -- read shall always succeed derivePersistField "Theme" diff --git a/src/Utils.hs b/src/Utils.hs index faf47afaf..b4066c5f1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -67,8 +67,9 @@ withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) + uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "cmael-case-thing" -uncamel = drop 1 . reverse . foldl helper [] +uncamel = ("theme-" ++) . reverse . foldl helper [] where helper _ '.' = [] helper acc c @@ -76,6 +77,8 @@ uncamel = drop 1 . reverse . foldl helper [] | Char.isUpper c = Char.toLower c : '-' : acc | otherwise = c : acc + + ------------ -- Tuples -- ------------ @@ -86,6 +89,9 @@ snd3 :: (a,b,c) -> b snd3 (_,y,_) = y trd3 :: (a,b,c) -> c trd3 (_,_,z) = z + + + ---------- -- Maps -- ---------- diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 142a48e90..97b1e821c 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -4,7 +4,7 @@ module Utils.Common where -- Common Utility Functions that require TemplateHaskell -import Data.Char +-- import Data.Char import Language.Haskell.TH -- import Control.Monad