Model changed according to discussion (compiles, but runs only after non-safe SQL migration)
This commit is contained in:
SJost
parent
586d411162
commit
e85b130a0d
3
.gitignore
vendored
3
.gitignore
vendored
@ -24,3 +24,6 @@ uniworx.nix
|
||||
.gup/
|
||||
.dbsettings.yml
|
||||
*.kate-swp
|
||||
src/Handler/Assist.bak
|
||||
src/Handler/Course.SnapCustom.hs
|
||||
|
||||
|
||||
22
models
22
models
@ -38,7 +38,8 @@ Course
|
||||
created UTCTime
|
||||
changed UTCTime
|
||||
createdBy UserId
|
||||
changedBy UserId
|
||||
changedBy UserId
|
||||
hasRegistration Bool default=TRUE -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
CourseTermShort termId shorthand
|
||||
@ -46,6 +47,19 @@ Lecturer
|
||||
userId UserId
|
||||
courseId CourseId
|
||||
UniqueLecturer userId courseId
|
||||
Corrector
|
||||
userId UserId
|
||||
courseId CourseId
|
||||
load Load
|
||||
-- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet
|
||||
-- WHERE ( tutorialTutor = correctorUserId
|
||||
-- && tutorialCourse = correctorCourseId
|
||||
-- && tutorialUserTutorial = tutorialId
|
||||
-- && submissionUser = tutorialUserUser
|
||||
-- && sheetId = submissionSheetId
|
||||
-- && sheetCourse = correctorCourseId
|
||||
-- )
|
||||
UniqueCorrector userId courseId
|
||||
CourseParticipant
|
||||
userId UserId
|
||||
courseId CourseId
|
||||
@ -76,10 +90,10 @@ File
|
||||
deriving Show Eq
|
||||
Submission
|
||||
sheetId SheetId
|
||||
ratingBy UserId Maybe
|
||||
ratingPoints Points Maybe
|
||||
ratingComment Text Maybe
|
||||
rated UTCTime Maybe
|
||||
ratingBy UserId Maybe
|
||||
ratingTime UTCTime Maybe
|
||||
created UTCTime
|
||||
changed UTCTime
|
||||
createdBy UserId
|
||||
@ -107,6 +121,7 @@ SubmissionGroupUser
|
||||
Tutorial json
|
||||
name Text
|
||||
tutor UserId
|
||||
course CourseId -- ?
|
||||
TutorialUser
|
||||
userId UserId
|
||||
tutorialId TutorialId
|
||||
@ -159,4 +174,3 @@ ExamUser
|
||||
-- CONTINUE HERE: Inlcude rating in this table or seperatly?
|
||||
UniqueExamUser userId examId
|
||||
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
|
||||
|
||||
|
||||
4
routes
4
routes
@ -16,7 +16,7 @@
|
||||
!/course/edit CourseEditR GET POST
|
||||
!/course/#TermIdentifier CourseListTermR GET
|
||||
/course/#TermIdentifier/#Text/edit CourseEditExistR GET
|
||||
/course/#TermIdentifier/#Text/show CourseShowR GET
|
||||
/course/#TermIdentifier/#Text/show CourseShowR GET
|
||||
|
||||
-- For demonstration
|
||||
/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
|
||||
/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
|
||||
|
||||
@ -61,8 +61,8 @@ getCourseShowR tid csh = do
|
||||
(courseEnt,(schoolMB,participants)) <- runDB $ do
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
|
||||
dependent <- (,)
|
||||
<$> get (courseSchoolId course)
|
||||
<*> count [CourseParticipantCourseId ==. cid]
|
||||
<$> get (courseSchoolId course) -- join
|
||||
<*> count [CourseParticipantCourseId ==. cid] -- join
|
||||
return $ (courseEnt,dependent)
|
||||
let course = entityVal courseEnt
|
||||
defaultLayout $ do
|
||||
@ -95,13 +95,11 @@ courseEditHandler course = do
|
||||
aid <- requireAuthId
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
|
||||
action <- lookupPostParam "formaction"
|
||||
liftIO $ putStrLn "================" -- DEBUG
|
||||
liftIO $ print (result,action) -- DEBUG
|
||||
case (result,action) of
|
||||
(FormSuccess res, fAct)
|
||||
| fAct == formActionDelete
|
||||
, Just cid <- cfCourseId res -> do
|
||||
runDB $ delete cid -- TODO Sicherheitsabfrage einbauen!
|
||||
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
||||
let cti = termToText $ cfTerm res
|
||||
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |]
|
||||
redirect $ CourseListTermR $ cfTerm res
|
||||
@ -127,19 +125,20 @@ courseEditHandler course = do
|
||||
, Nothing <- cfCourseId res -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
insertOkay <- runDB $ insertUnique $ Course
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTermId = TermKey $ cfTerm res
|
||||
, courseSchoolId = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseRegisterFrom = cfRegFrom res
|
||||
, courseRegisterTo = cfRegTo res
|
||||
, courseCreated = actTime
|
||||
, courseChanged = actTime
|
||||
, courseCreatedBy = aid
|
||||
, courseChangedBy = aid
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTermId = TermKey $ cfTerm res
|
||||
, courseSchoolId = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseHasRegistration = cfHasReg res
|
||||
, courseRegisterFrom = cfRegFrom res
|
||||
, courseRegisterTo = cfRegTo res
|
||||
, courseCreated = actTime
|
||||
, courseChanged = actTime
|
||||
, courseCreatedBy = aid
|
||||
, courseChangedBy = aid
|
||||
}
|
||||
case insertOkay of
|
||||
(Just cid) -> do
|
||||
@ -164,7 +163,7 @@ courseEditHandler course = do
|
||||
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId
|
||||
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
||||
, cfName :: Text
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
@ -172,6 +171,7 @@ data CourseForm = CourseForm
|
||||
, cfTerm :: TermIdentifier
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int
|
||||
, cfHasReg :: Bool
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
}
|
||||
@ -183,36 +183,41 @@ instance Show CourseForm where
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm cEntity = CourseForm
|
||||
{ cfCourseId = Just $ entityKey cEntity
|
||||
, cfName = courseName course
|
||||
, cfDesc = courseDescription course
|
||||
, cfLink = courseLinkExternal course
|
||||
, cfShort = courseShorthand course
|
||||
, cfName = courseName course
|
||||
, cfDesc = courseDescription course
|
||||
, cfLink = courseLinkExternal course
|
||||
, cfShort = courseShorthand course
|
||||
, cfTerm = unTermKey $ courseTermId course
|
||||
, cfSchool = courseSchoolId course
|
||||
, cfCapacity = courseCapacity course
|
||||
, cfRegFrom = courseRegisterFrom course
|
||||
, cfRegTo = courseRegisterTo course
|
||||
, cfSchool = courseSchoolId course
|
||||
, cfCapacity = courseCapacity course
|
||||
, cfHasReg = courseHasRegistration course
|
||||
, cfRegFrom = courseRegisterFrom course
|
||||
, cfRegTo = courseRegisterTo course
|
||||
}
|
||||
where
|
||||
course = entityVal cEntity
|
||||
|
||||
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
||||
newCourseForm template html = do
|
||||
-- mopt hiddenField
|
||||
-- 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 "courseId" (cfCourseId <$> template)
|
||||
<*> areq textField (set "Name") (cfName <$> template)
|
||||
<*> aopt htmlField (set "Beschreibung") (cfDesc <$> template)
|
||||
<*> aopt urlField (set "Homepage") (cfLink <$> template)
|
||||
<$> aopt hiddenField "KursId" (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)
|
||||
<*> 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)
|
||||
<*> areq checkBoxField (set "Anmeldung") (cfHasReg <$> template)
|
||||
<*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template)
|
||||
-- <* bootstrapSubmit (bsSubmit (show cid))
|
||||
liftIO $ putStrLn "++++++++++" -- DEBUG
|
||||
liftIO $ print cid -- DEBUG
|
||||
return $ case result of
|
||||
FormSuccess courseResult
|
||||
| errorMsgs <- validateCourse courseResult
|
||||
@ -252,8 +257,21 @@ validateCourse :: CourseForm -> [Text]
|
||||
validateCourse (CourseForm{..}) =
|
||||
[ msg | (False, msg) <-
|
||||
[
|
||||
( cfRegFrom <= cfRegTo
|
||||
, "Ende der Anmeldungszeit muss nach dem Anfang liegen"
|
||||
( cfHasReg <= (cfRegFrom <= cfRegTo)
|
||||
, "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
|
||||
)
|
||||
,
|
||||
-- No starting date is okay: effective immediately
|
||||
-- ( cfHasReg <= (isNothing cfRegFrom)
|
||||
-- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
|
||||
-- )
|
||||
-- ,
|
||||
( cfHasReg <= (isNothing cfRegTo)
|
||||
, "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
|
||||
)
|
||||
,
|
||||
( (isJust cfRegFrom || isJust cfRegTo) <= cfHasReg
|
||||
, "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
|
||||
)
|
||||
] ]
|
||||
|
||||
|
||||
@ -22,7 +22,7 @@ import Model.Types
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
|
||||
$(persistFileWith lowerCaseSettings "models")
|
||||
|
||||
|
||||
|
||||
@ -53,6 +53,9 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "SheetFileType"
|
||||
|
||||
data Load = ByTutorial | ByProportion Double
|
||||
deriving (Show, Read, Eq)
|
||||
derivePersistField "Load"
|
||||
|
||||
data Season = Summer | Winter
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
@ -16,7 +16,7 @@
|
||||
<h2 #description>Beschreibung
|
||||
<p> #{descr}
|
||||
$maybe link <- courseLinkExternal course
|
||||
<h4 #linl>Homepage:
|
||||
<h4 #linl>Homepage
|
||||
<a href=#{link}>#{link}
|
||||
<div .row>
|
||||
<div .col-lg-12>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user