fix(course-edit): additional permission checks wrt allocations
This commit is contained in:
Gregor Kleen
parent
248482b1bb
commit
fca5caaa31
@ -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.
|
||||
|
||||
2
routes
2
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user