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

111
models
View File

@ -1,10 +1,10 @@
User User
plugin Text plugin Text
ident Text ident Text
matrikelnummer Text Maybe matrikelnummer Text Maybe
email Text email Text
displayName Text displayName Text
maxFavourites Int default=12 maxFavourites Int default=12
UniqueAuthentication plugin ident UniqueAuthentication plugin ident
UniqueEmail email UniqueEmail email
UserAdmin UserAdmin
@ -52,20 +52,20 @@ DegreeCourse json
terms StudyTermsId terms StudyTermsId
UniqueDegreeCourse course degree terms UniqueDegreeCourse course degree terms
Course Course
name Text name Text
description Html Maybe description Html Maybe
linkExternal Text Maybe linkExternal Text Maybe
shorthand Text shorthand Text
termId TermId term TermId
schoolId SchoolId school SchoolId
capacity Int Maybe capacity Int Maybe
hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
registerFrom UTCTime Maybe registerFrom UTCTime Maybe
registerTo UTCTime Maybe registerTo UTCTime Maybe
deregisterUntil UTCTime Maybe deregisterUntil UTCTime Maybe
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool default=true materialFree Bool default=true
CourseTermShort termId shorthand CourseTermShort term shorthand
CourseEdit CourseEdit
user UserId user UserId
time UTCTime time UTCTime
@ -76,29 +76,28 @@ CourseFavourite
course CourseId course CourseId
UniqueCourseFavourite user course UniqueCourseFavourite user course
Lecturer Lecturer
userId UserId user UserId
courseId CourseId course CourseId
UniqueLecturer userId courseId UniqueLecturer user course
Corrector Corrector
userId UserId user UserId
courseId CourseId course CourseId
load Load load Load
-- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet -- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet
-- WHERE ( tutorialTutor = correctorUserId -- WHERE ( tutorialTutor = correctorUserId
-- && tutorialCourse = correctorCourseId -- && tutorialCourse = correctorCourseId
-- && tutorialUserTutorial = tutorialId -- && tutorialUserTutorial = tutorialId
-- && submissionUser = tutorialUserUser -- && submissionUser = tutorialUserUser
-- && sheetId = submissionSheetId -- && sheetId = SubmissionSheet
-- && sheetCourse = correctorCourseId -- && sheetCourse = correctorCourseId
-- ) -- )
UniqueCorrector userId courseId
CourseParticipant CourseParticipant
courseId CourseId course CourseId
userId UserId user UserId
registration UTCTime registration UTCTime
UniqueParticipant userId courseId UniqueParticipant user course
Sheet Sheet
courseId CourseId course CourseId
name Text name Text
description Html Maybe description Html Maybe
type SheetType type SheetType
@ -109,23 +108,27 @@ Sheet
activeTo UTCTime activeTo UTCTime
hintFrom UTCTime Maybe hintFrom UTCTime Maybe
solutionFrom UTCTime Maybe solutionFrom UTCTime Maybe
CourseSheet courseId name CourseSheet course name
SheetEdit SheetEdit
user UserId user UserId
time UTCTime time UTCTime
sheet SheetId sheet SheetId
SheetCorrector
user UserId
sheet CourseId
load Load
SheetFile SheetFile
sheetId SheetId sheet SheetId
fileId FileId file FileId
type SheetFileType type SheetFileType
UniqueSheetFile fileId sheetId type UniqueSheetFile file sheet type
File File
title FilePath title FilePath
content ByteString Maybe -- Nothing iff this is a directory content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime modified UTCTime
deriving Show Eq deriving Show Eq
Submission Submission
sheetId SheetId sheet SheetId
ratingPoints Points Maybe ratingPoints Points Maybe
ratingComment Text Maybe ratingComment Text Maybe
ratingBy UserId Maybe ratingBy UserId Maybe
@ -136,37 +139,37 @@ SubmissionEdit
time UTCTime time UTCTime
submission SubmissionId submission SubmissionId
SubmissionFile SubmissionFile
submissionId SubmissionId submission SubmissionId
fileId FileId file FileId
isUpdate Bool isUpdate Bool
isDeletion Bool isDeletion Bool
UniqueSubmissionFile fileId submissionId isUpdate UniqueSubmissionFile file submission isUpdate
deriving Show deriving Show
SubmissionUser SubmissionUser
userId UserId user UserId
submissionId SubmissionId submission SubmissionId
UniqueSubmissionUser userId submissionId UniqueSubmissionUser user submission
SubmissionGroup SubmissionGroup
courseId CourseId course CourseId
name Text Maybe name Text Maybe
SubmissionGroupEdit SubmissionGroupEdit
user UserId user UserId
time UTCTime time UTCTime
submissionGroup SubmissionGroupId submissionGroup SubmissionGroupId
SubmissionGroupUser SubmissionGroupUser
submissionGroupId SubmissionGroupId submissionGroup SubmissionGroupId
userId UserId user UserId
UniqueSubmissionGroupUser submissionGroupId userId UniqueSubmissionGroupUser submissionGroup user
Tutorial json Tutorial json
name Text name Text
tutor UserId tutor UserId
course CourseId course CourseId
TutorialUser TutorialUser
userId UserId user UserId
tutorialId TutorialId tutorial TutorialId
UniqueTutorialUser userId tutorialId UniqueTutorialUser user tutorial
Booking Booking
termId TermId term TermId
begin UTCTime begin UTCTime
end UTCTime end UTCTime
weekly Bool weekly Bool
@ -183,17 +186,17 @@ Room
building Text Maybe building Text Maybe
-- BookingRoom -- BookingRoom
-- subject RoomForId -- subject RoomForId
-- roomId RoomId -- room RoomId
-- bookingId BookingId -- booking BookingId
-- UniqueRoomCourse subject roomId bookingId -- UniqueRoomCourse subject room booking
+RoomFor +RoomFor
courseId CourseId course CourseId
tutorialId TutorialId tutorial TutorialId
examId ExamId exam ExamId
-- data RoomFor = RoomForCourseIdSum CourseId | RoomForTutorialIdSum TutorialId ... -- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
-- EXAMS ARE TODO: -- EXAMS ARE TODO:
Exam Exam
courseId CourseId course CourseId
name Text name Text
description Text description Text
begin UTCTime begin UTCTime
@ -208,8 +211,8 @@ Exam
-- time UTCTime -- time UTCTime
-- exam ExamId -- exam ExamId
--ExamUser --ExamUser
-- userId UserId -- user UserId
-- examId ExamId -- examId ExamId
-- -- CONTINUE HERE: Include rating in this table or separately? -- -- 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) -- 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 authId <- lift requireAuthId
submissionId <- either decrypt decrypt cID submissionId <- either decrypt decrypt cID
Submission{..} <- get404 submissionId 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 let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
return $ case auth of return $ case auth of
True -> Authorized True -> Authorized
@ -304,8 +304,9 @@ lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLectur
courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer
courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult --courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult
courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector --courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector
-- TODO: Correctors are no longer unit, could be ByTutorial and also by ByProportion
courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant

