Theme is now read from Database

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

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

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"
 

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 --
 ----------

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