fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

defaultHandler gained argument for page navigation

Browse Source
This commit is contained in:
SJost 2017-11-24 15:20:26 +01:00
parent 1b272c6ee8
commit 39b3cd0bec
2 changed files with 86 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
src/Foundation.hs
View File

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

23
src/Handler/Course.hs
View File

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