From c99433c291bda25b45bf0c36ca8469324a71202e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Wed, 29 Jul 2020 16:44:39 +0200 Subject: [PATCH] fix(course-visibility): account for active auth tags everywhere --- src/Handler/Allocation/Show.hs | 3 ++- src/Handler/Course/List.hs | 15 ++++++++------- src/Handler/Term.hs | 3 ++- src/Model/Types/Security.hs | 3 +++ 4 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index a3df82105..b0ec6ab67 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -18,6 +18,7 @@ getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAShowR tid ssh ash = do muid <- maybeAuthId now <- liftIO getCurrentTime + ata <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags let resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course) @@ -42,7 +43,7 @@ getAShowR tid ssh ash = do E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId - E.&&. mayViewCourse muid now course + E.&&. mayViewCourse muid ata now course E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 628ad7358..10cf8c8a0 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -62,27 +62,28 @@ type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants (course `E.InnerJoin` _school) = numCourseParticipants course -course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) -course2Registered muid (course `E.InnerJoin` _school) = isCourseParticipant muid course +course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool) +course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata course makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget makeCourseTable whereClause colChoices psValidator = do muid <- lift maybeAuthId now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ dbtSQLQuery qin@(course `E.InnerJoin` school) = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId let participants = course2Participants qin - let registered = course2Registered muid qin - let mayView = mayViewCourse muid now course + let registered = course2Registered muid ata qin + let mayView = mayViewCourse muid ata now course E.where_ $ whereClause (course, participants, registered, mayView) return (course, participants, registered, school) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user - isEditorQuery course user = E.where_ $ mayEditCourse' muid course + isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course E.&&. E.just (user E.^. UserId) E.==. E.val muid dbtProj :: DBRow _ -> DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do @@ -105,7 +106,7 @@ makeCourseTable whereClause colChoices psValidator = do , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) , ( "members", SortColumn course2Participants ) - , ( "registered", SortColumn $ course2Registered muid) + , ( "registered", SortColumn $ course2Registered muid ata) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if @@ -160,7 +161,7 @@ makeCourseTable whereClause colChoices psValidator = do ) , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> course2Registered muid tExpr E.==. E.val needle + Just needle -> course2Registered muid ata tExpr E.==. E.val needle ) , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 44f730cbf..ed50bdc30 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -68,12 +68,13 @@ getTermShowR :: Handler Html getTermShowR = do muid <- maybeAuthId now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags table <- runDB $ let termDBTable = DBTable{..} where dbtSQLQuery term = return (term, courseCount) where courseCount = E.subSelectCount . E.from $ \course -> E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm - E.&&. mayViewCourse muid now course + E.&&. mayViewCourse muid ata now course dbtRowKey = (E.^. TermId) dbtProj = return . dbrOutput dbtColonnade = widgetColonnade $ mconcat diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 0cd47cc69..57379d4af 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -121,6 +121,9 @@ instance Binary AuthTagActive where derivePersistFieldJSON ''AuthTagActive +getSessionActiveAuthTags :: MonadHandler m => m AuthTagActive +getSessionActiveAuthTags = fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable)