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

MODEL REFACTOR: dropped ID suffixes throughout

Browse Source
This commit is contained in:
SJost 2018-04-26 11:29:42 +02:00
parent 0e8ed257f8
commit e98cf70400
12 changed files with 161 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
fill-db.hs
View File

@ -89,8 +89,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "ffp"
, courseTermId = TermKey summer2018
, courseSchoolId = ifi
, courseTerm = TermKey summer2018
, courseSchool = ifi
, courseCapacity = Just 20
, courseHasRegistration = True
, courseRegisterFrom = Just now
@ -117,8 +117,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "eip"
, courseTermId = TermKey summer2017
, courseSchoolId = ifi
, courseTerm = TermKey summer2017
, courseSchool = ifi
, courseCapacity = Just 20
, courseHasRegistration = False
, courseRegisterFrom = Nothing
@ -136,8 +136,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "ixd"
, courseTermId = TermKey summer2018
, courseSchoolId = ifi
, courseTerm = TermKey summer2018
, courseSchool = ifi
, courseCapacity = Just 20
, courseHasRegistration = True
, courseRegisterFrom = Just now
@ -155,8 +155,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "ux3"
, courseTermId = TermKey winter2017
, courseSchoolId = ifi
, courseTerm = TermKey winter2017
, courseSchool = ifi
, courseCapacity = Just 30
, courseHasRegistration = False
, courseRegisterFrom = Nothing
@ -174,8 +174,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "pmo"
, courseTermId = TermKey summer2017
, courseSchoolId = ifi
, courseTerm = TermKey summer2017
, courseSchool = ifi
, courseCapacity = Just 50
, courseHasRegistration = False
, courseRegisterFrom = Nothing
@ -193,8 +193,8 @@ main = db $ do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "dbs"
, courseTermId = TermKey summer2018
, courseSchoolId = ifi
, courseTerm = TermKey summer2018
, courseSchool = ifi
, courseCapacity = Just 50
, courseHasRegistration = False
, courseRegisterFrom = Nothing

111
models
View File

@ -1,10 +1,10 @@
User
plugin Text
ident Text
plugin Text
ident Text
matrikelnummer Text Maybe
email Text
displayName Text
maxFavourites Int default=12
email Text
displayName Text
maxFavourites Int default=12
UniqueAuthentication plugin ident
UniqueEmail email
UserAdmin
@ -52,20 +52,20 @@ DegreeCourse json
terms StudyTermsId
UniqueDegreeCourse course degree terms
Course
name Text
description Html Maybe
linkExternal Text Maybe
shorthand Text
termId TermId
schoolId SchoolId
capacity Int Maybe
name Text
description Html Maybe
linkExternal Text Maybe
shorthand Text
term TermId
school SchoolId
capacity Int Maybe
hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
registerFrom UTCTime Maybe
registerTo UTCTime Maybe
deregisterUntil UTCTime Maybe
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool default=true
CourseTermShort termId shorthand
CourseTermShort term shorthand
CourseEdit
user UserId
time UTCTime
@ -76,29 +76,28 @@ CourseFavourite
course CourseId
UniqueCourseFavourite user course
Lecturer
userId UserId
courseId CourseId
UniqueLecturer userId courseId
user UserId
course CourseId
UniqueLecturer user course
Corrector
userId UserId
courseId CourseId
user UserId
course CourseId
load Load
-- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet
-- WHERE ( tutorialTutor = correctorUserId
-- && tutorialCourse = correctorCourseId
-- && tutorialUserTutorial = tutorialId
-- && submissionUser = tutorialUserUser
-- && sheetId = submissionSheetId
-- && sheetId = SubmissionSheet
-- && sheetCourse = correctorCourseId
-- )
UniqueCorrector userId courseId
CourseParticipant
courseId CourseId
userId UserId
course CourseId
user UserId
registration UTCTime
UniqueParticipant userId courseId
UniqueParticipant user course
Sheet
courseId CourseId
course CourseId
name Text
description Html Maybe
type SheetType
@ -109,23 +108,27 @@ Sheet
activeTo UTCTime
hintFrom UTCTime Maybe
solutionFrom UTCTime Maybe
CourseSheet courseId name
CourseSheet course name
SheetEdit
user UserId
time UTCTime
sheet SheetId
SheetCorrector
user UserId
sheet CourseId
load Load
SheetFile
sheetId SheetId
fileId FileId
sheet SheetId
file FileId
type SheetFileType
UniqueSheetFile fileId sheetId type
UniqueSheetFile file sheet type
File
title FilePath
content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime
deriving Show Eq
Submission
sheetId SheetId
sheet SheetId
ratingPoints Points Maybe
ratingComment Text Maybe
ratingBy UserId Maybe
@ -136,37 +139,37 @@ SubmissionEdit
time UTCTime
submission SubmissionId
SubmissionFile
submissionId SubmissionId
fileId FileId
submission SubmissionId
file FileId
isUpdate Bool
isDeletion Bool
UniqueSubmissionFile fileId submissionId isUpdate
UniqueSubmissionFile file submission isUpdate
deriving Show
SubmissionUser
userId UserId
submissionId SubmissionId
UniqueSubmissionUser userId submissionId
user UserId
submission SubmissionId
UniqueSubmissionUser user submission
SubmissionGroup
courseId CourseId
course CourseId
name Text Maybe
SubmissionGroupEdit
user UserId
time UTCTime
submissionGroup SubmissionGroupId
SubmissionGroupUser
submissionGroupId SubmissionGroupId
userId UserId
UniqueSubmissionGroupUser submissionGroupId userId
submissionGroup SubmissionGroupId
user UserId
UniqueSubmissionGroupUser submissionGroup user
Tutorial json
name Text
tutor UserId
tutor UserId
course CourseId
TutorialUser
userId UserId
tutorialId TutorialId
UniqueTutorialUser userId tutorialId
user UserId
tutorial TutorialId
UniqueTutorialUser user tutorial
Booking
termId TermId
term TermId
begin UTCTime
end UTCTime
weekly Bool
@ -183,17 +186,17 @@ Room
building Text Maybe
-- BookingRoom
-- subject RoomForId
-- roomId RoomId
-- bookingId BookingId
-- UniqueRoomCourse subject roomId bookingId
-- room RoomId
-- booking BookingId
-- UniqueRoomCourse subject room booking
+RoomFor
courseId CourseId
tutorialId TutorialId
examId ExamId
-- data RoomFor = RoomForCourseIdSum CourseId | RoomForTutorialIdSum TutorialId ...
course CourseId
tutorial TutorialId
exam ExamId
-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
-- EXAMS ARE TODO:
Exam
courseId CourseId
course CourseId
name Text
description Text
begin UTCTime
@ -208,8 +211,8 @@ Exam
-- time UTCTime
-- exam ExamId
--ExamUser
-- userId UserId
-- user UserId
-- examId ExamId
-- -- CONTINUE HERE: Include rating in this table or separately?
-- UniqueExamUser userId examId
-- UniqueExamUser user examId
-- By default this file is used in Model.hs (which is imported by Foundation.hs)

