diff --git a/.gitignore b/.gitignore
index 44f8bb6b1..932688139 100644
--- a/.gitignore
+++ b/.gitignore
@@ -24,3 +24,6 @@ uniworx.nix
.gup/
.dbsettings.yml
*.kate-swp
+src/Handler/Assist.bak
+src/Handler/Course.SnapCustom.hs
+
diff --git a/models b/models
index 38705f488..1fd956be7 100644
--- a/models
+++ b/models
@@ -38,7 +38,8 @@ Course
created UTCTime
changed UTCTime
createdBy UserId
- changedBy UserId
+ changedBy UserId
+ hasRegistration Bool -- 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)
-
diff --git a/routes b/routes
index 889bead74..10f0aa4d8 100644
--- a/routes
+++ b/routes
@@ -4,10 +4,10 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
-/ HomeR GET POST
-
+/ HomeR GET
/profile ProfileR GET
+
/term TermShowR GET
/term/edit TermEditR GET POST
/term/#TermIdentifier/edit TermEditExistR GET
@@ -19,4 +19,4 @@
/course/#TermIdentifier/#Text/show CourseShowR GET
-- For demonstration
-/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
\ No newline at end of file
+/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 836911410..54ebfc18b 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -222,8 +222,18 @@ instance Yesod UniWorX where
makeLogger = return . appLogger
-- Define breadcrumbs.
-instance YesodBreadcrumbs UniWorX where
- breadcrumb HomeR = return ("Home", Nothing)
+instance YesodBreadcrumbs UniWorX where
+ breadcrumb TermShowR = return ("Semester", Just HomeR)
+ breadcrumb TermEditR = return ("Neu", Just TermShowR)
+ breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
+
+ breadcrumb CourseListR = return ("Kurs", Just HomeR)
+ breadcrumb (CourseListTermR term) = return (termToText term, Just TermShowR)
+ breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
+ breadcrumb CourseEditR = return ("Neu", Just CourseListR)
+ breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR)
+
+ breadcrumb HomeR = return ("ReWorX", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb _ = return ("home", Nothing)
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 38d1c8f53..b63e51f89 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -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
@@ -253,7 +258,20 @@ validateCourse (CourseForm{..}) =
[ msg | (False, msg) <-
[
( 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 == (isJust cfRegTo)
+ , "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
+ )
+ ,
+ ( isJust cfRegFrom <= cfHasReg
+ , "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
)
] ]
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 11dec1ca5..1ee3d187b 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -1,67 +1,28 @@
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
module Handler.Home where
-import Import
-import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
-import Text.Julius (RawJS (..))
+import Import
+import Handler.Utils
+
+import Data.Time
+import qualified Data.Text as T
+import Yesod.Form.Bootstrap3
+
+import Colonnade
+import Yesod.Colonnade
+
+import qualified Data.UUID.Cryptographic as UUID
--- Define our data that will be used for creating the form.
-data FileForm = FileForm
- { fileInfo :: FileInfo
- , fileDescription :: Text
- }
--- This is a handler function for the GET request method on the HomeR
--- resource pattern. All of your resource patterns are defined in
--- config/routes
---
--- The majority of the code you will write in Yesod lives in these handler
--- functions. You can spread them across multiple files if you are so
--- inclined, or create a single monolithic file.
getHomeR :: Handler Html
-getHomeR = do
- (formWidget, formEnctype) <- generateFormPost sampleForm
- let submission = Nothing :: Maybe FileForm
- handlerName = "getHomeR" :: Text
- defaultLayout $ do
- let (commentFormId, commentTextareaId, commentListId) = commentIds
- aDomId <- newIdent
- setTitle "Welcome To Yesod!"
- $(widgetFile "homepage")
-
-postHomeR :: Handler Html
-postHomeR = do
- ((result, formWidget), formEnctype) <- runFormPost sampleForm
- let handlerName = "postHomeR" :: Text
- submission = case result of
- FormSuccess res -> Just res
- _ -> Nothing
-
- defaultLayout $ do
- let (commentFormId, commentTextareaId, commentListId) = commentIds
- aDomId <- newIdent
- setTitle "Welcome To Yesod!"
- $(widgetFile "homepage")
-
-sampleForm :: Form FileForm
-sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
- <$> fileAFormReq "Choose a file"
- <*> areq textField textSettings Nothing
- -- Add attributes like the placeholder and CSS classes.
- where textSettings = FieldSettings
- { fsLabel = "What's on the file?"
- , fsTooltip = Nothing
- , fsId = Nothing
- , fsName = Nothing
- , fsAttrs =
- [ ("class", "form-control")
- , ("placeholder", "File description")
- ]
- }
-
-commentIds :: (Text, Text, Text)
-commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
+getHomeR = defaultLayout $ do
+ setTitle "Willkommen zum ReWorX Test!"
+ $(widgetFile "home")
diff --git a/src/Model.hs b/src/Model.hs
index 62909c626..a08615827 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -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")
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 08856e56a..3365a8351 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -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)
diff --git a/templates/course.hamlet b/templates/course.hamlet
index 8b2073aa2..fd8fc510d 100644
--- a/templates/course.hamlet
+++ b/templates/course.hamlet
@@ -16,7 +16,7 @@
Beschreibung
#{descr}
$maybe link <- courseLinkExternal course
-
Homepage:
+