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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-10 19:21:02 +02:00
commit 6bb8f1b49e
9 changed files with 115 additions and 106 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/
.dbsettings.yml
*.kate-swp
src/Handler/Assist.bak
src/Handler/Course.SnapCustom.hs

22
models
View File

@ -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)

6
routes
View File

@ -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
/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

14
src/Foundation.hs
View File

@ -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)

94
src/Handler/Course.hs
View File

@ -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"
)
] ]

75
src/Handler/Home.hs
View File

@ -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")

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
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
$(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)
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)

2
templates/course.hamlet
View File

@ -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>