diff --git a/routes b/routes index afb0adb90..de7b39e66 100644 --- a/routes +++ b/routes @@ -13,7 +13,7 @@ /term/#TermIdentifier/edit TermEditExistR GET /course/ CourseListR GET -!/course/edit CourseEditR GET POST +!/course/new CourseEditR GET POST !/course/#TermIdentifier CourseListTermR GET /course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermIdentifier/#Text/show CourseShowR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index d81828ca6..4b76dc434 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -68,7 +68,7 @@ data MenuItem = MenuItem } data MenuTypes - = NavbarLeft MenuItem + = NavbarLeft MenuItem | NavbarRight MenuItem -- This is where we define all of the routes in our application. For a full @@ -113,56 +113,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 - } - , 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 @@ -254,6 +205,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 68c7b72c1..7bb536b6d 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -41,19 +41,37 @@ 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 - setTitle "Semesterkurse" + |] + ) + ] + 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) getCourseShowR :: TermIdentifier -> Text -> Handler Html @@ -232,12 +250,12 @@ courseToForm cEntity = CourseForm course = entityVal cEntity newCourseForm :: Maybe CourseForm -> Form CourseForm -newCourseForm template html = do +newCourseForm template = identForm FIDcourse $ \html -> do -- mopt hiddenField --- cidKey <- getsYesod appCryptoIDKey --- courseId <- runMaybeT $ do --- cid <- cfCourseId template --- UUID.encrypt cidKey cid + -- cidKey <- getsYesod appCryptoIDKey + -- courseId <- runMaybeT $ do + -- cid <- cfCourseId template + -- UUID.encrypt cidKey cid (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> aopt hiddenField "KursId" (cfCourseId <$> template) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 6949cf94d..82ea20ded 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -15,7 +15,7 @@ import Handler.Utils import Data.Time import qualified Data.Text as T import Yesod.Form.Bootstrap3 - + import Web.PathPieces (showToPathPiece, readFromPathPiece) import Colonnade @@ -33,31 +33,12 @@ instance PathPiece CreateButton where -- for displaying the button only, not instance Button CreateButton where label CreateMath = [whamlet|Mathematik|] - label CreateInf = "Informatik" + label CreateInf = "Informatik" + cssClass CreateMath = BCInfo + cssClass CreateInf = BCPrimary -- END Button needed here -{- -- Old Version -getHomeR :: Handler Html -getHomeR = do - (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonFormOld - defaultLayout $ do - setTitle "Willkommen zum ReWorX Test!" - $(widgetFile "home") - - -postHomeR :: Handler Html -postHomeR = do - ((btnResult,_), _) <- runFormPost $ buttonFormOld - $(logDebug) $ tshow btnResult - case btnResult of - (FormSuccess CreateInf) -> setMessage "Informatik anlegen" - (FormSuccess CreateMath) -> setMessage "Mathematik anlegen" - _other -> return () - getHomeR - - -} - getHomeR :: Handler Html getHomeR = do (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) @@ -70,8 +51,8 @@ postHomeR :: Handler Html postHomeR = do ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of - (FormSuccess CreateInf) -> setMessage "Informatik anlegen" - (FormSuccess CreateMath) -> setMessage "Mathematik anlegen" + (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" + (FormSuccess CreateMath) -> setMessage "Knopf Mathematik erkannt" _other -> return () getHomeR diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f6a569e9a..89e34f284 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -10,9 +10,7 @@ module Handler.Utils.Form where import Import --- import Data.Time -import Data.Proxy -import qualified Data.Map as Map +import qualified Data.Char as Char import Handler.Utils.DateTime import Data.String (IsString(..)) @@ -25,31 +23,124 @@ import Yesod.Form.Functions (parseHelper) import Yesod.Form.Bootstrap3 import Web.PathPieces (showToPathPiece, readFromPathPiece) -import Text.Blaze (Markup) + +------------------------------------------------ +-- Unique Form Identifiers to avoid accidents -- +------------------------------------------------ + +data FormIdentifier = FIDcourse + deriving (Enum, Eq, Ord, Bounded, Read, Show) + + +identForm :: FormIdentifier -> Form a -> Form a +identForm fid = identifyForm (T.pack $ show fid) + + ---------------------------- -- Buttons (new version ) -- ---------------------------- +data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually +bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc)) + class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where label :: a -> Widget label = toWidget . toPathPiece + cssClass :: a -> ButtonCssClass + cssClass _ = BCDefault + + +--Some standard Buttons useful throughout +data StandardButton = BtnDelete | BtnAbort | BtnSave + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance PathPiece StandardButton where -- for displaying the button only, not really for paths + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece +instance Button StandardButton where + label BtnDelete = "Löschen" + label BtnAbort = "Abbrechen" + label BtnSave = "Speichern" + + cssClass BtnDelete = BCWarning + cssClass BtnAbort = BCDefault + cssClass BtnSave = BCPrimary + +-- -- Looks like a button, but is just a link (e.g. for create course, etc.) +-- data LinkButton = LinkButton (Route UniWorX) +-- deriving (Enum, Eq, Ord, Bounded, Read, Show) +-- +-- instance PathPiece LinkButton where +-- LinkButton route = ??? + +linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget +linkButton lbl cls url = [whamlet| ^{lbl} |] +-- [whamlet| +--
+-- +--