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

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

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-29 16:44:39 +02:00
parent 9473d657a6
commit c99433c291
4 changed files with 15 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Handler/Allocation/Show.hs
View File

@ -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

15
src/Handler/Course/List.hs
View File

@ -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)

3
src/Handler/Term.hs
View File

@ -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

3
src/Model/Types/Security.hs
View File

@ -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)