7
src/Foundation.hs
View File

@ -274,7 +274,7 @@ submissionAccess cID = do
authId <- lift requireAuthId
submissionId <- either decrypt decrypt cID
Submission{..} <- get404 submissionId
submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] []
submissionUsers <- map (submissionUserUser . entityVal) <$> selectList [SubmissionUserSubmission ==. submissionId] []
let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
return $ case auth of
True -> Authorized
@ -304,8 +304,9 @@ lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLectur
courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer
courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult
courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector
--courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult
--courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector
-- TODO: Correctors are no longer unit, could be ByTutorial and also by ByProportion
courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant

28
src/Handler/Course.hs
View File

@ -30,7 +30,7 @@ getCourseListTermR :: TermId -> Handler Html
getCourseListTermR tidini = do
(term,courses) <- runDB $ (,)
<$> get tidini
<*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
<*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
when (isNothing term) $ do
addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
redirect TermShowR
@ -39,20 +39,20 @@ getCourseListTermR tidini = do
[ headed "Kürzel" $ (\ckv ->
let c = entityVal ckv
shd = courseShorthand c
tid = courseTermId c
tid = courseTerm c
in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
-- , headed "Institut" $ [shamlet| #{course} |]
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
, headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
, headed "Teilnehmer" $ (\ckv -> do
let cid = entityKey ckv
partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid]
partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid]
[whamlet| #{show partiNum} |]
)
, headed " " $ (\ckv ->
let c = entityVal ckv
shd = courseShorthand c
tid = courseTermId c
tid = courseTerm c
in do
adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
@ -82,8 +82,8 @@ getCourseShowR tid csh = do
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
dependent <- (,,)
<$> get (courseSchoolId course) -- join
<*> count [CourseParticipantCourseId ==. cid] -- join
<$> get (courseSchool course) -- join
<*> count [CourseParticipantCourse ==. cid] -- join
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
Nothing -> return False
(Just aid) -> do
@ -183,8 +183,8 @@ courseEditHandler course = do
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTermId = cfTerm res
, courseSchoolId = cfSchool res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterFrom = cfRegFrom res
@ -226,8 +226,8 @@ courseEditHandler course = do
-- , CourseDescription =. cfDesc res
-- , CourseLinkExternal =. cfLink res
-- , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?!
-- , CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?!
-- , CourseSchoolId =. cfSchool res
-- , CourseTerm =. tid -- TODO: change here should generate a warning, or only allowed for Admins?!
-- , CourseSchool =. cfSchool res
-- , CourseCapacity =. cfCapacity res
-- , CourseRegisterFrom =. cfRegFrom res
-- , CourseRegisterTo =. cfRegTo res
@ -239,8 +239,8 @@ courseEditHandler course = do
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTermId = cfTerm res
, courseSchoolId = cfSchool res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterFrom = cfRegFrom res
@ -291,8 +291,8 @@ courseToForm cEntity = CourseForm
, cfDesc = courseDescription course
, cfLink = courseLinkExternal course
, cfShort = courseShorthand course
, cfTerm = courseTermId course
, cfSchool = courseSchoolId course
, cfTerm = courseTerm course
, cfSchool = courseSchool course
, cfCapacity = courseCapacity course
, cfHasReg = courseHasRegistration course
, cfRegFrom = courseRegisterFrom course

6
src/Handler/CryptoIDDispatch.hs
View File

@ -34,10 +34,10 @@ instance CryptoRoute UUID SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do
(smid :: SubmissionId) <- decrypt cID
(tid,csh,shn) <- runDB $ do
shid <- submissionSheetId <$> get404 smid
shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourseId
return (courseTermId, courseShorthand, sheetName)
Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName)
return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID

34
src/Handler/Sheet.hs
View File

@ -68,8 +68,8 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identForm FIDsheet $ \html -> do
let oldFileIds fType
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
E.&&. sheetFile E.^. SheetFileType E.==. E.val fType
return (file E.^. FileId)
| otherwise = return Set.empty
@ -135,11 +135,11 @@ getSheetList courseEnt = do
let cid = entityKey courseEnt
let course = entityVal courseEnt
let csh = courseShorthand course
let tid = courseTermId course
let tid = courseTerm course
sheets <- runDB $ do
rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
forM rawSheets $ \(Entity sid sheet) -> do
let sheetsub = [SubmissionSheetId ==. sid]
let sheetsub = [SubmissionSheet ==. sid]
submissions <- count sheetsub
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
return (sid, sheet, (submissions, rated))
@ -188,8 +188,8 @@ getSheetShowR tid csh shn = do
fileNameTypes <- runDB $ E.select $ E.from $
\(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
-- filter to requested file
E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- return desired columns
@ -214,15 +214,15 @@ getSheetFileR tid csh shn typ title = do
content <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId)
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseTermId E.==. E.val tid )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return desired columns
return $ file E.^. FileContent
@ -251,8 +251,8 @@ getSheetEditR tid csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent)
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise
return (file E.^. FileId)
return (ent, fIds)
@ -295,7 +295,7 @@ handleSheetEdit tid csh msId template dbAction = do
actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ CourseTermShort tid csh
let newSheet = Sheet
{ sheetCourseId = cid
{ sheetCourse = cid
, sheetName = sfName
, sheetDescription = sfDescription
, sheetType = sfType
@ -345,7 +345,7 @@ getSheetDelR tid csh shn = do
_other -> do
submissionno <- runDB $ do
sid <- fetchSheetId tid csh shn
count [SubmissionSheetId ==. sid]
count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelTitle tident csh shn
let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid csh $ SheetDelR shn
@ -369,8 +369,8 @@ insertSheetFile sid ftype finfo = do
insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId)
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert

70
src/Handler/Submission.hs
View File

@ -80,27 +80,27 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
case msmid of
Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmissionId)
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ submission E.^. SubmissionId
-- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
case submissions of
[] -> do
-- fetch buddies from previous submission in this course
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId)
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
E.on (submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId)
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId)
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid
E.&&. sheet E.^. SheetCourseId E.==. E.val sheetCourseId
E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit 1
return $ submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserSubmissionId `E.in_` oldids
E.&&. submissionUser E.^. SubmissionUserUserId E.!=. E.val uid
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail
return (sheet,buddies,[],[])
@ -109,13 +109,13 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
(Just smid) -> do
shid' <- submissionSheetId <$> get404 smid
shid' <- submissionSheet <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
-- fetch buddies from current submission
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmissionId E.==. E.val smid
E.&&. submissionUser E.^. SubmissionUserUserId E.!=. E.val uid
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail
oldfiles <- sourceToList $ submissionFileSource smid
@ -145,13 +145,13 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
let
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId
E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val sheetCourseId
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
return $ E.countRows E.>. E.val (0 :: Int64)
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ E.countRows E.>. E.val (0 :: Int64)
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
@ -180,11 +180,11 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
-- Determine members of pre-registered group
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroupId
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid
E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId
return $ submissionGroupUser' E.^. SubmissionGroupUserUserId
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
-- SubmissionUser for all group members (pre-registered & ad-hoc)
forM_ (groupUids `Set.union` adhocIds) $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
@ -229,8 +229,8 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return f
@ -248,8 +248,8 @@ getSubmissionDownloadSingleR cID path = do
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID)
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID)
E.where_ (f E.^. FileTitle E.==. E.val path)
E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
@ -288,8 +288,8 @@ getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
submissionTable = do
subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
return (sub, sheet, course)
@ -297,7 +297,7 @@ submissionTable = do
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
let
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
@ -334,7 +334,7 @@ postSubmissionListR = do
Just sink -> return sink
Nothing -> do
Submission{..} <- lift $ get404 sId
return . newResumableSink $ sinkSubmission submissionSheetId userId (Just (sId, isUpdate))
return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate))
sink' <- lift $ yield val ++$$ sink
case sink' of
Left _ -> error "sinkSubmission returned prematurely"
@ -434,12 +434,12 @@ postSubmissionDemoR cID = do
yieldM $ do
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
return File{..}
submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate))
submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate))
get404 submissionId'
files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId)
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId)
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return (f, sf)
return (submission, files)

