fix(allocations): fix allocation-course-accept-substitutes

messages/uniworx/de-de-formal.msg

@@ -262,7 +262,9 @@ CourseApplicationsAllocatedDirectory: zentral
 CourseApplicationsNotAllocatedDirectory: direkt
 
 CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
-AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden. Ihre Änderungen wurden ignoriert.
+AllocationStaffRegisterToExpiredAllocation: Die Frist zur Eintrageng von Kursen in die Zentralanmeldung ist verstrichen. Die Teilnahme darf nicht mehr verändert werden.
+AllocationStaffRegisterToExpiredMinCapacity: Die Frist zur Eintrageng von Kursen in die Zentralanmeldung ist verstrichen. Die minimale Kapazität darf nicht mehr verändert werden.
+
 
 
 CourseFormSectionRegistration: Anmeldung zum Kurs

messages/uniworx/en-eu.msg

@@ -262,7 +262,8 @@ CourseApplicationsAllocatedDirectory: central
 CourseApplicationsNotAllocatedDirectory: direct
 
 CourseNoAllocationsAvailable: There are no ongoing central allocations
-AllocationStaffRegisterToExpired: You cannot change course properties concerning the central allocation after the course registration period. Your changes may have been discarded.
+AllocationStaffRegisterToExpiredAllocation: The course registration period for the central allocation is over. Participation may not be changed.
+AllocationStaffRegisterToExpiredMinCapacity: The course registration period for the central allocation is over. Minimum capacity may not be changed.
 
 CourseFormSectionRegistration: Registration
 CourseFormSectionAdministration: Administration

src/Handler/Course/Edit.hs

@@ -61,6 +61,9 @@ data AllocationCourseForm = AllocationCourseForm
   , acfDeregisterNoShow          :: Bool
   }
 
+makeLenses_ ''CourseForm
+makeLenses_ ''AllocationCourseForm
+
 courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm
 courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
     { cfCourseId            = Just cid
@@ -326,20 +329,28 @@ validateCourse = do
   now <- liftIO getCurrentTime
   uid <- liftHandler requireAuthId
   userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
-  allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
+  newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
 
-  oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> lift $ do
+  prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId
-    prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
+  prevAllocation <- fmap join . traverse (lift . getEntity) $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
-    prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
 
-    fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
+  oldAllocatedCapacity <- if
-      | userAdmin
+    | Just (Entity _ Allocation{..}) <- prevAllocation
-        -> return Nothing
+    , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
-      | NTop allocationStaffAllocationTo <= NTop (Just now)
+    , NTop allocationStaffAllocationTo <= NTop (Just now)
     , NTop allocationRegisterByCourse > NTop (Just now)
-        -> Just . courseCapacity <$> getJust cid
+      -> lift $ Just . courseCapacity <$> getJust allocationCourseCourse
     | otherwise
       -> return Nothing
+  let oldAllocation = do
+        Entity allocId Allocation{..} <- prevAllocation
+        guard $ NTop (Just now) > NTop allocationStaffRegisterTo
+        pure $ Just allocId
+      oldAllocatedMinCapacity = do
+        Entity _ Allocation{..} <- prevAllocation
+        Entity _ AllocationCourse{..} <- prevAllocationCourse
+        guard $ NTop (Just now) > NTop allocationStaffRegisterTo
+        pure $ Just allocationCourseMinCapacity
 
   guardValidation MsgCourseVisibilityEndMustBeAfterStart
     $ NTop cfVisFrom <= NTop cfVisTo
@@ -347,15 +358,19 @@ validateCourse = do
     $ NTop cfRegFrom <= NTop cfRegTo
   guardValidation MsgCourseDeregistrationEndMustBeAfterStart
     $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
-  unless userAdmin $
-    guardValidation MsgCourseUserMustBeLecturer
-      $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
   guardValidation MsgCourseAllocationRequiresCapacity
     $ is _Nothing cfAllocation || is _Just cfCapacity
   guardValidation MsgCourseAllocationTermMustMatch
-    $ maybe True (== cfTerm) allocationTerm
+    $ maybe True (== cfTerm) newAllocationTerm
+  unless userAdmin $ do
+    guardValidation MsgCourseUserMustBeLecturer
+      $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
     guardValidation MsgCourseAllocationCapacityMayNotBeChanged
       $ maybe True (== cfCapacity) oldAllocatedCapacity
+    guardValidation MsgAllocationStaffRegisterToExpiredAllocation
+      $ maybe True (== fmap acfAllocation cfAllocation) oldAllocation
+    guardValidation MsgAllocationStaffRegisterToExpiredMinCapacity
+      $ maybe True (== fmap acfMinCapacity cfAllocation) oldAllocatedMinCapacity
 
   warnValidation MsgCourseShorthandTooLong
     $ length (CI.original cfShort) <= 10
@@ -567,33 +582,10 @@ courseEditHandler miButtonAction mbCourseForm = do
         }
 
 upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
-upsertAllocationCourse cid cfAllocation = do
+upsertAllocationCourse cid = \case
-  now <- liftIO getCurrentTime
-  Course{} <- getJust cid
-  prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
-  prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
-  userAdmin <- fromMaybe False <$> for prevAllocation (\(Entity _ Allocation{..}) -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
-
-  doEdit <- if
-    | userAdmin
-      -> return True
-    | Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation
-    , NTop allocationStaffRegisterTo <= NTop (Just now)
-      -> let anyChanges
-               | Just AllocationCourseForm{..} <- cfAllocation
-               , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
-               = or [ acfAllocation  /= allocationCourseAllocation
-                    , acfMinCapacity /= allocationCourseMinCapacity
-                    ]
-               | otherwise
-               = True
-          in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
-    | otherwise
-      -> return True
-
-  when doEdit $
-    case cfAllocation of
   Just AllocationCourseForm{..} -> do
+    prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
+
     void $ upsert AllocationCourse
       { allocationCourseAllocation        =  acfAllocation
       , allocationCourseCourse            =  cid
@@ -606,9 +598,7 @@ upsertAllocationCourse cid cfAllocation = do
       , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
       ]
 
-        when (Just acfAllocation /= fmap entityKey prevAllocation) $
+    when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $
       queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
-      Nothing
+  Nothing ->
-        | Just (Entity prevId _) <- prevAllocationCourse
+    deleteWhere [ AllocationCourseCourse ==. cid ]
-          -> delete prevId
-      _other -> return ()

src/Model/Types/Changelog.hs

@@ -37,6 +37,7 @@ classifyChangelogItem = \case
   ChangelogErrorMessagesForTableItemVanish        -> ChangelogItemBugfix
   ChangelogExamAchievementParticipantDuplication  -> ChangelogItemBugfix
   ChangelogFormsTimesReset                        -> ChangelogItemBugfix
+  ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
   _other                                          -> ChangelogItemFeature
 
 changelogItemDays :: Map ChangelogItem Day

templates/i18n/changelog/allocation-course-accept-substitutes-fixed.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Das Eintragen von Fristen bis zu denen Nachrücker aus Zentralanmeldungen akzeptiert werden ist nun möglich

templates/i18n/changelog/allocation-course-accept-substitutes-fixed.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+It is now possible to specify deadlines up to which substitute registrations from central allocations are accepted