fix(course-visibility): account for active auth tags everywhere

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

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 :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
-course2Registered muid (course `E.InnerJoin` _school) = isCourseParticipant muid course
+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 registered   = course2Registered muid ata qin
-        let mayView      = mayViewCourse muid now course
+        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)

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

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)