28
src/Handler/Course.hs
View File

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

6
src/Handler/CryptoIDDispatch.hs
View File

@ -34,10 +34,10 @@ instance CryptoRoute UUID SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do
(smid :: SubmissionId) <- decrypt cID (smid :: SubmissionId) <- decrypt cID
(tid,csh,shn) <- runDB $ do (tid,csh,shn) <- runDB $ do
shid <- submissionSheetId <$> get404 smid shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourseId Course{..} <- get404 sheetCourse
return (courseTermId, courseShorthand, sheetName) return (courseTerm, courseShorthand, sheetName)
return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID 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 makeSheetForm msId template = identForm FIDsheet $ \html -> do
let oldFileIds fType let oldFileIds fType
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do | 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.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
E.&&. sheetFile E.^. SheetFileType E.==. E.val fType E.&&. sheetFile E.^. SheetFileType E.==. E.val fType
return (file E.^. FileId) return (file E.^. FileId)
| otherwise = return Set.empty | otherwise = return Set.empty
@ -135,11 +135,11 @@ getSheetList courseEnt = do
let cid = entityKey courseEnt let cid = entityKey courseEnt
let course = entityVal courseEnt let course = entityVal courseEnt
let csh = courseShorthand course let csh = courseShorthand course
let tid = courseTermId course let tid = courseTerm course
sheets <- runDB $ do sheets <- runDB $ do
rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom] rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
forM rawSheets $ \(Entity sid sheet) -> do forM rawSheets $ \(Entity sid sheet) -> do
let sheetsub = [SubmissionSheetId ==. sid] let sheetsub = [SubmissionSheet ==. sid]
submissions <- count sheetsub submissions <- count sheetsub
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
return (sid, sheet, (submissions, rated)) return (sid, sheet, (submissions, rated))
@ -188,8 +188,8 @@ getSheetShowR tid csh shn = do
fileNameTypes <- runDB $ E.select $ E.from $ fileNameTypes <- runDB $ E.select $ E.from $
\(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
-- filter to requested file -- filter to requested file
E.where_ (sheet E.^. SheetId E.==. E.val sid ) E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- return desired columns -- return desired columns
@ -214,15 +214,15 @@ getSheetFileR tid csh shn typ title = do
content <- runDB $ E.select $ E.from $ content <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file -- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title) E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) 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 desired columns
return $ file E.^. FileContent return $ file E.^. FileContent
@ -251,8 +251,8 @@ getSheetEditR tid csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn ent <- fetchSheet tid csh shn
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do 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.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent) E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise
return (file E.^. FileId) return (file E.^. FileId)
return (ent, fIds) return (ent, fIds)
@ -295,7 +295,7 @@ handleSheetEdit tid csh msId template dbAction = do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ CourseTermShort tid csh cid <- getKeyBy404 $ CourseTermShort tid csh
let newSheet = Sheet let newSheet = Sheet
{ sheetCourseId = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName
, sheetDescription = sfDescription , sheetDescription = sfDescription
, sheetType = sfType , sheetType = sfType
@ -345,7 +345,7 @@ getSheetDelR tid csh shn = do
_other -> do _other -> do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid csh shn sid <- fetchSheetId tid csh shn
count [SubmissionSheetId ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelTitle tident csh shn let formTitle = MsgSheetDelTitle tident csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid csh $ SheetDelR shn 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' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> 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.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId) return (file E.^. FileId)
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert 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 case msmid of
Nothing -> do Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmissionId) E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
-- $logDebugS "Submission.DUPLICATENEW" (tshow submissions) -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
case submissions of case submissions of
[] -> do [] -> do
-- fetch buddies from previous submission in this course -- fetch buddies from previous submission in this course
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do 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 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 (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
E.on (submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId) E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId) E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. sheet E.^. SheetCourseId E.==. E.val sheetCourseId E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit 1 E.limit 1
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserSubmissionId `E.in_` oldids E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
E.&&. submissionUser E.^. SubmissionUserUserId E.!=. E.val uid E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
return (sheet,buddies,[],[]) return (sheet,buddies,[],[])
@ -109,13 +109,13 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
(Just smid) -> do (Just smid) -> do
shid' <- submissionSheetId <$> get404 smid shid' <- submissionSheet <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
-- fetch buddies from current submission -- fetch buddies from current submission
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do 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)
E.where_ $ submissionUser E.^. SubmissionUserSubmissionId E.==. E.val smid E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.&&. submissionUser E.^. SubmissionUserUserId E.!=. E.val uid E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
oldfiles <- sourceToList $ submissionFileSource smid 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 E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
let let
isParticipant = E.sub_select . E.from $ \courseParticipant -> do isParticipant = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val sheetCourseId E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
return $ E.countRows E.>. E.val (0 :: Int64) return $ E.countRows E.>. E.val (0 :: Int64)
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ E.countRows E.>. E.val (0 :: Int64) return $ E.countRows E.>. E.val (0 :: Int64)
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
@ -180,11 +180,11 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
-- Determine members of pre-registered group -- Determine members of pre-registered group
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do 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 $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
return $ submissionGroupUser' E.^. SubmissionGroupUserUserId return $ submissionGroupUser' E.^. SubmissionGroupUserUser
-- SubmissionUser for all group members (pre-registered & ad-hoc) -- SubmissionUser for all group members (pre-registered & ad-hoc)
forM_ (groupUids `Set.union` adhocIds) $ \uid' -> void . insertUnique $ SubmissionUser uid' smid 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 -> Source (YesodDB UniWorX) (Entity File)
submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do 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.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return f return f
@ -248,8 +248,8 @@ getSubmissionDownloadSingleR cID path = do
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
False -> do False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ 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.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID) E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID)
E.where_ (f E.^. FileTitle E.==. E.val path) E.where_ (f E.^. FileTitle E.==. E.val path)
E.where_ . E.not_ . E.isNothing $ f E.^. FileContent E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
@ -288,8 +288,8 @@ getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
submissionTable :: MForm Handler (FormResult [SubmissionId], Widget) submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
submissionTable = do submissionTable = do
subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> 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 $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
return (sub, sheet, course) return (sub, sheet, course)
@ -297,7 +297,7 @@ submissionTable = do
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
let let
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
@ -334,7 +334,7 @@ postSubmissionListR = do
Just sink -> return sink Just sink -> return sink
Nothing -> do Nothing -> do
Submission{..} <- lift $ get404 sId 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 sink' <- lift $ yield val ++$$ sink
case sink' of case sink' of
Left _ -> error "sinkSubmission returned prematurely" Left _ -> error "sinkSubmission returned prematurely"
@ -434,12 +434,12 @@ postSubmissionDemoR cID = do
yieldM $ do yieldM $ do
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC) fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
return File{..} return File{..}
submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate)) submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate))
get404 submissionId' get404 submissionId'
files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do 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.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId) E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId)
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return (f, sf) return (f, sf)
return (submission, files) return (submission, files)

