Term creation half-ways, problems with Custom Primary key for Terms
This commit is contained in:
SJost
parent
fcec208936
commit
6d3df4f30b
3
models
3
models
@ -8,7 +8,8 @@ Term json
|
||||
start Day
|
||||
end Day
|
||||
holidays [Day]
|
||||
-- UniqueTerm shorthand
|
||||
active Bool
|
||||
UniqueTerm name
|
||||
Primary name
|
||||
deriving Show
|
||||
School json
|
||||
|
||||
4
routes
4
routes
@ -9,4 +9,6 @@
|
||||
/profile ProfileR GET
|
||||
|
||||
|
||||
/assist/newcourse NewCourseR GET POST
|
||||
/assist/newcourse NewCourseR GET POST
|
||||
/assist/newterm NewTermR GET POST
|
||||
/assist/showterm ShowTermR GET
|
||||
|
||||
@ -168,6 +168,8 @@ instance Yesod UniWorX where
|
||||
isAuthorized ProfileR _ = isAuthenticated
|
||||
-- TODO: change to Assistants
|
||||
isAuthorized NewCourseR _ = return Authorized
|
||||
isAuthorized NewTermR _ = return Authorized
|
||||
isAuthorized ShowTermR _ = return Authorized
|
||||
|
||||
-- This function creates static content files in the static folder
|
||||
-- and names them based on a hash of their content. This allows
|
||||
|
||||
@ -8,9 +8,35 @@ module Handler.Assist where
|
||||
|
||||
import Import
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe
|
||||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
||||
import Database.Persist.Class as K (Key)
|
||||
-- import Text.Julius (RawJS (..))
|
||||
|
||||
-- TODO: Move elsewhere
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap checkTerm termToText textField
|
||||
where
|
||||
errTextParse :: Text
|
||||
errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
|
||||
|
||||
errTextFreigabe :: TermIdentifier -> Text
|
||||
errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
|
||||
|
||||
checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
|
||||
checkTerm t = case termFromText t of
|
||||
Left _ -> return $ Left errTextParse
|
||||
res@(Right ti) -> do
|
||||
-- term <- runDB $ get $ Key ti -- TODO: membershiptest instead?
|
||||
term <- runDB $ getBy $ UniqueTerm ti -- TODO: use get instead of getBy?
|
||||
return $ if isNothing term
|
||||
then Left $ errTextFreigabe ti
|
||||
else res
|
||||
|
||||
|
||||
|
||||
-- Handler for Assistants
|
||||
|
||||
data NewCourseForm = NewCourseForm
|
||||
{ ncf_user :: UserId
|
||||
, ncf_term :: TermIdentifier
|
||||
@ -21,57 +47,6 @@ data NewCourseForm = NewCourseForm
|
||||
, ncf_html :: Html
|
||||
, ncf_capacity :: Maybe Int
|
||||
}
|
||||
-- Handler for Assistants
|
||||
|
||||
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 Daten 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")
|
||||
-}
|
||||
|
||||
|
||||
-- TODO: Move elsewhere
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
|
||||
newCourseForm :: UserId -> Form NewCourseForm
|
||||
newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
|
||||
@ -94,3 +69,121 @@ newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
|
||||
[ ("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")
|
||||
-}
|
||||
|
||||
|
||||
getShowTermR :: Handler Html
|
||||
getShowTermR = do
|
||||
terms <- runDB $ selectList [] [Desc TermStart]
|
||||
defaultLayout $ do
|
||||
setTitle "Freigeschaltete Semester"
|
||||
[whamlet|
|
||||
<h2>
|
||||
Liste der freigeschalteten Semeser:
|
||||
$if null terms
|
||||
<p> Es wurden noch kein Semester freigeschaltetet.
|
||||
$else
|
||||
<ul>
|
||||
$forall term <- terms
|
||||
<li> #{show term}
|
||||
|]
|
||||
|
||||
getNewTermR :: Handler Html
|
||||
getNewTermR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
getNewTermDefR Nothing
|
||||
|
||||
|
||||
getNewTermDefR :: Maybe Term -> Handler Html
|
||||
getNewTermDefR mbTerm= do
|
||||
aid <- requireAuthId
|
||||
(formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
|
||||
defaultLayout $ do
|
||||
setTitle "Neues Semester anlegen"
|
||||
$(widgetFile "newTerm")
|
||||
|
||||
postNewTermR :: Handler Html
|
||||
postNewTermR = do
|
||||
aid <- requireAuthId
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newTermForm Nothing
|
||||
case result of
|
||||
FormSuccess res -> do
|
||||
-- term <- runDB $ getBy UniqueTerm $ termName
|
||||
runDB $ insert res
|
||||
let tid = termToText $ termName res
|
||||
let msg = "Semester " `T.append` tid `T.append` " wurde angelegt!"
|
||||
-- setMessage $ toHtml msg -- FIXME
|
||||
setMessage "Semester wurde angelegt"
|
||||
redirect ShowTermR
|
||||
FormMissing -> defaultLayout $ do
|
||||
setMessage "Keine Formulardaten erhalten."
|
||||
$(widgetFile "newTerm")
|
||||
FormFailure errorMsgs -> defaultLayout $ do
|
||||
setMessage [shamlet| <span .error>Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
|]
|
||||
$(widgetFile "newTerm")
|
||||
|
||||
newTermForm :: Maybe Term -> Form Term
|
||||
newTermForm template =
|
||||
renderBootstrap3 BootstrapBasicForm $ Term
|
||||
<$> areq termField (set "Semester") (termName <$> template)
|
||||
<*> areq dayField (set "Erster Tag") (termStart <$> template)
|
||||
<*> areq dayField (set "Letzer Tag") (termEnd <$> template)
|
||||
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
|
||||
<*> areq checkBoxField (set "Aktiv") (termActive <$> template)
|
||||
where set txt = FieldSettings
|
||||
{ fsLabel = txt
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs =
|
||||
[ ("class", "form-control")
|
||||
]
|
||||
}
|
||||
|
||||
@ -58,6 +58,7 @@ data TermIdentifier = TermIdentifier
|
||||
, season :: Season
|
||||
} deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
|
||||
--TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year
|
||||
|
||||
|
||||
@ -15,6 +15,6 @@
|
||||
^{formWidget}
|
||||
|
||||
<button .btn.btn-primary type="submit">
|
||||
Kurs anlegen!
|
||||
Kurs anlegen
|
||||
|
||||
|
||||
20
templates/newTerm.hamlet
Normal file
20
templates/newTerm.hamlet
Normal file
@ -0,0 +1,20 @@
|
||||
<div .container>
|
||||
<div .bs-docs-section>
|
||||
<div .row>
|
||||
<div .col-lg-12>
|
||||
<div .page-header>
|
||||
<h1 #forms>Neues Semester anlegen:
|
||||
|
||||
<p>
|
||||
Bitte alles ausfüllen!
|
||||
|
||||
<div .row>
|
||||
<div .col-lg-6>
|
||||
<div .bs-callout bs-callout-info well>
|
||||
<form .form-horizontal method=post action=@{NewTermR}#forms enctype=#{formEnctype}>
|
||||
^{formWidget}
|
||||
|
||||
<button .btn.btn-primary type="submit">
|
||||
Semester anlegen
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user