From e1cac76f1518e2de0f9d7e9f0f80278ea07fac0d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 Feb 2020 09:42:33 +0100 Subject: [PATCH] feat(pageactions): finish restoration --- src/Foundation.hs | 389 +++++++++++++++++++++++++--------------------- 1 file changed, 211 insertions(+), 178 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index b252668c9..a599bd7a6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2909,6 +2909,17 @@ pageActions ProfileR = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCsvOptions + , navRoute = CsvOptionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions TermShowR = return [ NavPageActionPrimary @@ -3489,185 +3500,207 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return } } ] - +pageActions (CourseR tid ssh csh CApplicationsR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseApplicationsFiles + , navRoute = CourseR tid ssh csh CAppsFilesR + , navAccess' = + let appAccess (E.Value appId) = do + cID <- encrypt appId + hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR + appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.where_ . E.exists . E.from $ \courseApplicationFile -> + E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId + return $ courseApplication E.^. CourseApplicationId + in runDB . runConduit $ appSource .| anyMC appAccess + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseMembers + , navRoute = CourseR tid ssh csh CUsersR + , navAccess' = + runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + exists [ CourseParticipantCourse ==. cid ] + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions CorrectionsR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsDownload + , navRoute = CorrectionsDownloadR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsUpload + , navRoute = CorrectionsUploadR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsCreate + , navRoute = CorrectionsCreateR + , navAccess' = runDB . maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + let + isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ + $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + isLecturer = E.exists . E.from $ \lecturer -> E.where_ + $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsGrade + , navRoute = CorrectionsGradeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions CorrectionsGradeR = do + correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR + return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrections + , navRoute = CorrectionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = correctionsSecondary + } + ] +pageActions EExamListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamNew + , navRoute = EExamNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEShowR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEGradesR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions ParticipantsListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCsvOptions + , navRoute = CsvOptionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] pageActions _ = return [] --- pageActions (CourseR tid ssh csh CApplicationsR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCourseApplicationsFiles --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR --- , menuItemModal = False --- , menuItemAccessCallback' --- = let appAccess (E.Value appId) = do --- cID <- encrypt appId --- hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR --- appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do --- E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse --- E.where_ $ course E.^. CourseTerm E.==. E.val tid --- E.&&. course E.^. CourseSchool E.==. E.val ssh --- E.&&. course E.^. CourseShorthand E.==. E.val csh --- E.where_ . E.exists . E.from $ \courseApplicationFile -> --- E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId --- return $ courseApplication E.^. CourseApplicationId --- in runDB . runConduit $ appSource .| anyMC appAccess --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCourseMembers --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR --- , menuItemModal = False --- , menuItemAccessCallback' = runDB $ do --- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh --- exists [ CourseParticipantCourse ==. cid ] --- } --- ] --- pageActions (CorrectionsR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsDownload --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsDownloadR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsUpload --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsUploadR --- , menuItemModal = True --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsCreate --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsCreateR --- , menuItemModal = False --- , menuItemAccessCallback' = runDB . maybeT (return False) $ do --- uid <- MaybeT $ liftHandler maybeAuthId --- sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do --- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse --- let --- isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ --- $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid --- E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId --- isLecturer = E.exists . E.from $ \lecturer -> E.where_ --- $ lecturer E.^. LecturerUser E.==. E.val uid --- E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId --- E.where_ $ isCorrector' E.||. isLecturer --- return $ sheet E.^. SheetSubmissionMode --- return $ orOf (traverse . _Value . _submissionModeCorrector) sheets --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsGrade --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsGradeR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions (CorrectionsGradeR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsUpload --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsUploadR --- , menuItemModal = True --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuCorrectionsCreate --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CorrectionsCreateR --- , menuItemModal = False --- , menuItemAccessCallback' = runDB . maybeT (return False) $ do --- uid <- MaybeT $ liftHandler maybeAuthId --- sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do --- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse --- let --- isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ --- $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid --- E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId --- isLecturer = E.exists . E.from $ \lecturer -> E.where_ --- $ lecturer E.^. LecturerUser E.==. E.val uid --- E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId --- E.where_ $ isCorrector' E.||. isLecturer --- return $ sheet E.^. SheetSubmissionMode --- return $ orOf (traverse . _Value . _submissionModeCorrector) sheets --- } --- ] --- pageActions EExamListR = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamNew --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute EExamNewR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions (EExamR tid ssh coursen examn EEShowR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamEdit --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEEditR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamUsers --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamGrades --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions (EExamR tid ssh coursen examn EEGradesR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamUsers --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions (EExamR tid ssh coursen examn EEUsersR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExternalExamGrades --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions ParticipantsListR = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgCsvOptions --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute CsvOptionsR --- , menuItemModal = True --- , menuItemAccessCallback' = return True --- } --- ] --- pageActions _ = [] pageQuickActions :: ( MonadCatch m , MonadHandler m