feat(pageactions): restore pageactions
This commit is contained in:
Gregor Kleen
parent
7340fc1fa6
commit
926bd44736
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user