fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Model changed according to discussion (compiles, but runs only after non-safe SQL migration)

Browse Source
This commit is contained in:
SJost 2017-10-10 17:41:10 +02:00
parent 586d411162
commit e85b130a0d
7 changed files with 85 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -24,3 +24,6 @@ uniworx.nix
.gup/ .gup/
.dbsettings.yml .dbsettings.yml
*.kate-swp *.kate-swp
src/Handler/Assist.bak
src/Handler/Course.SnapCustom.hs

22
models
View File

@ -38,7 +38,8 @@ Course
created UTCTime created UTCTime
changed UTCTime changed UTCTime
createdBy UserId createdBy UserId
changedBy UserId changedBy UserId
hasRegistration Bool default=TRUE -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
registerFrom UTCTime Maybe registerFrom UTCTime Maybe
registerTo UTCTime Maybe registerTo UTCTime Maybe
CourseTermShort termId shorthand CourseTermShort termId shorthand
@ -46,6 +47,19 @@ Lecturer
userId UserId userId UserId
courseId CourseId courseId CourseId
UniqueLecturer userId 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 CourseParticipant
userId UserId userId UserId
courseId CourseId courseId CourseId
@ -76,10 +90,10 @@ File
deriving Show Eq deriving Show Eq
Submission Submission
sheetId SheetId sheetId SheetId
ratingBy UserId Maybe
ratingPoints Points Maybe ratingPoints Points Maybe
ratingComment Text Maybe ratingComment Text Maybe
rated UTCTime Maybe ratingBy UserId Maybe
ratingTime UTCTime Maybe
created UTCTime created UTCTime
changed UTCTime changed UTCTime
createdBy UserId createdBy UserId
@ -107,6 +121,7 @@ SubmissionGroupUser
Tutorial json Tutorial json
name Text name Text
tutor UserId tutor UserId
course CourseId -- ?
TutorialUser TutorialUser
userId UserId userId UserId
tutorialId TutorialId tutorialId TutorialId
@ -159,4 +174,3 @@ ExamUser
-- CONTINUE HERE: Inlcude rating in this table or seperatly? -- CONTINUE HERE: Inlcude rating in this table or seperatly?
UniqueExamUser userId examId UniqueExamUser userId examId
-- By default this file is used in Model.hs (which is imported by Foundation.hs) -- By default this file is used in Model.hs (which is imported by Foundation.hs)

4
routes
View File

@ -16,7 +16,7 @@
!/course/edit CourseEditR GET POST !/course/edit CourseEditR GET POST
!/course/#TermIdentifier CourseListTermR GET !/course/#TermIdentifier CourseListTermR GET
/course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermIdentifier/#Text/edit CourseEditExistR GET
/course/#TermIdentifier/#Text/show CourseShowR GET /course/#TermIdentifier/#Text/show CourseShowR GET
-- For demonstration -- For demonstration
/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

96
src/Handler/Course.hs
View File

