From b4df98069982752e36e69571f5557a6179b44cff Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 20 Oct 2020 13:06:36 +0200 Subject: [PATCH] fix(allocations): fix allocation-course-accept-substitutes --- messages/uniworx/de-de-formal.msg | 4 +- messages/uniworx/en-eu.msg | 3 +- src/Handler/Course/Edit.hs | 112 ++++++++---------- src/Model/Types/Changelog.hs | 19 +-- ...cept-substitutes-fixed.de-de-formal.hamlet | 2 + ...urse-accept-substitutes-fixed.en-eu.hamlet | 2 + 6 files changed, 70 insertions(+), 72 deletions(-) create mode 100644 templates/i18n/changelog/allocation-course-accept-substitutes-fixed.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/allocation-course-accept-substitutes-fixed.en-eu.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index fff9e6611..c6107bd5e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 74fb98ab2..989eb2b61 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 7a4fa97eb..9071a9ef0 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 <- getBy $ UniqueAllocationCourse cid - prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse + prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId + prevAllocation <- fmap join . traverse (lift . getEntity) $ allocationCourseAllocation . entityVal <$> prevAllocationCourse - fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if - | userAdmin - -> return Nothing - | NTop allocationStaffAllocationTo <= NTop (Just now) - , NTop allocationRegisterByCourse > NTop (Just now) - -> Just . courseCapacity <$> getJust cid - | otherwise - -> return Nothing + oldAllocatedCapacity <- if + | Just (Entity _ Allocation{..}) <- prevAllocation + , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse + , NTop allocationStaffAllocationTo <= NTop (Just now) + , NTop allocationRegisterByCourse > NTop (Just now) + -> 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 - guardValidation MsgCourseAllocationCapacityMayNotBeChanged - $ maybe True (== cfCapacity) oldAllocatedCapacity + $ 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,48 +582,23 @@ courseEditHandler miButtonAction mbCourseForm = do } upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX () -upsertAllocationCourse cid cfAllocation = do - 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) +upsertAllocationCourse cid = \case + Just AllocationCourseForm{..} -> do + prevAllocationCourse <- getBy $ UniqueAllocationCourse cid - 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 + void $ upsert AllocationCourse + { allocationCourseAllocation = acfAllocation + , allocationCourseCourse = cid + , allocationCourseMinCapacity = acfMinCapacity + , allocationCourseAcceptSubstitutes = acfAcceptSubstitutes + } + [ AllocationCourseAllocation =. acfAllocation + , AllocationCourseCourse =. cid + , AllocationCourseMinCapacity =. acfMinCapacity + , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes + ] - when doEdit $ - case cfAllocation of - Just AllocationCourseForm{..} -> do - void $ upsert AllocationCourse - { 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 () + when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $ + queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid + Nothing -> + deleteWhere [ AllocationCourseCourse ==. cid ] diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs index 828f9a4df..f0b64a502 100644 --- a/src/Model/Types/Changelog.hs +++ b/src/Model/Types/Changelog.hs @@ -29,15 +29,16 @@ makePrisms ''ChangelogItemKind classifyChangelogItem :: ChangelogItem -> ChangelogItemKind classifyChangelogItem = \case - ChangelogHaskellCampusLogin -> ChangelogItemBugfix - ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix - ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix - ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix - ChangelogPassingByPointsWorks -> ChangelogItemBugfix - ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix - ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix - ChangelogFormsTimesReset -> ChangelogItemBugfix - _other -> ChangelogItemFeature + ChangelogHaskellCampusLogin -> ChangelogItemBugfix + ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix + ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix + ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix + ChangelogPassingByPointsWorks -> ChangelogItemBugfix + ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix + ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix + ChangelogFormsTimesReset -> ChangelogItemBugfix + 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) diff --git a/templates/i18n/changelog/allocation-course-accept-substitutes-fixed.de-de-formal.hamlet b/templates/i18n/changelog/allocation-course-accept-substitutes-fixed.de-de-formal.hamlet new file mode 100644 index 000000000..31106fc32 --- /dev/null +++ b/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 diff --git a/templates/i18n/changelog/allocation-course-accept-substitutes-fixed.en-eu.hamlet b/templates/i18n/changelog/allocation-course-accept-substitutes-fixed.en-eu.hamlet new file mode 100644 index 000000000..657c7a162 --- /dev/null +++ b/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