diff --git a/src/Foundation.hs b/src/Foundation.hs index e99edcb05..366529f27 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -74,7 +74,7 @@ import Handler.Utils.StudyFeatures import Handler.Utils.SchoolLdap import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam --- import Handler.Utils.ExamOffice.Course +import Handler.Utils.ExamOffice.Course import Handler.Utils.Profile import Handler.Utils.Routes import Utils.Form @@ -2487,9 +2487,82 @@ pageActions NewsR = return } ] pageActions (CourseR tid ssh csh CShowR) = do + materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR + tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR - - return + examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR + membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR + + let examListBound :: Num a => a + examListBound = 4 -- guaranteed random; chosen by fair dice roll + examListExams <- liftHandler . runDB $ do + examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + 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.limit $ succ examListBound + return $ exam E.^. ExamName + return $ do + E.Value examn <- examNames + return NavLink + { navLabel = examn + , navRoute = CExamR tid ssh csh examn EShowR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + let showExamList = length examListExams <= examListBound + + let + navMembersChildren = + [ NavLink + { navLabel = MsgMenuCourseApplications + , navRoute = CourseR tid ssh csh CApplicationsR + , navAccess' = + let courseWhere course = course <$ do + 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 + existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + void $ courseWhere course + courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do + void $ courseWhere course + return $ course E.^. CourseApplicationsRequired + courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + void $ courseWhere course + in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + ] + navMembers = NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseMembers + , navRoute = CourseR tid ssh csh CUsersR + , navAccess' = + let courseWhere course = course <$ do + 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 + hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + void $ courseWhere course + mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + in runDB $ mayRegister `or2M` hasParticipants + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = navMembersChildren ++ membersSecondary + } + showMembers <- maybeT (return False) $ True <$ navAccess navMembers + + return $ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialList @@ -2510,7 +2583,7 @@ pageActions (CourseR tid ssh csh CShowR) = do , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } - , navChildren = [] -- TODO: MaterialNewR + , navChildren = materialListSecondary } , NavPageActionPrimary { navLink = NavLink @@ -2534,6 +2607,90 @@ pageActions (CourseR tid ssh csh CShowR) = do } , navChildren = sheetListSecondary } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialList + , navRoute = CourseR tid ssh csh CTutorialListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = tutorialListSecondary + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamList + , navRoute = CourseR tid ssh csh CExamListR + , navAccess' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR + examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR + existsVisible = do + examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + 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 + return $ exam E.^. ExamName + anyM examNames $ examAccess . E.unValue + in runDB $ lecturerAccess `or2M` existsVisible + , navType = NavTypeLink { navModal = False } + , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList + , navForceActive = False + } + , navChildren = examListSecondary ++ guardOnM showExamList examListExams + } + , navMembers + ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- navMembersChildren] ++ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseCommunication + , navRoute = CourseR tid ssh csh CCommR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = tutorialListSecondary + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseExamOffice + , navRoute = CourseR tid ssh csh CExamOfficeR + , navAccess' = do + uid <- requireAuthId + runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + E.selectExists $ do + (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) + E.where_ $ E.not_ isForced + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseEdit + , navRoute = CourseR tid ssh csh CEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseClone + , navRoute = ( CourseNewR + , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] + ) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuCourseDelete @@ -2543,7 +2700,7 @@ pageActions (CourseR tid ssh csh CShowR) = do , navQuick' = mempty , navForceActive = False } - } -- TODO + } ] pageActions (CourseR tid ssh csh SheetListR) = return [ NavPageActionPrimary @@ -2560,165 +2717,6 @@ pageActions (CourseR tid ssh csh SheetListR) = return } -- TODO ] pageActions _ = return [] --- pageActions (CourseR tid ssh csh CShowR) = --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuMaterialList --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR --- , menuItemModal = False --- , menuItemAccessCallback' = --- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material --- materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents --- existsVisible = do --- matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do --- E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse --- 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 --- return $ material E.^. MaterialName --- anyM matNames (materialAccess . E.unValue) --- in runDB $ lecturerAccess `or2M` existsVisible --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuSheetList --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR --- , menuItemModal = False --- , menuItemAccessCallback' = --- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets --- sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents --- existsVisible = do --- sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do --- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse --- 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 --- return $ sheet E.^. SheetName --- anyM sheetNames $ sheetAccess . E.unValue --- in runDB $ lecturerAccess `or2M` existsVisible --- } --- ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ --- [ MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuTutorialList --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionPrime --- , menuItemLabel = MsgMenuExamList --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR --- , menuItemModal = False --- , menuItemAccessCallback' = --- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR --- examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR --- existsVisible = do --- examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do --- E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse --- 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 --- return $ exam E.^. ExamName --- anyM examNames $ examAccess . E.unValue --- in runDB $ lecturerAccess `or2M` existsVisible --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseApplications --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR --- , menuItemModal = False --- , menuItemAccessCallback' = --- let courseWhere course = course <$ do --- 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 --- existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do --- E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse --- void $ courseWhere course --- courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do --- void $ courseWhere course --- return $ course E.^. CourseApplicationsRequired --- courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do --- E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse --- void $ courseWhere course --- in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseMembers --- , menuItemIcon = Just "user-graduate" --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR --- , menuItemModal = False --- , menuItemAccessCallback' = do --- now <- liftIO getCurrentTime --- let courseWhere course = course <$ do --- 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 --- hasActiveAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation) -> do --- E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation --- E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId --- void $ courseWhere course --- E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) --- E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse) --- hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do --- E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse --- void $ courseWhere course --- runDB $ (not <$> hasActiveAllocation) `or2M` hasParticipants --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseCommunication --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseEdit --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseClone --- , menuItemIcon = Just "copy" --- , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseDelete --- , menuItemIcon = Just "trash" --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR --- , menuItemModal = False --- , menuItemAccessCallback' = return True --- } --- , MenuItem --- { menuItemType = PageActionSecondary --- , menuItemLabel = MsgMenuCourseExamOffice --- , menuItemIcon = Nothing --- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamOfficeR --- , menuItemModal = True --- , menuItemAccessCallback' = do --- uid <- requireAuthId --- runDB $ do --- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh --- E.selectExists $ do --- (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) --- E.where_ $ E.not_ isForced --- } --- ] -- pageActions (AdminR) = -- [ MenuItem -- { menuItemType = PageActionPrime diff --git a/src/Utils.hs b/src/Utils.hs index f924d3141..c1a05222d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -630,6 +630,15 @@ assertM' f x = x <$ guard (f x) guardOn :: Alternative m => Bool -> a -> m a guardOn b x = x <$ guard b +guardOnM :: Alternative m => Bool -> m a -> m a +guardOnM b x = guard b *> x + +guardMOn :: MonadPlus m => m Bool -> a -> m a +guardMOn b x = x <$ guardM b + +guardMOnM :: MonadPlus m => m Bool -> m a -> m a +guardMOnM b x = guardM b *> x + -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a