@ -61,8 +61,8 @@ getCourseShowR tid csh = do
(courseEnt,(schoolMB,participants)) <- runDB $ do (courseEnt,(schoolMB,participants)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
dependent <- (,) dependent <- (,)
<$> get (courseSchoolId course) <$> get (courseSchoolId course) -- join
<*> count [CourseParticipantCourseId ==. cid] <*> count [CourseParticipantCourseId ==. cid] -- join
return $ (courseEnt,dependent) return $ (courseEnt,dependent)
let course = entityVal courseEnt let course = entityVal courseEnt
defaultLayout $ do defaultLayout $ do
@ -95,13 +95,11 @@ courseEditHandler course = do
aid <- requireAuthId aid <- requireAuthId
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
action <- lookupPostParam "formaction" action <- lookupPostParam "formaction"
liftIO $ putStrLn "================" -- DEBUG
liftIO $ print (result,action) -- DEBUG
case (result,action) of case (result,action) of
(FormSuccess res, fAct) (FormSuccess res, fAct)
| fAct == formActionDelete | fAct == formActionDelete
, Just cid <- cfCourseId res -> do , Just cid <- cfCourseId res -> do
runDB $ delete cid -- TODO Sicherheitsabfrage einbauen! runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
let cti = termToText $ cfTerm res let cti = termToText $ cfTerm res
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |] setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |]
redirect $ CourseListTermR $ cfTerm res redirect $ CourseListTermR $ cfTerm res
@ -127,19 +125,20 @@ courseEditHandler course = do
, Nothing <- cfCourseId res -> do , Nothing <- cfCourseId res -> do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique $ Course insertOkay <- runDB $ insertUnique $ Course
{ courseName = cfName res { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
, courseShorthand = cfShort res , courseShorthand = cfShort res
, courseTermId = TermKey $ cfTerm res , courseTermId = TermKey $ cfTerm res
, courseSchoolId = cfSchool res , courseSchoolId = cfSchool res
, courseCapacity = cfCapacity res , courseCapacity = cfCapacity res
, courseRegisterFrom = cfRegFrom res , courseHasRegistration = cfHasReg res
, courseRegisterTo = cfRegTo res , courseRegisterFrom = cfRegFrom res
, courseCreated = actTime , courseRegisterTo = cfRegTo res
, courseChanged = actTime , courseCreated = actTime
, courseCreatedBy = aid , courseChanged = actTime
, courseChangedBy = aid , courseCreatedBy = aid
, courseChangedBy = aid
} }
case insertOkay of case insertOkay of
(Just cid) -> do (Just cid) -> do
@ -164,7 +163,7 @@ courseEditHandler course = do
data CourseForm = CourseForm data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
, cfName :: Text , cfName :: Text
, cfDesc :: Maybe Html , cfDesc :: Maybe Html
, cfLink :: Maybe Text , cfLink :: Maybe Text
@ -172,6 +171,7 @@ data CourseForm = CourseForm
, cfTerm :: TermIdentifier , cfTerm :: TermIdentifier
, cfSchool :: SchoolId , cfSchool :: SchoolId
, cfCapacity :: Maybe Int , cfCapacity :: Maybe Int
, cfHasReg :: Bool
, cfRegFrom :: Maybe UTCTime , cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime , cfRegTo :: Maybe UTCTime
} }
@ -183,36 +183,41 @@ instance Show CourseForm where
courseToForm :: Entity Course -> CourseForm courseToForm :: Entity Course -> CourseForm
courseToForm cEntity = CourseForm courseToForm cEntity = CourseForm
{ cfCourseId = Just $ entityKey cEntity { cfCourseId = Just $ entityKey cEntity
, cfName = courseName course , cfName = courseName course
, cfDesc = courseDescription course , cfDesc = courseDescription course
, cfLink = courseLinkExternal course , cfLink = courseLinkExternal course
, cfShort = courseShorthand course , cfShort = courseShorthand course
, cfTerm = unTermKey $ courseTermId course , cfTerm = unTermKey $ courseTermId course
, cfSchool = courseSchoolId course , cfSchool = courseSchoolId course
, cfCapacity = courseCapacity course , cfCapacity = courseCapacity course
, cfRegFrom = courseRegisterFrom course , cfHasReg = courseHasRegistration course
, cfRegTo = courseRegisterTo course , cfRegFrom = courseRegisterFrom course
, cfRegTo = courseRegisterTo course
} }
where where
course = entityVal cEntity course = entityVal cEntity
newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm :: Maybe CourseForm -> Form CourseForm
newCourseForm template html = do 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 (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
<$> aopt hiddenField "courseId" (cfCourseId <$> template) <$> aopt hiddenField "KursId" (cfCourseId <$> template)
<*> areq textField (set "Name") (cfName <$> template) <*> areq textField (set "Name") (cfName <$> template)
<*> aopt htmlField (set "Beschreibung") (cfDesc <$> template) <*> aopt htmlField (set "Beschreibung") (cfDesc <$> template)
<*> aopt urlField (set "Homepage") (cfLink <$> template) <*> aopt urlField (set "Homepage") (cfLink <$> template)
<*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) <*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template)
<*> areq termExistsField (set "Semester") (cfTerm <$> template) <*> areq termExistsField (set "Semester") (cfTerm <$> template)
<*> areq (selectField schools) (set "Institut") (cfSchool <$> template) <*> areq (selectField schools) (set "Institut") (cfSchool <$> template)
<*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template) <*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template)
<*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template) <*> areq checkBoxField (set "Anmeldung") (cfHasReg <$> template)
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template) <*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template)
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template)
-- <* bootstrapSubmit (bsSubmit (show cid)) -- <* bootstrapSubmit (bsSubmit (show cid))
liftIO $ putStrLn "++++++++++" -- DEBUG
liftIO $ print cid -- DEBUG
return $ case result of return $ case result of
FormSuccess courseResult FormSuccess courseResult
| errorMsgs <- validateCourse courseResult | errorMsgs <- validateCourse courseResult
@ -252,8 +257,21 @@ validateCourse :: CourseForm -> [Text]
validateCourse (CourseForm{..}) = validateCourse (CourseForm{..}) =
[ msg | (False, msg) <- [ msg | (False, msg) <-
[ [
( cfRegFrom <= cfRegTo ( cfHasReg <= (cfRegFrom <= cfRegTo)
, "Ende der Anmeldungszeit muss nach dem Anfang liegen" , "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"
) )
] ] ] ]

2
src/Model.hs
View File

@ -22,7 +22,7 @@ import Model.Types
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"] share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "models") $(persistFileWith lowerCaseSettings "models")

3
src/Model/Types.hs
View File

@ -53,6 +53,9 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType" derivePersistField "SheetFileType"
data Load = ByTutorial | ByProportion Double
deriving (Show, Read, Eq)
derivePersistField "Load"
data Season = Summer | Winter data Season = Summer | Winter
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)

2
templates/course.hamlet
View File

@ -16,7 +16,7 @@
<h2 #description>Beschreibung <h2 #description>Beschreibung
<p> #{descr} <p> #{descr}
$maybe link <- courseLinkExternal course $maybe link <- courseLinkExternal course
<h4 #linl>Homepage: <h4 #linl>Homepage
<a href=#{link}>#{link} <a href=#{link}>#{link}
<div .row> <div .row>
<div .col-lg-12> <div .col-lg-12>