From c8e1d51e252e037daa72aaf058239091694af74a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 08:06:56 +0200 Subject: [PATCH] fix(authorisation): keep showing allocations (ro) to lecturers --- src/Foundation.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 42ddd0570..ffe1d32b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -933,7 +933,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -944,7 +944,8 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of Just Allocation{..} -> do cTime <- liftIO getCurrentTime guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo + when isWrite $ + guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo return Authorized