2
src/Handler/Term.hs
View File

@ -35,7 +35,7 @@ getTermShowR = do
-- E.orderBy [E.desc $ term E.^. TermStart ] -- E.orderBy [E.desc $ term E.^. TermStart ]
let courseCount :: E.SqlExpr (E.Value Int) let courseCount :: E.SqlExpr (E.Value Int)
courseCount = E.sub_select . E.from $ \course -> do 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 E.countRows
return (term, courseCount) return (term, courseCount)
selectRep $ do 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 -> YesodDB UniWorX (Maybe Rating)
getRating submissionId = runMaybeT $ do getRating submissionId = runMaybeT $ do
let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> 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 $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId 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 -- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto: -- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTermId E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet 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 fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course) 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 sinkSubmission sheetId userId mExists = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
submissionSheetId = sheetId submissionSheet = sheetId
submissionRatingPoints = Nothing submissionRatingPoints = Nothing
submissionRatingComment = Nothing submissionRatingComment = Nothing
submissionRatingBy = Nothing submissionRatingBy = Nothing
@ -90,8 +90,8 @@ sinkSubmission sheetId userId mExists = do
tell $ mempty{ sinkFilenames = Set.singleton fileTitle } tell $ mempty{ sinkFilenames = Set.singleton fileTitle }
otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
-- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate -- 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 E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
return (f, sf) return (f, sf)
@ -121,8 +121,8 @@ sinkSubmission sheetId userId mExists = do
_ -> do _ -> do
fileId <- insert file fileId <- insert file
insert_ $ SubmissionFile insert_ $ SubmissionFile
{ submissionFileSubmissionId = submissionId { submissionFileSubmission = submissionId
, submissionFileFileId = fileId , submissionFileFile = fileId
, submissionFileIsUpdate = isUpdate , submissionFileIsUpdate = isUpdate
, submissionFileIsDeletion = False , submissionFileIsDeletion = False
} }
@ -189,8 +189,8 @@ sinkSubmission sheetId userId mExists = do
finalize :: SubmissionSinkState -> YesodDB UniWorX () finalize :: SubmissionSinkState -> YesodDB UniWorX ()
finalize SubmissionSinkState{..} = do finalize SubmissionSinkState{..} = do
missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ 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.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
when (not isUpdate) $ when (not isUpdate) $
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames) 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 ] ] False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate) E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
E.where_ $ f E.^. FileTitle E.==. E.val fileTitle E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
return $ f E.^. FileId return $ f E.^. FileId
@ -212,13 +212,13 @@ sinkSubmission sheetId userId mExists = do
([], _) -> deleteCascade fileId ([], _) -> deleteCascade fileId
(E.Value f:_, False) -> do (E.Value f:_, False) -> do
insert_ $ SubmissionFile insert_ $ SubmissionFile
{ submissionFileSubmissionId = submissionId { submissionFileSubmission = submissionId
, submissionFileFileId = f , submissionFileFile = f
, submissionFileIsUpdate = True , submissionFileIsUpdate = True
, submissionFileIsDeletion = True , submissionFileIsDeletion = True
} }
(E.Value f:_, True) -> do (E.Value f:_, True) -> do
update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ] update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
deleteCascade fileId deleteCascade fileId
when (isUpdate && not (getAny sinkSeenRating)) $ when (isUpdate && not (getAny sinkSeenRating)) $

2
templates/widgets/asidenav.hamlet
View File

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