2
src/Handler/Term.hs
View File

@ -35,7 +35,7 @@ getTermShowR = do
-- E.orderBy [E.desc $ term E.^. TermStart ]
let courseCount :: E.SqlExpr (E.Value Int)
courseCount = E.sub_select . E.from $ \course -> do
E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
return E.countRows
return (term, courseCount)
selectRep $ do

4
src/Handler/Utils/Rating.hs
View File

@ -90,8 +90,8 @@ instance Exception RatingException
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
getRating submissionId = runMaybeT $ do
let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId

6
src/Handler/Utils/Sheet.hs
View File

@ -33,8 +33,8 @@ fetchSheetAux prj tid csh shn =
-- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
E.where_ $ course E.^. CourseTermId E.==. E.val tid
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet
@ -49,4 +49,4 @@ fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourseId)) tid cid shn
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn

24
src/Handler/Utils/Submission.hs
View File

@ -65,7 +65,7 @@ sinkSubmission :: SheetId
sinkSubmission sheetId userId mExists = do
now <- liftIO getCurrentTime
let
submissionSheetId = sheetId
submissionSheet = sheetId
submissionRatingPoints = Nothing
submissionRatingComment = Nothing
submissionRatingBy = Nothing
@ -90,8 +90,8 @@ sinkSubmission sheetId userId mExists = do
tell $ mempty{ sinkFilenames = Set.singleton fileTitle }
otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
-- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
return (f, sf)
@ -121,8 +121,8 @@ sinkSubmission sheetId userId mExists = do
_ -> do
fileId <- insert file
insert_ $ SubmissionFile
{ submissionFileSubmissionId = submissionId
, submissionFileFileId = fileId
{ submissionFileSubmission = submissionId
, submissionFileFile = fileId
, submissionFileIsUpdate = isUpdate
, submissionFileIsDeletion = False
}
@ -189,8 +189,8 @@ sinkSubmission sheetId userId mExists = do
finalize :: SubmissionSinkState -> YesodDB UniWorX ()
finalize SubmissionSinkState{..} = do
missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
when (not isUpdate) $
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
@ -202,8 +202,8 @@ sinkSubmission sheetId userId mExists = do
False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
return $ f E.^. FileId
@ -212,13 +212,13 @@ sinkSubmission sheetId userId mExists = do
([], _) -> deleteCascade fileId
(E.Value f:_, False) -> do
insert_ $ SubmissionFile
{ submissionFileSubmissionId = submissionId
, submissionFileFileId = f
{ submissionFileSubmission = submissionId
, submissionFileFile = f
, submissionFileIsUpdate = True
, submissionFileIsDeletion = True
}
(E.Value f:_, True) -> do
update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ]
update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
deleteCascade fileId
when (isUpdate && not (getAny sinkSeenRating)) $

2
templates/widgets/asidenav.hamlet
View File

@ -18,7 +18,7 @@ $newline never
WiSe 17/18
<ul .asidenav__list>
$forall (Entity _ Course{..}) <- favourites
$with route <- CourseR courseTermId courseShorthand CourseShowR
$with route <- CourseR courseTerm courseShorthand CourseShowR
<li .asidenav__list-item :Just route == mcurrentRoute:.asidenav__list-item--active>
<a .asidenav__link-wrapper href=@{route}>
<div .asidenav__link-shorthand>#{courseShorthand}