diff --git a/CHANGELOG.md b/CHANGELOG.md index 87274836d..5ce661834 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,18 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [20.13.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.1...v20.13.0) (2020-10-20) + + +### Features + +* **allocations:** display participant counts to admins ([b79bac7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b79bac777c6d349a626ea4efa6c43141b7f669d0)) + + +### Bug Fixes + +* **allocations:** fix allocation-course-accept-substitutes ([b4df980](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4df98069982752e36e69571f5557a6179b44cff)) + ### [20.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.0...v20.12.1) (2020-10-14) diff --git a/messages/faq/de-de-formal.msg b/messages/faq/de-de-formal.msg index 092366c09..bc424609f 100644 --- a/messages/faq/de-de-formal.msg +++ b/messages/faq/de-de-formal.msg @@ -1,6 +1,8 @@ FAQNoCampusAccount: Ich habe keine LMU-Benutzerkennung (ehem. Campus-Kennung); kann ich trotzdem Zugang zum System erhalten? FAQForgottenPassword: Ich habe mein Passwort vergessen FAQCampusCantLogin: Ich kann mich mit meiner LMU-Benutzerkennung (ehem. Campus-Kennung) nicht anmelden -FAQCourseCorrectorsTutors: Wie kann ich Tutoren oder Korrektoren für meinen Kurs einstellen? +FAQCourseCorrectorsTutors: Wie kann ich Tutoren oder Korrektoren für meinen Kurs konfigurieren? FAQNotLecturerHowToCreateCourses: Wie kann ich einen neuen Kurs anlegen? -FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen? \ No newline at end of file +FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen? +FAQInvalidCredentialsAdAccountDisabled: Ich kann mich nicht anmelden und bekomme die Meldung „Benutzereintrag gesperrt“ +FAQAllocationNoPlaces: Ich habe über eine Zentralanmeldung keine Plätze/nicht die Plätze, die ich möchte, erhalten \ No newline at end of file diff --git a/messages/faq/en-eu.msg b/messages/faq/en-eu.msg index 1cce5d04b..51c56628f 100644 --- a/messages/faq/en-eu.msg +++ b/messages/faq/en-eu.msg @@ -4,3 +4,5 @@ FAQCampusCantLogin: I can't log in using my LMU user ID (formerly Campus-ID) FAQCourseCorrectorsTutors: How can I add tutors or correctors to my course? FAQNotLecturerHowToCreateCourses: How can I create new courses? FAQExamPoints: Why can't I enter achievements for my exam as points? +FAQInvalidCredentialsAdAccountDisabled: I can't log in and am instead given the message “Account disabled” +FAQAllocationNoPlaces: I did not receive any places/the places I wanted from a central allocation \ No newline at end of file diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 3ffe51e6a..d511560ae 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -206,6 +206,7 @@ CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein CourseAllocationCourseAcceptsSubstitutesUntil: Akzeptiert Nachrücker bis CourseAllocationCourseAcceptsSubstitutesNever: Akzeptiert keine Nachrücker +CourseAllocationCourseParticipants: Teilnehmer CourseApplicationInstructions: Anweisungen zur Bewerbung/Anmeldung CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden CourseApplicationTemplate: Bewerbungsvorlagen @@ -262,7 +263,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 @@ -1995,6 +1998,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Te ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} liegt nach dem Ende der Prüfung ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor +ExamOccurrenceCannotBeDeletedDueToRegistrations eoName@ExamOccurrenceName: Termin #{eoName} kann nicht gelöscht werden, da noch Teilnehmer diesem Termin zugewiesen sind. Über die Liste von Prüfungsteilnehmern können Sie zunächst die entsprechenden Terminzuweisungen entfernen. +ExamPartCannotBeDeletedDueToResults exampartnum@ExamPartNumber: Teil #{exampartnum} kann nicht gelöscht werden, da bereits Prüfungsergebnisse für diesen Teil eingetragen wurden. VersionHistory: Versionsgeschichte KnownBugs: Bekannte Bugs @@ -2317,6 +2322,7 @@ AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt w AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein. AllocationNextSubstitutesDeadline: Nächster Kurs akzeptiert Nachrücker bis AllocationNextSubstitutesDeadlineNever: Keine Kurse akzeptieren mehr Nachrücker +AllocationFreeCapacity: Freie Plätze AllocationSchoolShort: Institut Allocation: Zentralanmeldung diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index b8d8b0421..d38d280c7 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -206,6 +206,7 @@ CourseAllocationMinCapacityTip: If fewer students than this number were to be as CourseAllocationMinCapacityMustBeNonNegative: Minimum number of participants must not be negative CourseAllocationCourseAcceptsSubstitutesUntil: Accepts substitutes until CourseAllocationCourseAcceptsSubstitutesNever: Does not accept substitutes +CourseAllocationCourseParticipants: Participants CourseApplicationInstructions: Instructions for application CourseApplicationInstructionsTip: Will be shown to students if they decide to apply for this course CourseApplicationTemplate: Application template @@ -262,7 +263,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 @@ -1955,6 +1957,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName ExamOccurrenceEndMustBeBeforeExamEnd eoName: End of the occurrence #{eoName} must be before the exam end ExamOccurrenceDuplicate eoRoom eoRange: Combination of room #{eoRoom} and occurrence #{eoRange} occurs multiple times ExamOccurrenceDuplicateName eoName: Internal name #{eoName} occurs multiple times +ExamOccurrenceCannotBeDeletedDueToRegistrations eoName: Occurrence #{eoName} cannot be deleted because participants are registered for it. You can remove the offending registrations via the list of exam participants. +ExamPartCannotBeDeletedDueToResults exampartnum: Part #{exampartnum} cannot be deleted because some exam part results were already entered for it. VersionHistory: Version history KnownBugs: Known bugs @@ -2277,6 +2281,7 @@ AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified. AllocationNotificationLoginFirst: To change your notification settings, please log in first. AllocationNextSubstitutesDeadline: Next course accepts substitutes until AllocationNextSubstitutesDeadlineNever: No course currently accepts substitutes +AllocationFreeCapacity: Free capacity AllocationSchoolShort: Department Allocation: Central allocation diff --git a/nixpkgs.nix b/nixpkgs.nix index 375c84162..6a21dfbda 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,7 +4,7 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "bc00ecedfa709f4fa91d445dd76ecd792cb2c728"; - sha256 = "0plhwb04srr4b0h7w8qlqi207a19szz2wqz6r4gmic856jlkchaa"; + rev = "a7a1447e5d40a9ad90983d33e151f5474eddeed9"; + sha256 = "1zb8wgsq9grrsdcz81y08h45rj8i5r8ckjhg2cv1cqmam4dczcrf"; fetchSubmodules = true; }) diff --git a/package-lock.json b/package-lock.json index ae6c1c4c3..d64371801 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.12.1", + "version": "20.13.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 8baee28ac..26b0c1388 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.12.1", + "version": "20.13.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 916b96640..1d7a50b1d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.12.1 +version: 20.13.0 dependencies: - base diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 471e59dd7..597163cd4 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -160,6 +160,7 @@ campusUserMatr' pool mode newtype ADInvalidCredentials = ADInvalidCredentials ADError deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Universe, Finite, Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey) isUnusualADError :: ADError -> Bool isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure] @@ -220,7 +221,7 @@ campusLogin pool mode = AuthPlugin{..} $logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|] observeLoginOutcome apName LoginADInvalidCredentials MsgRenderer mr <- liftHandler getMsgRenderer - setSessionJson SessionError . PermissionDenied . mr $ ADInvalidCredentials adError + setSessionJson SessionError . PermissionDenied . toPathPiece $ ADInvalidCredentials adError loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError Right (Left bindErr) -> do case bindErr of diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index f58b1be58..432566344 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -61,6 +61,8 @@ postAShowR tid ssh ash = do resultCourseVisible = _5 . _Value resultAllocationCourse :: _ => Lens' a AllocationCourse resultAllocationCourse = _6 . _entityVal + resultParticipantCount :: _ => Lens' a Int + resultParticipantCount = _7 . _Value (Entity aId Allocation{..}, School{..}, isAnyLecturer, isAdmin, courses, registration, wouldNotifyNewCourse) <- runDB $ do alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash @@ -81,12 +83,16 @@ postAShowR tid ssh ash = do E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId + participantCount = E.subSelectCount . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return ( course , courseApplication , hasTemplate , E.not_ . E.isNothing $ registration E.?. CourseParticipantId , courseIsVisible now course . Just $ E.val aId , allocationCourse + , participantCount ) registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId @@ -99,6 +105,7 @@ postAShowR tid ssh ash = do return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse) let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses + freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ subtract (cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry MsgRenderer mr <- getMsgRenderer let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName @@ -158,6 +165,7 @@ postAShowR tid ssh ash = do isRegistered = cEntry ^. resultIsRegistered courseVisible = cEntry ^. resultCourseVisible AllocationCourse{..} = cEntry ^. resultAllocationCourse + partCount = cEntry ^. resultParticipantCount cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR 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/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 7478479a4..7cc3ef518 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -18,17 +18,14 @@ import Jobs.Queue getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEEditR = postEEditR postEEditR tid ssh csh examn = do - (cid, Entity eId oldExam, template) <- runDB $ do - (cid, exam) <- fetchCourseIdExam tid ssh csh examn + (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do + (cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn template <- examFormTemplate exam - return (cid, exam, template) + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm $ Just template - ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template - - formResult editExamResult $ \ExamForm{..} -> do - insertRes <- runDBJobs $ do + editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do insertRes <- myReplaceUnique eId Exam { examCourse = cid , examName = efName @@ -116,13 +113,15 @@ postEEditR tid ssh csh examn = do deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites - return insertRes + return . Just $ case insertRes of + Just _ -> addMessageI Error $ MsgExamNameTaken efName + Nothing -> do + addMessageI Success $ MsgExamEdited efName + redirect $ CExamR tid ssh csh efName EShowR - case insertRes of - Just _ -> addMessageI Error $ MsgExamNameTaken efName - Nothing -> do - addMessageI Success $ MsgExamEdited efName - redirect $ CExamR tid ssh csh efName EShowR + return (template, (editExamAct, (editExamWidget, editExamEnctype))) + + sequence_ editExamAct let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1fe31be33..2a19dfa4f 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -98,11 +98,14 @@ deriveJSON defaultOptions } ''ExamOccurrenceForm -examForm :: Maybe ExamForm -> Form ExamForm -examForm template html = do +examForm :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget)) +examForm template csrf = hoist liftHandler $ do MsgRenderer mr <- getMsgRenderer - flip (renderAForm FormStandard) html $ ExamForm + flip (renderAForm FormStandard) csrf $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template) <* aformSection MsgExamFormTimes @@ -284,7 +287,11 @@ examPartsForm prev = wFormToAForm $ do miIdent' :: Text miIdent' = "exam-parts" -examFormTemplate :: Entity Exam -> DB ExamForm +examFormTemplate :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + ) + => Entity Exam -> SqlPersistT m ExamForm examFormTemplate (Entity eId Exam{..}) = do examParts <- selectList [ ExamPartExam ==. eId ] [] occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] @@ -342,7 +349,8 @@ examFormTemplate (Entity eId Exam{..}) = do , efStaff = examStaff } -examTemplate :: CourseId -> DB (Maybe ExamForm) +examTemplate :: MonadHandler m + => CourseId -> SqlPersistT m (Maybe ExamForm) examTemplate cid = runMaybeT $ do newCourse <- MaybeT $ get cid @@ -393,7 +401,12 @@ examTemplate cid = runMaybeT $ do } -validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m () +validateExam :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + ) + => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) () validateExam cId oldExam = do ExamForm{..} <- State.get @@ -404,6 +417,7 @@ validateExam cId oldExam = do guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd) guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart) + forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart @@ -421,6 +435,28 @@ validateExam cId oldExam = do guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b + oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do + E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId + E.where_ . E.exists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) + return ( examOccurrence E.^. ExamOccurrenceId + , examOccurrence E.^. ExamOccurrenceName + ) + forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) -> + guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId + + + oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do + E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId + E.where_ . E.exists . E.from $ \examPartResult -> + E.where_ $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId + return ( examPart E.^. ExamPartId + , examPart E.^. ExamPartNumber + ) + forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) -> + guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId + + mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseId E.==. E.val cId @@ -429,7 +465,7 @@ validateExam cId oldExam = do whenIsJust mSchool $ \(Entity _ School{..}) -> do whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do let doValidation - | Just Exam{..} <- oldExam + | Just (Entity _ Exam{..}) <- oldExam , not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom) = warnValidation | otherwise @@ -438,7 +474,7 @@ validateExam cId oldExam = do . fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom) whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do let doValidation - | Just Exam{..} <- oldExam + | Just (Entity _ Exam{..}) <- oldExam , not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom) = warnValidation | otherwise @@ -447,7 +483,7 @@ validateExam cId oldExam = do . fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom) when schoolExamRequireModeForRegistration $ do let doValidation - | Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam + | Just (Entity _ Exam{ examExamMode = ExamMode{..}, .. }) <- oldExam , or [ is _Nothing examAids , is _Nothing examOnline , is _Nothing examSynchronicity @@ -468,5 +504,5 @@ validateExam cId oldExam = do warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode - unless (has (_Just . _examStaff . _Nothing) oldExam) $ + unless (has (_Just . _entityVal . _examStaff . _Nothing) oldExam) $ guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 3477273f0..43b7b287e 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -19,15 +19,13 @@ import qualified Data.Conduit.Combinators as C getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR postCExamNewR tid ssh csh = do - (cid, template) <- runDB $ do + (newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh template <- examTemplate cid - return (cid, template) - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template - formResult newExamResult $ \ExamForm{..} -> do - insertRes <- runDBJobs $ do + newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do now <- liftIO getCurrentTime insertRes <- insertUnique Exam @@ -95,12 +93,15 @@ postCExamNewR tid ssh csh = do audit $ TransactionExamResultEdit examid courseParticipantUser runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow - return insertRes - case insertRes of - Nothing -> addMessageI Error $ MsgExamNameTaken efName - Just _ -> do - addMessageI Success $ MsgExamCreated efName - redirect $ CourseR tid ssh csh CExamListR + return . Just $ case insertRes of + Nothing -> addMessageI Error $ MsgExamNameTaken efName + Just _ -> do + addMessageI Success $ MsgExamCreated efName + redirect $ CourseR tid ssh csh CExamListR + + return (newExamAct, (newExamWidget, newExamEnctype)) + + sequence_ newExamAct let heading = prependCourseTitle tid ssh csh MsgExamNew diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 99a748da2..43110c6cc 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -14,6 +14,8 @@ import qualified Database.Esqueleto.Utils as E import Development.GitRev +import Auth.LDAP (ADError(..), ADInvalidCredentials(..)) + -- | Versionsgeschichte getVersionR :: Handler TypedContent getVersionR = selectRep $ do @@ -181,6 +183,26 @@ showFAQ (CExamR tid ssh csh examn _) FAQExamPoints E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. exam E.^. ExamName E.==. E.val examn +showFAQ _ FAQInvalidCredentialsAdAccountDisabled = maybeT (return False) $ do + guardM $ is _Nothing <$> maybeAuthId + sessionError <- MaybeT $ lookupSessionJson SessionError + guard $ sessionError == PermissionDenied (toPathPiece $ ADInvalidCredentials ADAccountDisabled) + return True +showFAQ _ FAQAllocationNoPlaces = maybeT (return False) $ do + uid <- MaybeT maybeAuthId + now <- liftIO getCurrentTime + liftHandler . runDB . E.selectExists . E.from $ \allocation -> do + let doneSince = E.subSelectMaybe . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (allocation E.^. AllocationId) + return . E.max_ $ participant E.^. CourseParticipantRegistration + isAllocationUser = E.exists . E.from $ \allocationUser -> + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. allocation E.^. AllocationId + E.&&. allocationUser E.^. AllocationUserUser E.==. E.val uid + isApplicant = E.exists . E.from $ \courseApplication -> + E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId) + E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid + E.where_ $ isAllocationUser E.||. isApplicant + E.where_ $ E.maybe E.false (\done -> done E.>=. E.val (addUTCTime (-7 * nominalDay) now)) doneSince showFAQ _ _ = return False prioFAQ :: Monad m @@ -191,3 +213,5 @@ prioFAQ _ FAQForgottenPassword = return 1 prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1 prioFAQ _ FAQCourseCorrectorsTutors = return 1 prioFAQ _ FAQExamPoints = return 2 +prioFAQ _ FAQAllocationNoPlaces = return 2 +prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3 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/src/Utils.hs b/src/Utils.hs index 07f37c889..1131e5afc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -822,14 +822,14 @@ and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) or2M ma = ifM ma (return True) -andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool -andM = Fold.foldr and2M (return True) -orM = Fold.foldr or2M (return False) +andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool +andM = ofoldl' and2M (return True) +orM = ofoldl' or2M (return False) -- | Short-circuiting monady any -allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool -allM xs f = andM $ fmap f xs -anyM xs f = orM $ fmap f xs +allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool +allM xs f = andM . fmap f $ otoList xs +anyM xs f = orM . fmap f $ otoList xs ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono) ofoldr1M f (otoList -> x:xs) = foldrM f x xs diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 3b334391c..f5251825e 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module Utils.Files ( sinkFile, sinkFiles , sinkFile', sinkFiles' @@ -35,6 +37,8 @@ import qualified Database.Esqueleto.Utils as E import Data.Conduit.Algorithms.FastCDC (fastCDC) +import Control.Monad.Trans.Cont + sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => Bool -- ^ Replace? Use only in serializable transaction @@ -43,14 +47,16 @@ sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnlif sinkFileDB doReplace fileContentContent = do chunkingParams <- getsYesod $ view _appFileChunkingParams - let sinkChunk fileContentChunkContent = do + let sinkChunk !fileContentChunkContent = do fileChunkLockTime <- liftIO getCurrentTime fileChunkLockInstance <- getsYesod appInstanceID observeSunkChunk StorageDB $ olength fileContentChunkContent tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. } + existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash] + let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased] if | existsChunk -> lift setContentBased | otherwise -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $ @@ -144,7 +150,22 @@ sinkFile File{ fileContent = Nothing, .. } = return FileReference , fileReferenceModified = fileModified } sinkFile File{ fileContent = Just fileContentContent, .. } = do - (unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE + chunk <- liftIO newEmptyTMVarIO + sourceAsync <- allocateLinkedAsync . runConduit $ fileContentContent .| C.mapM_ (atomically . putTMVar chunk) + + isEmpty <- atomically $ + False <$ readTMVar chunk + <|> True <$ waitSTM sourceAsync + + let fileContentContent' = evalContT . callCC $ \finishConsume -> forever $ do + inpChunk <- atomically $ + Right <$> takeTMVar chunk + <|> Left <$> waitCatchSTM sourceAsync + + case inpChunk of + Right inpChunk' -> lift $ yield inpChunk' + Left (Left exc) -> throwM exc + Left (Right res) -> finishConsume res fileContentHash <- if | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent' diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index 9f49e5a3c..5be1369df 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -62,6 +62,16 @@ $newline never ^{formatTimeW SelFormatDateTime deadline} $nothing _{MsgAllocationNextSubstitutesDeadlineNever} +
+ _{MsgAllocationFreeCapacity} # + ^{iconInvisible} +
+ $maybe freeCap <- freeCapacity + #{freeCap} + $if freeCap <= 0 + \ ^{iconOK} + $nothing + ∞ $maybe fromT <- allocationRegisterByCourse
_{MsgAllocationRegisterByCourseFrom} diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 322b5ea6d..56c967d06 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -24,6 +24,15 @@ $if isAdmin _{MsgCourseAllocationCourseAcceptsSubstitutesNever} $if allocationCourseAcceptSubstitutes >= Just now \ ^{iconOK} +

+ _{MsgCourseAllocationCourseParticipants}: + $maybe capacity <- courseCapacity + \ _{MsgCourseMembersCountLimited partCount capacity} + $if partCount < capacity + \ ^{iconProblem} + $nothing + \ _{MsgCourseMembersCount partCount} + \ ^{iconProblem} $if hasApplicationTemplate || is _Just courseApplicationsInstructions

_{MsgCourseApplicationInstructionsApplication} 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 diff --git a/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet b/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet new file mode 100644 index 000000000..55c53c6e5 --- /dev/null +++ b/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet @@ -0,0 +1,108 @@ +$newline never +

+ Die Plätze in den Zentralanmeldungen werden nach den folgenden # + Kriterien verteilt (in grober Reihenfolge des Einfluss, den sie auf # + die Verteilung haben): + +