Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Gregor Kleen
commit
e6f6e8c621
2
routes
2
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<a href=@{CourseEditExistR tid shd}>
|
||||
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)
|
||||
|
||||
@ -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|Ma<i>thema</i>tik|]
|
||||
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
|
||||
|
||||
|
||||
@ -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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
|
||||
-- [whamlet|
|
||||
-- <form method=post action=@{url}>
|
||||
-- <input type="hidden" name="_formid" value="identify-linkButton">
|
||||
-- <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
|
||||
-- |]
|
||||
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
|
||||
|
||||
|
||||
buttonField :: Button a => a -> Field Handler a
|
||||
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
||||
where
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
fieldView fid name attrs _val _ =
|
||||
[whamlet|
|
||||
<button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
|
||||
|]
|
||||
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse [str] _
|
||||
| str == toPathPiece btn = return $ Right $ Just btn
|
||||
| otherwise = return $ Left "Wrong button value"
|
||||
fieldParse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
fieldView id name attrs _val _ =
|
||||
[whamlet|
|
||||
<button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{id}>^{label btn}
|
||||
|]
|
||||
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a]
|
||||
combinedButtonField1 btns = traverse b2f btns
|
||||
where
|
||||
b2f b = aopt (buttonField b) "n/a" Nothing
|
||||
|
||||
{-
|
||||
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
|
||||
combinedButtonField btns inner csrf = do
|
||||
buttonIdent <- newFormIdent
|
||||
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
|
||||
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
|
||||
(innerRes,innerWdgt) <- inner
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{csrf}
|
||||
^{innerWdgt}
|
||||
<div .btn-group>
|
||||
$forall bView <- btnViews
|
||||
^{fvInput bView}
|
||||
|]
|
||||
let result = case (accResult result, innerRes) of
|
||||
(FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
|
||||
_ -> FormFailure ["Something went wrong"] -- TODO
|
||||
return (result,widget)
|
||||
where
|
||||
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
|
||||
accResult = Foldable.foldr accResult' FormMissing
|
||||
|
||||
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
||||
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
|
||||
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
||||
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
|
||||
accResult' (FormSuccess Nothing) x = x
|
||||
accResult' FormMissing _ = FormMissing
|
||||
accResult' (FormFailure errs) _ = FormFailure errs
|
||||
-}
|
||||
|
||||
-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
|
||||
buttonForm :: (Button a) => Form a
|
||||
@ -71,56 +162,15 @@ buttonForm csrf = do
|
||||
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
||||
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
|
||||
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
||||
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Should Failure override Success?
|
||||
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
|
||||
accResult' (FormSuccess Nothing) x = x
|
||||
accResult' FormMissing _ = FormMissing
|
||||
accResult' (FormFailure errs) _ = FormFailure errs
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
buttonFormOld :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
|
||||
buttonFormOld html = do
|
||||
let
|
||||
buttonValues = [minBound..maxBound]
|
||||
buttonMap = Map.fromList $ zip buttonValues buttonValues
|
||||
button b = Field parse view UrlEncoded
|
||||
where
|
||||
parse [] _ = return $ Right Nothing
|
||||
parse [str] _
|
||||
| str == toPathPiece b = return $ Right $ Just b
|
||||
| otherwise = return $ Left "Wrong button value"
|
||||
parse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
view id name attrs _val _ = do
|
||||
[whamlet|
|
||||
#{html}
|
||||
<button .btn .btn-default type=submit name=#{name} value=#{toPathPiece b} *{attrs} ##{id}>^{label b}
|
||||
|]
|
||||
|
||||
buttonIdent <- newFormIdent
|
||||
resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
|
||||
|
||||
let result = accResult $ fst <$> Map.elems resultWidgetMap
|
||||
let viewF = (Map.!) (snd <$> resultWidgetMap)
|
||||
|
||||
return (result, viewF)
|
||||
where
|
||||
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
|
||||
accResult = Foldable.foldr accResult' FormMissing
|
||||
|
||||
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
||||
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous parse"]
|
||||
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
||||
accResult' _ x@(FormSuccess _) = x
|
||||
accResult' (FormSuccess Nothing) x = x
|
||||
accResult' FormMissing _ = FormMissing
|
||||
accResult' (FormFailure errs) _ = FormFailure errs
|
||||
|
||||
----------------------------
|
||||
-- Buttons (old version ) --
|
||||
----------------------------
|
||||
---------------------------------------
|
||||
-- Buttons (old version, deprecated) --
|
||||
---------------------------------------
|
||||
|
||||
formBtnSave :: (Text,Text,Text)
|
||||
formBtnSave = ("save" ,"Speichern" ,"btn-primary")
|
||||
@ -147,8 +197,7 @@ defaultFormActions = [ formBtnDelete
|
||||
]
|
||||
|
||||
-- Post-Buttons
|
||||
-- postButtonForm :: MonadHandler m =>
|
||||
-- Text -> Text.Blaze.Internal.Markup -> MForm m (FormResult (), WidgetT (HandlerSite m) IO ())
|
||||
postButtonForm :: Text -> Form ()
|
||||
postButtonForm lblId = identifyForm lblId buttonF
|
||||
where
|
||||
buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps
|
||||
|
||||
Loading…
Reference in New Issue
Block a user