From fca5caaa3137f3e8a11d76fbacf4d0ed0f1b78dd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 6 Aug 2019 16:10:58 +0200 Subject: [PATCH] fix(course-edit): additional permission checks wrt allocations --- messages/uniworx/de.msg | 5 ++ routes | 2 +- src/Foundation.hs | 14 ++++- src/Handler/Course/Edit.hs | 112 +++++++++++++++++++++++-------------- 4 files changed, 89 insertions(+), 44 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 71fc9843e..a6fce2d21 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -172,6 +172,10 @@ CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein +CourseAllocationRequiresCapacity: Bei Teilnahme an einer Zentralanmeldung muss eine Kurskapazität angegeben werden +CourseAllocationTermMustMatch: Kurs-Semester muss mit Semester der Zentralanmeldung übereinstimmen +CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Zentralanmeldung teilnimmt, darf nicht nachträglich verändert werden + CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht. @@ -341,6 +345,7 @@ UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet +UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. diff --git a/routes b/routes index 223539390..8ebe100e7 100644 --- a/routes +++ b/routes @@ -89,7 +89,7 @@ /register CRegisterR GET POST !timeANDcapacityANDallocation-time !lecturerANDallocation-time /edit CEditR GET POST /lecturer-invite CLecInviteR GET POST - /delete CDeleteR GET POST !lecturerANDempty + /delete CDeleteR GET POST !lecturerANDemptyANDallocation-time /users CUsersR GET POST !/users/new CAddUserR GET POST !lecturerANDallocation-time !/users/invite CInviteR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 7d8d42654..c6f4da349 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -820,10 +820,20 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of mba <- mbAllocation tid ssh csh case mba of Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) - , NTop allocationRegisterByStaffFrom >= NTop (Just now) + | NTop allocationStaffRegisterTo <= NTop (Just now) + || NTop allocationStaffRegisterFrom >= NTop (Just now) -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister _other -> return Authorized + + CourseR tid ssh csh CDeleteR -> do + now <- liftIO getCurrentTime + mba <- mbAllocation tid ssh csh + case mba of + Just (_, Allocation{..}) + | NTop allocationRegisterByStaffTo <= NTop (Just now) + || NTop allocationRegisterByStaffFrom >= NTop (Just now) + -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete + _other -> return Authorized r -> $unsupportedAuthPredicate AuthAllocationTime r where diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 4a9a843c8..8cb6a1bb5 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -51,12 +51,12 @@ data CourseForm = CourseForm data AllocationCourseForm = AllocationCourseForm { acfAllocation :: AllocationId - , acfMinCapacity :: Int , acfInstructions :: Maybe Html , acfFiles :: Maybe (Source Handler (Either FileId File)) , acfApplicationText :: Bool , acfApplicationFiles :: UploadMode , acfApplicationRatingsVisible :: Bool + , acfMinCapacity :: Int } courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm @@ -223,12 +223,12 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do let allocationForm' = AllocationCourseForm <$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) - <*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation)) <*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation) <*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ template >>= cfAllocation) + <*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template) @@ -279,9 +279,24 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] validateCourse CourseForm{..} = do + now <- liftIO getCurrentTime uid <- liftHandlerT requireAuthId userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route MsgRenderer mr <- getMsgRenderer + allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust + + oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> liftHandlerT . runDB $ do + prevAllocationCourse <- getBy $ UniqueAllocationCourse cid + prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse + + fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if + | is _Just userAdmin + -> return Nothing + | NTop allocationStaffRegisterTo <= NTop (Just now) + -> Just . courseCapacity <$> getJust cid + | otherwise + -> return Nothing + return [ mr msg | (False, msg) <- @@ -296,6 +311,15 @@ validateCourse CourseForm{..} = do , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin , MsgCourseUserMustBeLecturer ) + , ( is _Nothing cfAllocation || is _Just cfCapacity + , MsgCourseAllocationRequiresCapacity + ) + , ( maybe True (== cfTerm) allocationTerm + , MsgCourseAllocationTermMustMatch + ) + , ( maybe True (== cfCapacity) oldAllocatedCapacity + , MsgCourseAllocationCapacityMayNotBeChanged + ) ] ] @@ -481,49 +505,55 @@ courseEditHandler miButtonAction mbCourseForm = do upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime + uid <- liftHandlerT requireAuthId + Course{..} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse + userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route - if -- TODO: loophole for admins + doEdit <- if + | is _Just userAdmin + -> return True | Just Allocation{allocationStaffRegisterTo} <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) - -> permissionDeniedI MsgAllocationStaffRegisterToExpired + -> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired | otherwise - -> return () - - case cfAllocation of - Just AllocationCourseForm{..} -> do - Entity acId _ <- upsert AllocationCourse - { allocationCourseAllocation = acfAllocation - , allocationCourseCourse = cid - , allocationCourseMinCapacity = acfMinCapacity - , allocationCourseInstructions = acfInstructions - , allocationCourseApplicationText = acfApplicationText - , allocationCourseApplicationFiles = acfApplicationFiles - , allocationCourseRatingsVisible = acfApplicationRatingsVisible - } - [ AllocationCourseAllocation =. acfAllocation - , AllocationCourseCourse =. cid - , AllocationCourseMinCapacity =. acfMinCapacity - , AllocationCourseInstructions =. acfInstructions - , AllocationCourseApplicationText =. acfApplicationText - , AllocationCourseApplicationFiles =. acfApplicationFiles - , AllocationCourseRatingsVisible =. acfApplicationRatingsVisible - ] + -> return True - let - finsert val = do - fId <- lift $ either return insert val - tell $ Set.singleton fId - lift $ - void . insertUnique $ AllocationCourseFile acId fId - keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert - acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] [] - mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs - Nothing - | Just (Entity prevId _) <- prevAllocationCourse - -> do - acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] [] - mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs - delete prevId - _other -> return () + when doEdit $ + case cfAllocation of + Just AllocationCourseForm{..} -> do + Entity acId _ <- upsert AllocationCourse + { allocationCourseAllocation = acfAllocation + , allocationCourseCourse = cid + , allocationCourseMinCapacity = acfMinCapacity + , allocationCourseInstructions = acfInstructions + , allocationCourseApplicationText = acfApplicationText + , allocationCourseApplicationFiles = acfApplicationFiles + , allocationCourseRatingsVisible = acfApplicationRatingsVisible + } + [ AllocationCourseAllocation =. acfAllocation + , AllocationCourseCourse =. cid + , AllocationCourseMinCapacity =. acfMinCapacity + , AllocationCourseInstructions =. acfInstructions + , AllocationCourseApplicationText =. acfApplicationText + , AllocationCourseApplicationFiles =. acfApplicationFiles + , AllocationCourseRatingsVisible =. acfApplicationRatingsVisible + ] + + let + finsert val = do + fId <- lift $ either return insert val + tell $ Set.singleton fId + lift $ + void . insertUnique $ AllocationCourseFile acId fId + keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert + acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] [] + mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs + Nothing + | Just (Entity prevId _) <- prevAllocationCourse + -> do + acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] [] + mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs + delete prevId + _other -> return ()