defaultHandler gained argument for page navigation

src/Foundation.hs

@@ -105,61 +105,7 @@ instance Yesod UniWorX where
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
     yesodMiddleware = defaultYesodMiddleware
 
-    defaultLayout widget = do
+    defaultLayout = defaultMenuLayout defaultLinks
-        master <- getYesod
-        mmsgs <- getMessages
-
-        muser <- maybeAuthPair
-        mcurrentRoute <- getCurrentRoute
-
-        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-        (title, parents) <- breadcrumbs
-
-        -- Define the menu items of the header.
-        let menuItems =
-                [ NavbarLeft $ MenuItem
-                    { menuItemLabel = "Home"
-                    , menuItemRoute = HomeR
-                    , menuItemAccessCallback = True
-                    }
-                , NavbarLeft $ MenuItem
-                    { menuItemLabel = "Profile"
-                    , menuItemRoute = ProfileR
-                    , menuItemAccessCallback = isJust muser
-                    }
-                , NavbarLeft $ MenuItem
-                    { menuItemLabel = "Kurse"
-                    , menuItemRoute = CourseListR
-                    , menuItemAccessCallback = True
-                    }                    
-                , NavbarRight $ MenuItem
-                    { menuItemLabel = "Login"
-                    , menuItemRoute = AuthR LoginR
-                    , menuItemAccessCallback = isNothing muser
-                    }
-                , NavbarRight $ MenuItem
-                    { menuItemLabel = "Logout"
-                    , menuItemRoute = AuthR LogoutR
-                    , menuItemAccessCallback = isJust muser
-                    }
-                ]
-
-        let navbarLeftMenuItems  = [x | NavbarLeft  x <- menuItems]
-        let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
-
-        let navbarLeftFilteredMenuItems  = [x | x <- navbarLeftMenuItems , menuItemAccessCallback x]
-        let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-
-        -- 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
-        -- value passed to hamletToRepHtml cannot be a widget, this allows
-        -- you to use normal widget features in default-layout.
-
-        pc <- widgetToPageContent $ do
-            addStylesheet $ StaticR css_bootstrap_css
-            $(widgetFile "default-layout")
-        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
@@ -251,6 +197,71 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)
 
+  
+defaultLinks :: Maybe (UserId, User) -> [MenuTypes]
+defaultLinks muser = -- Define the menu items of the header.
+  [ NavbarLeft $ MenuItem
+      { menuItemLabel = "Home"
+      , menuItemRoute = HomeR
+      , menuItemAccessCallback = True
+      }
+  , NavbarLeft $ MenuItem
+      { menuItemLabel = "Kurse"
+      , menuItemRoute = CourseListR
+      , menuItemAccessCallback = True
+      }                    
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Profile"
+      , menuItemRoute = ProfileR
+      , menuItemAccessCallback = isJust muser
+      }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Login"
+      , menuItemRoute = AuthR LoginR
+      , menuItemAccessCallback = isNothing muser
+      }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Logout"
+      , menuItemRoute = AuthR LogoutR
+      , menuItemAccessCallback = isJust muser
+      }
+  ]
+
+defaultLinkLayout :: (Maybe (UserId, User) -> [MenuTypes]) -> Widget -> Handler Html
+defaultLinkLayout menu = defaultMenuLayout defaultsPlusMenu
+  where 
+    defaultsPlusMenu = (++) <$> defaultLinks <*> menu
+
+defaultMenuLayout :: (Maybe (UserId, User) -> [MenuTypes]) 
+                          -> Widget -> Handler Html
+defaultMenuLayout menu widget = do
+    master <- getYesod
+    mmsgs <- getMessages
+
+    muser <- maybeAuthPair
+    mcurrentRoute <- getCurrentRoute
+
+    -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
+    (title, parents) <- breadcrumbs
+
+    let menuItems = menu muser
+    let navbarLeftMenuItems  = [x | NavbarLeft  x <- menuItems]
+    let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
+    let navbarLeftFilteredMenuItems  = [x | x <- navbarLeftMenuItems , menuItemAccessCallback x]
+    let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
+
+    -- 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
+    -- value passed to hamletToRepHtml cannot be a widget, this allows
+    -- you to use normal widget features in default-layout.
+
+    pc <- widgetToPageContent $ do
+        addStylesheet $ StaticR css_bootstrap_css
+        $(widgetFile "default-layout")
+    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+  
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend

src/Handler/Course.hs

@@ -41,18 +41,35 @@ getCourseListTermR tidini = do
 --         , headed "Institut" $ [shamlet| #{course} |]
         , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom
         , headed "Ende Anmeldung"   $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo
+-- TODO        
+--         , headed "Teilnehmer" $ (\c -> do
+--               let cid = courseId c
+--               partiNum <- runDB $ count [CourseParticipantCourseId ==. cid]
+--               return $ fromString $ show partiNum
+--             )
         , headed " " $ (\c -> 
             let shd = courseShorthand c  
                 tid = unTermKey $ courseTermId c
             in do
               adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
+              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
               [whamlet| 
                 $if adminLink == Authorized
                   <a href=@{CourseEditExistR tid shd}>
                     editieren
-              |] )  
+              |]
-        ]  
+          )  
-  defaultLayout $ do
+        ]
+  allowedNew <- isAuthorized CourseEditR False
+  let pageLinks muser = 
+        [ NavbarLeft $ MenuItem
+          { menuItemLabel = "Neuer Kurs"
+          , menuItemRoute = CourseEditR
+          , menuItemAccessCallback = Authorized == allowedNew
+          }
+        ] 
+  defaultLinkLayout pageLinks $ do
+--   defaultLayout $ do
     setTitle "Semesterkurse"  
     linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
     encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal courses)