From 39b3cd0bec3d3d1040f333cce3574937abfa138f Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 24 Nov 2017 15:20:26 +0100 Subject: [PATCH] defaultHandler gained argument for page navigation --- src/Foundation.hs | 121 +++++++++++++++++++++++------------------- src/Handler/Course.hs | 23 ++++++-- 2 files changed, 86 insertions(+), 58 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 092cc5f1b..3b7094c9d 100644 --- a/src/Foundation.hs +++ b/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 - 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") + defaultLayout = defaultMenuLayout defaultLinks -- 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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 819f64edc..7bb536b6d 100644 --- a/src/Handler/Course.hs +++ b/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 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)