fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SheetList-prime accessCallback from Course refactored

Browse Source
This commit is contained in:
Steffen Jost 2019-05-09 17:11:23 +02:00
parent a0de628d9b
commit d6c3cc8c15
1 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/Foundation.hs
View File

@ -1825,8 +1825,8 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = , menuItemAccessCallback' =
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers that can create new material 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 -- or show if user can see at least one of the contents 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 existsVisible = do
matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
@ -1843,17 +1843,18 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer , menuItemAccessCallback' =
let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets
muid <- maybeAuthId sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
(sheets,lecturer) <- runDB $ do existsVisible = do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
lecturer <- case muid of E.where_ $ course E.^. CourseTerm E.==. E.val tid
Nothing -> return False E.&&. course E.^. CourseSchool E.==. E.val ssh
(Just uid) -> existsBy $ UniqueLecturer uid cid E.&&. course E.^. CourseShorthand E.==. E.val csh
return (sheets,lecturer) return $ sheet E.^. SheetName
or2M (return lecturer) $ anyM sheets sheetRouteAccess anyM sheetNames (sheetAccess . E.unValue)
in runDB $ lecturerAccess `or2M` existsVisible
} }
] ++ pageActions (CourseR tid ssh csh SheetListR) ++ ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
[ MenuItem [ MenuItem