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)
+    , NTop allocationRegisterByCourse > NTop (Just now)
-        -> Just . courseCapacity <$> getJust cid
+      -> lift $ Just . courseCapacity <$> getJust allocationCourseCourse
-      | otherwise
+    | otherwise
-        -> return Nothing
+      -> 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
-  guardValidation MsgCourseAllocationCapacityMayNotBeChanged
+  unless userAdmin $ do
-    $ maybe True (== cfCapacity) oldAllocatedCapacity
+    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,48 +582,23 @@ courseEditHandler miButtonAction mbCourseForm = do
         }
 
 upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
-upsertAllocationCourse cid cfAllocation = do
+upsertAllocationCourse cid = \case
-  now <- liftIO getCurrentTime
+  Just AllocationCourseForm{..} -> do
-  Course{} <- getJust cid
+    prevAllocationCourse <- getBy $ UniqueAllocationCourse 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
+    void $ upsert AllocationCourse
-    | userAdmin
+      { allocationCourseAllocation        =  acfAllocation
-      -> return True
+      , allocationCourseCourse            =  cid
-    | Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation
+      , allocationCourseMinCapacity       =  acfMinCapacity
-    , NTop allocationStaffRegisterTo <= NTop (Just now)
+      , allocationCourseAcceptSubstitutes =  acfAcceptSubstitutes
-      -> let anyChanges
+      }
-               | Just AllocationCourseForm{..} <- cfAllocation
+      [ AllocationCourseAllocation        =. acfAllocation
-               , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
+      , AllocationCourseCourse            =. cid
-               = or [ acfAllocation  /= allocationCourseAllocation
+      , AllocationCourseMinCapacity       =. acfMinCapacity
-                    , acfMinCapacity /= allocationCourseMinCapacity
+      , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
-                    ]
+      ]
-               | otherwise
-               = True
-          in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
-    | otherwise
-      -> return True
 
-  when doEdit $
+    when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $
-    case cfAllocation of
+      queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
-      Just AllocationCourseForm{..} -> do
+  Nothing ->
-        void $ upsert AllocationCourse
+    deleteWhere [ AllocationCourseCourse ==. cid ]
-          { allocationCourseAllocation        =  acfAllocation
-          , allocationCourseCourse            =  cid
-          , allocationCourseMinCapacity       =  acfMinCapacity
-          , allocationCourseAcceptSubstitutes =  acfAcceptSubstitutes
-          }
-          [ AllocationCourseAllocation        =. acfAllocation
-          , AllocationCourseCourse            =. cid
-          , AllocationCourseMinCapacity       =. acfMinCapacity
-          , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
-          ]
-
-        when (Just acfAllocation /= fmap entityKey prevAllocation) $
-          queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
-      Nothing
-        | Just (Entity prevId _) <- prevAllocationCourse
-          -> delete prevId
-      _other -> return ()

src/Model/Types/Changelog.hs

@@ -29,15 +29,16 @@ makePrisms ''ChangelogItemKind
 
 classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
 classifyChangelogItem = \case
-  ChangelogHaskellCampusLogin                    -> ChangelogItemBugfix
+  ChangelogHaskellCampusLogin                     -> ChangelogItemBugfix
-  ChangelogTooltipsWithoutJavascript             -> ChangelogItemBugfix
+  ChangelogTooltipsWithoutJavascript              -> ChangelogItemBugfix
-  ChangelogButtonsWorkWithoutJavascript          -> ChangelogItemBugfix
+  ChangelogButtonsWorkWithoutJavascript           -> ChangelogItemBugfix
-  ChangelogTableFormsWorkAfterAjax               -> ChangelogItemBugfix
+  ChangelogTableFormsWorkAfterAjax                -> ChangelogItemBugfix
-  ChangelogPassingByPointsWorks                  -> ChangelogItemBugfix
+  ChangelogPassingByPointsWorks                   -> ChangelogItemBugfix
-  ChangelogErrorMessagesForTableItemVanish       -> ChangelogItemBugfix
+  ChangelogErrorMessagesForTableItemVanish        -> ChangelogItemBugfix
-  ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
+  ChangelogExamAchievementParticipantDuplication  -> ChangelogItemBugfix
-  ChangelogFormsTimesReset                       -> ChangelogItemBugfix
+  ChangelogFormsTimesReset                        -> ChangelogItemBugfix
-  _other                                         -> ChangelogItemFeature
+  ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
+  _other                                          -> ChangelogItemFeature
 
 changelogItemDays :: Map ChangelogItem Day
 changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)

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