Course Form works; display not yet.
This commit is contained in:
SJost
parent
d10a629fa2
commit
b980bab1b1
18
models
18
models
@ -29,17 +29,19 @@ DegreeCourse json
|
||||
UniqueDegreeCourse degreeId courseId
|
||||
Course
|
||||
name Text
|
||||
shorthand Text
|
||||
description Html Maybe
|
||||
linkexternal Text Maybe
|
||||
schoolId SchoolId
|
||||
termId TermId -- TermId ist jetzt Text als Typ
|
||||
linkExternal Text Maybe
|
||||
shorthand Text
|
||||
termId TermIdentifier
|
||||
schoolId SchoolId
|
||||
capacity Int Maybe
|
||||
created UTCTime
|
||||
changed UTCTime
|
||||
registerFrom UTCTime
|
||||
registerTo UTCTime
|
||||
UniqueTermShorthand shorthand termId
|
||||
createdBy UserId
|
||||
changedBy UserId
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
CourseTermShort termId shorthand
|
||||
Lecturer
|
||||
userId UserId
|
||||
courseId CourseId
|
||||
@ -113,7 +115,7 @@ TutorialUser
|
||||
tutorialId TutorialId
|
||||
UniqueTutorialUser userId tutorialId
|
||||
Booking
|
||||
termId TermId
|
||||
termId TermIdentifier
|
||||
begin UTCTime
|
||||
end UTCTime
|
||||
weekly Bool
|
||||
|
||||
11
routes
11
routes
@ -8,8 +8,11 @@
|
||||
|
||||
/profile ProfileR GET
|
||||
|
||||
/term ShowTermsR GET
|
||||
/term/edit EditTermR GET POST
|
||||
/term/#TermIdentifier/edit EditTermExistR GET
|
||||
/term TermShowR GET
|
||||
/term/edit TermEditR GET POST
|
||||
/term/#TermIdentifier/edit TermEditExistR GET
|
||||
|
||||
/course CourseShowR GET
|
||||
/course/edit CourseEditR GET POST
|
||||
/course/#TermIdentifier/#Text/edit CourseEditExistR GET
|
||||
|
||||
/assist/newcourse NewCourseR GET POST
|
||||
|
||||
@ -43,7 +43,7 @@ import Handler.Common
|
||||
import Handler.Home
|
||||
import Handler.Profile
|
||||
import Handler.Term
|
||||
import Handler.Assist
|
||||
import Handler.Course
|
||||
|
||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
||||
|
||||
@ -35,7 +35,18 @@ permuteFun perm = lamE pat rhs
|
||||
where pat = map varP $ fn:xs
|
||||
rhs = foldl appE (varE fn) $ map varE ps
|
||||
-- rhs = appE (varE fn) (varE $ xs!!1)
|
||||
ln = length perm
|
||||
ln = length perm
|
||||
xs = [ mkName $ "x" ++ show j | j <- [1..ln] ]
|
||||
ps = [ xs !! (j-1) | j <- perm ]
|
||||
fn = mkName "fn"
|
||||
|
||||
altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
|
||||
altFun perm = lamE pat rhs
|
||||
where pat = map varP $ fn:xs
|
||||
rhs = foldl appE (varE fn) $ map varE ps
|
||||
-- rhs = appE (varE fn) (varE $ xs!!1)
|
||||
mx = maximum perm
|
||||
xs = [ mkName $ "x" ++ show j | j <- [1..mx] ]
|
||||
ps = [ xs !! (j-1) | j <- perm ]
|
||||
fn = mkName "fn"
|
||||
|
||||
|
||||
@ -166,11 +166,16 @@ instance Yesod UniWorX where
|
||||
isAuthorized (StaticR _) _ = return Authorized
|
||||
|
||||
isAuthorized ProfileR _ = isAuthenticated
|
||||
-- TODO: change to Assistants
|
||||
isAuthorized NewCourseR _ = return Authorized
|
||||
isAuthorized EditTermR _ = return Authorized
|
||||
isAuthorized (EditTermExistR _) _ = return Authorized
|
||||
isAuthorized ShowTermsR _ = return Authorized
|
||||
|
||||
-- TODO: all?
|
||||
isAuthorized TermShowR _ = return Authorized
|
||||
isAuthorized CourseShowR _ = return Authorized
|
||||
-- TODO: change to Assistants
|
||||
isAuthorized TermEditR _ = return Authorized
|
||||
isAuthorized (TermEditExistR _) _ = return Authorized
|
||||
isAuthorized CourseEditR _ = return Authorized
|
||||
isAuthorized (CourseEditExistR _ _) _ = return Authorized
|
||||
|
||||
|
||||
-- This function creates static content files in the static folder
|
||||
-- and names them based on a hash of their content. This allows
|
||||
|
||||
@ -1,99 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Handler.Assist where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import qualified Data.Text as T
|
||||
-- import Data.Maybe
|
||||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
||||
-- import Text.Julius (RawJS (..))
|
||||
|
||||
-- TODO: Move elsewhere
|
||||
|
||||
|
||||
|
||||
|
||||
-- Handler for Assistants
|
||||
|
||||
data NewCourseForm = NewCourseForm
|
||||
{ ncf_user :: UserId
|
||||
, ncf_term :: TermIdentifier
|
||||
, ncf_name :: Text
|
||||
, ncf_short :: Text
|
||||
, ncf_description :: Textarea
|
||||
, ncf_homepage :: Maybe Text
|
||||
, ncf_html :: Html
|
||||
, ncf_capacity :: Maybe Int
|
||||
}
|
||||
|
||||
newCourseForm :: UserId -> Form NewCourseForm
|
||||
newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
|
||||
<$> pure uid
|
||||
<*> areq termExistsField (set "Semester") Nothing
|
||||
-- <*> areq textField (set "Semester") Nothing
|
||||
<*> areq textField (set "Name des Kurses") Nothing
|
||||
<*> areq textField (set "Kurs Kürzel (3-4 Zeichen)") Nothing
|
||||
<*> areq textareaField (set "Beschreibung des Kurses") Nothing
|
||||
<*> aopt urlField (set "Externe Kurshomepage") Nothing
|
||||
<*> areq htmlField (set "Beschreibung in HTML") Nothing
|
||||
<*> aopt intField (set "Maximale Teilnehmer") Nothing
|
||||
-- Add attributes like the placeholder and CSS classes.
|
||||
where set txt = FieldSettings
|
||||
{ fsLabel = txt
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs =
|
||||
[ ("class", "form-control")
|
||||
]
|
||||
}
|
||||
|
||||
getShowCourseR :: CourseId -> Handler Html
|
||||
getShowCourseR courseId = do
|
||||
defaultLayout $ do
|
||||
[whamlet|
|
||||
TODO unfinished
|
||||
|]
|
||||
|
||||
getNewCourseR :: Handler Html
|
||||
getNewCourseR = do
|
||||
aid <- requireAuthId
|
||||
(formWidget, formEnctype) <- generateFormPost $ newCourseForm aid
|
||||
defaultLayout $ do
|
||||
setTitle "Neuen Kurs anlegen"
|
||||
[whamlet|
|
||||
User: #{show aid}
|
||||
|]
|
||||
$(widgetFile "newCourse")
|
||||
|
||||
postNewCourseR :: Handler Html
|
||||
postNewCourseR = do
|
||||
aid <- requireAuthId
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm aid
|
||||
case result of
|
||||
FormSuccess res -> defaultLayout $ do
|
||||
setMessage "Got something!"
|
||||
$(widgetFile "newCourse")
|
||||
FormMissing -> defaultLayout $ do
|
||||
setMessage "Keine Formulardaten erhalten."
|
||||
$(widgetFile "newCourse")
|
||||
FormFailure errorMsgs -> defaultLayout $ do
|
||||
setMessage [shamlet| <span .error>Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
|]
|
||||
$(widgetFile "newCourse")
|
||||
|
||||
{-
|
||||
defaultLayout $ do
|
||||
let (commentFormId, commentTextareaId, commentListId) = commentIds
|
||||
aDomId <- newIdent
|
||||
setTitle "Welcome To Yesod!"
|
||||
$(widgetFile "homepage")
|
||||
-}
|
||||
220
src/Handler/Course.hs
Normal file
220
src/Handler/Course.hs
Normal file
@ -0,0 +1,220 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Handler.Course where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import Data.Time
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Form.Bootstrap3
|
||||
|
||||
import Colonnade
|
||||
import Yesod.Colonnade
|
||||
|
||||
|
||||
getCourseShowR :: Handler TypedContent
|
||||
getCourseShowR = do
|
||||
terms <- runDB $ selectList [] [Desc TermStart]
|
||||
selectRep $ do
|
||||
provideRep $ return $ toJSON terms
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ headed "Kürzel" $ (\t -> let tn = termName t in do
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tn) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{TermEditExistR tn}>
|
||||
#{termToText tn}
|
||||
$else
|
||||
#{termToText tn}
|
||||
|] )
|
||||
, headed "Beginn Vorlesungen" $ fromString.formatTimeGerWD.termLectureStart
|
||||
, headed "Ende Vorlesungen" $ fromString.formatTimeGerWD.termLectureEnd
|
||||
, headed "Aktiv" (\t -> if termActive t then tickmark else "")
|
||||
-- , Colonnade.bool (Headed "Aktiv") termActive (const tickmark) (const "")
|
||||
, headed "Semesteranfang" $ fromString.formatTimeGerWD.termStart
|
||||
, headed "Semesterende" $ fromString.formatTimeGerWD.termEnd
|
||||
, headed "Feiertage im Semester" $
|
||||
fromString.(intercalate ", ").(map formatTimeGerWD).termHolidays
|
||||
]
|
||||
defaultLayout $ do
|
||||
setTitle "Freigeschaltete Semester"
|
||||
encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal terms)
|
||||
|
||||
|
||||
getCourseEditR :: Handler Html
|
||||
getCourseEditR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
courseEditHandler Nothing
|
||||
|
||||
postCourseEditR :: Handler Html
|
||||
postCourseEditR = courseEditHandler Nothing
|
||||
|
||||
getCourseEditExistR :: TermIdentifier -> Text -> Handler Html
|
||||
getCourseEditExistR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler course
|
||||
|
||||
|
||||
courseEditHandler :: Maybe (Entity Course) -> Handler Html
|
||||
courseEditHandler course = do
|
||||
aid <- requireAuthId
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
|
||||
action <- lookupPostParam "formaction"
|
||||
case (result,action) of
|
||||
(FormSuccess res, fAct)
|
||||
| fAct == formActionDelete
|
||||
, Just cid <- cfCourseId res -> do
|
||||
runDB $ delete cid -- TODO Sicherheitsabfrage einbauen!
|
||||
let cti = termToText $ cfTerm res
|
||||
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |]
|
||||
redirect CourseShowR
|
||||
| fAct == formActionSave
|
||||
, Just cid <- cfCourseId res -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
update cid
|
||||
[ CourseName =. cfName res
|
||||
, CourseDescription =. cfDesc res
|
||||
, CourseLinkExternal =. cfLink res
|
||||
, CourseSchoolId =. cfSchool res
|
||||
, CourseCapacity =. cfCapacity res
|
||||
, CourseRegisterFrom =. cfRegFrom res
|
||||
, CourseRegisterTo =. cfRegTo res
|
||||
, CourseChangedBy =. aid
|
||||
, CourseChanged =. actTime
|
||||
]
|
||||
let cti = termToText $ cfTerm res
|
||||
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
|
||||
| fAct == formActionSave
|
||||
, Nothing <- cfCourseId res -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
insertOkay <- runDB $ insertUnique $ Course
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTermId = cfTerm res
|
||||
, courseSchoolId = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseRegisterFrom = cfRegFrom res
|
||||
, courseRegisterTo = cfRegTo res
|
||||
, courseCreated = actTime
|
||||
, courseChanged = actTime
|
||||
, courseCreatedBy = aid
|
||||
, courseChangedBy = aid
|
||||
}
|
||||
case insertOkay of
|
||||
(Just cid) -> do
|
||||
runDB $ insert_ $ Lecturer aid cid
|
||||
let cti = termToText $ cfTerm res
|
||||
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde angelegt. |]
|
||||
redirect CourseShowR
|
||||
Nothing -> do
|
||||
let cti = termToText $ cfTerm res
|
||||
setMessage $ [shamlet|
|
||||
<div .alert .alert-danger>
|
||||
Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.
|
||||
|]
|
||||
(FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren."
|
||||
_other -> return ()
|
||||
let formTitle = "Kurs editieren/anlegen" :: Text
|
||||
let actionUrl = TermEditR
|
||||
let formActions = defaultFormActions
|
||||
defaultLayout $ do
|
||||
setTitle [shamlet| #{formTitle} |]
|
||||
$(widgetFile "generic_form")
|
||||
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId
|
||||
, cfName :: Text
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfShort :: Text
|
||||
, cfTerm :: TermIdentifier
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm cEntity = CourseForm
|
||||
{ cfCourseId = Just $ entityKey cEntity
|
||||
, cfName = courseName course
|
||||
, cfDesc = courseDescription course
|
||||
, cfLink = courseLinkExternal course
|
||||
, cfShort = courseShorthand course
|
||||
, cfTerm = courseTermId course
|
||||
, cfSchool = courseSchoolId course
|
||||
, cfCapacity = courseCapacity course
|
||||
, cfRegFrom = courseRegisterFrom course
|
||||
, cfRegTo = courseRegisterTo course
|
||||
}
|
||||
where
|
||||
course = entityVal cEntity
|
||||
|
||||
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
||||
newCourseForm template html = do
|
||||
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
|
||||
<$> pure Nothing -- $ join (cfCourseId <$> template)
|
||||
<*> areq textField (set "Name") (cfName <$> template)
|
||||
<*> aopt htmlField (set "Beschreibung") (cfDesc <$> template)
|
||||
<*> aopt urlField (set "Homepage") (cfLink <$> template)
|
||||
<*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template)
|
||||
<*> areq termExistsField (set "Semester") (cfTerm <$> template)
|
||||
<*> areq (selectField schools) (set "Institut") (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template)
|
||||
<*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template)
|
||||
return $ case result of
|
||||
FormSuccess courseResult
|
||||
| errorMsgs <- validateCourse courseResult
|
||||
, not $ null errorMsgs ->
|
||||
(FormFailure errorMsgs,
|
||||
[whamlet|
|
||||
<div class="alert alert-danger">
|
||||
<h4> Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
^{widget}
|
||||
|]
|
||||
)
|
||||
_ -> (result, widget)
|
||||
where
|
||||
set :: Text -> FieldSettings site
|
||||
set = bfs
|
||||
|
||||
setAttrs :: Text -> [(Text,Text)] -> FieldSettings site
|
||||
setAttrs t attrs =
|
||||
let ifs = bfs t in ifs { fsAttrs= attrs++(fsAttrs ifs) }
|
||||
|
||||
setToolt :: Text -> String -> FieldSettings site
|
||||
setToolt t tt =
|
||||
let ifs = bfs t in ifs { fsTooltip= Just $ fromString tt }
|
||||
|
||||
-- schools :: GHandler UniWorX UniWorX (OptionList SchoolId)
|
||||
schools = do
|
||||
entities <- runDB $ selectList [] [Asc SchoolShorthand]
|
||||
optionsPairs $ map (\school -> (schoolShorthand $ entityVal school, entityKey school)) entities
|
||||
|
||||
validateCourse :: CourseForm -> [Text]
|
||||
validateCourse (CourseForm{..}) =
|
||||
[ msg | (False, msg) <-
|
||||
[
|
||||
( cfRegFrom <= cfRegTo
|
||||
, "Ende der Anmeldungszeit muss nach dem Anfang liegen"
|
||||
)
|
||||
] ]
|
||||
|
||||
|
||||
@ -18,18 +18,18 @@ import Colonnade
|
||||
import Yesod.Colonnade
|
||||
|
||||
|
||||
getShowTermsR :: Handler TypedContent
|
||||
getShowTermsR = do
|
||||
getTermShowR :: Handler TypedContent
|
||||
getTermShowR = do
|
||||
terms <- runDB $ selectList [] [Desc TermStart]
|
||||
selectRep $ do
|
||||
provideRep $ return $ toJSON terms
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ headed "Kürzel" $ (\t -> let tn = termName t in do
|
||||
adminLink <- handlerToWidget $ isAuthorized (EditTermExistR tn) False
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tn) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{EditTermExistR tn}>
|
||||
<a href=@{TermEditExistR tn}>
|
||||
#{termToText tn}
|
||||
$else
|
||||
#{termToText tn}
|
||||
@ -48,16 +48,16 @@ getShowTermsR = do
|
||||
encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal terms)
|
||||
|
||||
|
||||
getEditTermR :: Handler Html
|
||||
getEditTermR = do
|
||||
getTermEditR :: Handler Html
|
||||
getTermEditR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
termEditHandler Nothing
|
||||
|
||||
postEditTermR :: Handler Html
|
||||
postEditTermR = termEditHandler Nothing
|
||||
postTermEditR :: Handler Html
|
||||
postTermEditR = termEditHandler Nothing
|
||||
|
||||
getEditTermExistR :: TermIdentifier -> Handler Html
|
||||
getEditTermExistR tid = do
|
||||
getTermEditExistR :: TermIdentifier -> Handler Html
|
||||
getTermEditExistR tid = do
|
||||
term <- runDB $ get $ TermKey tid
|
||||
termEditHandler term
|
||||
|
||||
@ -73,19 +73,19 @@ termEditHandler term = do
|
||||
let tid = termToText $ termName res
|
||||
let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht."
|
||||
setMessage $ [shamlet| #{msg} |]
|
||||
redirect ShowTermsR
|
||||
redirect TermShowR
|
||||
| fAct == formActionSave -> do
|
||||
-- term <- runDB $ get $ TermKey termName
|
||||
runDB $ repsert (TermKey $ termName res) res
|
||||
let tid = termToText $ termName res
|
||||
let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
|
||||
setMessage [shamlet| #{msg} |]
|
||||
redirect ShowTermsR
|
||||
| otherwise -> redirect ShowTermsR
|
||||
redirect TermShowR
|
||||
| otherwise -> redirect TermShowR
|
||||
(FormMissing,_) -> return ()
|
||||
(FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren."
|
||||
let formTitle = "Semester editieren/anlegen" :: Text
|
||||
let actionUrl = EditTermR
|
||||
let actionUrl = TermEditR
|
||||
let formActions = defaultFormActions
|
||||
defaultLayout $ do
|
||||
setTitle [shamlet| #{formTitle} |]
|
||||
@ -95,7 +95,7 @@ termEditHandler term = do
|
||||
wdgtTermForm :: (ToWidget UniWorX a) => a -> Enctype -> Handler Html
|
||||
wdgtTermForm formWidget formEnctype = do
|
||||
let formTitle = "Semester editieren/anlegen" :: Text
|
||||
let actionUrl = EditTermR
|
||||
let actionUrl = TermEditR
|
||||
let formActions = defaultFormActions
|
||||
defaultLayout $ do
|
||||
setTitle [shamlet| #{formTitle} |]
|
||||
@ -107,11 +107,11 @@ newTermForm template html = do
|
||||
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term
|
||||
<$> areq termNewField (bfs ("Semester" :: Text)) (termName <$> template)
|
||||
<*> areq dayField (bfs ("Erster Tag" :: Text)) (termStart <$> template)
|
||||
<*> areq dayField (set "Letzer Tag") (termEnd <$> template)
|
||||
<*> areq dayField (bfs ("Letzer Tag" :: Text)) (termEnd <$> template)
|
||||
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
|
||||
<*> areq dayField (bfs ("Beginn Vorlesungen" :: Text)) (termLectureStart <$> template)
|
||||
<*> areq dayField (set "Ende Vorlesungen") (termLectureEnd <$> template)
|
||||
<*> areq checkBoxField (set "Aktiv") (termActive <$> template)
|
||||
<*> areq dayField (bfs ("Ende Vorlesungen" :: Text)) (termLectureEnd <$> template)
|
||||
<*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
|
||||
-- <* bootstrapSubmit (bsSubmit "Semester bearbeiten")
|
||||
return $ case result of
|
||||
FormSuccess termResult
|
||||
@ -128,12 +128,8 @@ newTermForm template html = do
|
||||
|]
|
||||
)
|
||||
_ -> (result, widget)
|
||||
where set txt = FieldSettings
|
||||
{ fsLabel = txt
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs =
|
||||
[ ("class", "form-control")
|
||||
]
|
||||
}
|
||||
{-
|
||||
where
|
||||
set :: Text -> FieldSettings site
|
||||
set = bfs
|
||||
-}
|
||||
|
||||
@ -2,6 +2,7 @@ module Handler.Utils.DateTime where
|
||||
|
||||
import Data.Time
|
||||
|
||||
|
||||
germanTimeLocale :: TimeLocale
|
||||
germanTimeLocale = TimeLocale
|
||||
{ wDays = [("Montag" ,"Mo")
|
||||
|
||||
@ -1,16 +1,24 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Handler.Utils.Form where
|
||||
module Handler.Utils.Form where
|
||||
|
||||
import Import
|
||||
-- import Data.Time
|
||||
import Handler.Utils.DateTime
|
||||
import Data.String (IsString(..))
|
||||
|
||||
-- import Yesod.Core
|
||||
-- import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
-- import Yesod.Form.Types
|
||||
-- import Yesod.Form.Functions
|
||||
import Yesod.Form.Functions (parseHelper)
|
||||
|
||||
|
||||
|
||||
formBtnSave :: (Text,Text,Text)
|
||||
formBtnSave = ("save" ,"Speichern" ,"btn-primary")
|
||||
@ -35,3 +43,44 @@ defaultFormActions = [ formBtnDelete
|
||||
, formBtnAbort
|
||||
, formBtnSave
|
||||
]
|
||||
|
||||
------------
|
||||
-- Fields --
|
||||
------------
|
||||
|
||||
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
||||
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
|
||||
|
||||
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
||||
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField
|
||||
|
||||
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
|
||||
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
|
||||
|
||||
|
||||
schoolField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId
|
||||
schoolField = undefined -- TODO
|
||||
|
||||
utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
|
||||
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
||||
utcTimeField = Field
|
||||
{ fieldParse = parseHelper $ readTime
|
||||
, fieldView = \theId name attrs val isReq ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id showTime val}">
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
fieldTimeFormat :: String
|
||||
fieldTimeFormat = "%e.%m.%y %k:%M"
|
||||
|
||||
readTime :: Text -> Either FormMessage UTCTime
|
||||
readTime t =
|
||||
case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
(Just time) -> Right time
|
||||
Nothing -> Left $ MsgInvalidEntry "Datum/Zeit Format: tt.mm.yy hh:mm"
|
||||
|
||||
showTime :: UTCTime -> Text
|
||||
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
|
||||
|
||||
@ -15,6 +15,7 @@ import Model.Types
|
||||
|
||||
termExistsField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termExistsField = termField True
|
||||
-- TODO: Change this to an option list of active terms
|
||||
|
||||
termNewField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termNewField = termField False
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#{formTitle}
|
||||
|
||||
<div .row>
|
||||
<div .col-lg-6>
|
||||
<div .col-md-10 .col-lg-9>
|
||||
<div .bs-callout bs-callout-info well>
|
||||
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
|
||||
^{formWidget}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user