fix(course-edit): additional permission checks wrt allocations

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.

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

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 allocationStaffRegisterTo <= NTop (Just now)
-        , NTop allocationRegisterByStaffFrom >= 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

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 ()
+      -> return True
-  
-  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
+  when doEdit $
-        finsert val = do
+    case cfAllocation of
-          fId <- lift $ either return insert val
+      Just AllocationCourseForm{..} -> do
-          tell $ Set.singleton fId
+        Entity acId _ <- upsert AllocationCourse
-          lift $
+          { allocationCourseAllocation       = acfAllocation
-            void . insertUnique $ AllocationCourseFile acId fId
+          , allocationCourseCourse           = cid
-      keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert
+          , allocationCourseMinCapacity      = acfMinCapacity
-      acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] []
+          , allocationCourseInstructions     = acfInstructions
-      mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+          , allocationCourseApplicationText  = acfApplicationText
-    Nothing
+          , allocationCourseApplicationFiles = acfApplicationFiles
-      | Just (Entity prevId _) <- prevAllocationCourse
+          , allocationCourseRatingsVisible   = acfApplicationRatingsVisible
-        -> do
+          }
-          acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] []
+          [ AllocationCourseAllocation       =. acfAllocation
-          mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+          , AllocationCourseCourse           =. cid
-          delete prevId
+          , AllocationCourseMinCapacity      =. acfMinCapacity
-    _other -> return ()
+          , 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 ()