feat(pageactions): restore pageactions

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
+  examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR
+  membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR
 
-  return
+  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

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