From c89e02fad264e769f435ebe0979733385bdc9dc0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Apr 2021 12:52:00 +0200 Subject: [PATCH 1/7] chore: redundant constraint --- src/Foundation/Yesod/ErrorHandler.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 4669a6bac..692250da3 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -24,7 +24,6 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX)) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX - , Button UniWorX ButtonSubmit , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent From f60d58993147053b9f2590251ddfd9b9634516ee Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Apr 2021 12:53:02 +0200 Subject: [PATCH 2/7] chore(release): 25.9.2 --- CHANGELOG.md | 2 ++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6df8c4fbf..09e5fc990 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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. +## [25.9.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.1...v25.9.2) (2021-04-14) + ## [25.9.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.0...v25.9.1) (2021-04-14) ## [25.9.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.8.1...v25.9.0) (2021-04-13) diff --git a/package-lock.json b/package-lock.json index 1666220d7..4e426f8ac 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.1", + "version": "25.9.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index e81fa6dd3..0103d4ed4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.1", + "version": "25.9.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 6f48c0774..634dc3e91 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.9.1 +version: 25.9.2 dependencies: - base - yesod From eb2cad341fbfa9ac262755e80db0ade829d480c9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Apr 2021 14:32:52 +0200 Subject: [PATCH 3/7] chore: redundant import --- src/Foundation/Yesod/ErrorHandler.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 692250da3..af67f5b8b 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -4,8 +4,6 @@ module Foundation.Yesod.ErrorHandler import Import.NoFoundation hiding (errorHandler) -import Utils.Form - import Foundation.Type import Foundation.I18n import Foundation.Authorization From 1a4469aefd9ae0d6a88cbbdefd1cabe3de9456af Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Apr 2021 14:33:14 +0200 Subject: [PATCH 4/7] chore(release): 25.9.3 --- CHANGELOG.md | 2 ++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 09e5fc990..5e3b3da3c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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. +## [25.9.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.2...v25.9.3) (2021-04-14) + ## [25.9.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.1...v25.9.2) (2021-04-14) ## [25.9.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.0...v25.9.1) (2021-04-14) diff --git a/package-lock.json b/package-lock.json index 4e426f8ac..5d30186f5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.2", + "version": "25.9.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 0103d4ed4..9ec1611c2 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.2", + "version": "25.9.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 634dc3e91..c8280026f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.9.2 +version: 25.9.3 dependencies: - base - yesod From d8878a905e07f1b5fb5159ecdaf70f27e9c1dc37 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 15 Apr 2021 14:38:52 +0200 Subject: [PATCH 5/7] feat(workflows): list involved users --- messages/uniworx/misc/de-de-formal.msg | 3 +++ messages/uniworx/misc/en-eu.msg | 3 +++ src/Handler/Utils/Table/Pagination.hs | 6 ++--- src/Handler/Workflow/Workflow/List.hs | 36 ++++++++++++++++++++++++-- 4 files changed, 43 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 040f301c5..b34955a0b 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -3231,3 +3231,6 @@ CorrectionInvisibleExamUnfinished: Die Frist „_{MsgExamFinished}“ für die r CorrectionInvisibleRatingNotDone: Die Bewertung ist nicht als „Abgeschlossen“ markiert CorrectionInvisibleWarning: Die Bewertung dieser Abgabe ist aktuell für mindestens eine an der Abgabe beteiligte Person nicht sichtbar! CorrectionInvisibleReasons: Mögliche Gründe hierfür: + + +WorkflowWorkflowListPersons: Beteiligte Benutzer \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index bf2d4861c..a7a607e59 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -3231,3 +3231,6 @@ CorrectionInvisibleExamUnfinished: The time configured in “_{MsgExamFinished} CorrectionInvisibleRatingNotDone: The correction is not marked as “finished” CorrectionInvisibleWarning: This correction is currently invisible for at least one of the submittors! CorrectionInvisibleReasons: Possible reasons include: + + +WorkflowWorkflowListPersons: Involved users \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 8cae1f08b..27827d25b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1699,13 +1699,13 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ toWidget $ x2widgetUnauth Nothing -listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a +listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a listCell = listCell' . return -listCell' :: (IsDBTable m a, Traversable f) => WriterT a m (f r') -> (r' -> DBCell m a) -> DBCell m a +listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a listCell' mkXS mkCell = review dbCell . ([], ) $ do xs <- mkXS - cells <- forM xs $ + cells <- forM (toList xs) $ \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget return $(widgetFile "table/cell/list") diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 7417af3b2..c537e72fc 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -35,6 +35,10 @@ import Data.Semigroup (Last(..)) import qualified Data.Monoid as Monoid (Last(..)) import Control.Monad.Trans.Writer.Strict (WriterT) +import Control.Monad.Trans.State.Strict (execStateT) +import qualified Control.Monad.State.Class as State + +import qualified Data.RFC5051 as RFC5051 getGlobalWorkflowWorkflowListR :: Handler Html @@ -115,6 +119,7 @@ type WorkflowWorkflowData = DBRow , Maybe (Entity WorkflowInstance) , Maybe (Entity WorkflowInstanceDescription) , Maybe WorkflowWorkflowActionData -- ^ Last Action + , [Entity User] ) type WorkflowWorkflowActionData = ( Maybe Text @@ -181,6 +186,9 @@ resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescrip resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData) resultLastAction = _dbrOutput . _6 +resultPersons :: Traversal' WorkflowWorkflowData (Entity User) +resultPersons = _dbrOutput . _7 . traverse + actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text) actionTo = _1 @@ -243,7 +251,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do where go Nothing = return Nothing go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do - guardM . lift . $cachedHereBinary (wwId, wpTo act, wpUser act, Map.keys $ wpPayload act) $ mayViewWorkflowAction mAuthId wwId act + guardM . lift $ mayViewWorkflowAction mAuthId wwId act Just <$> lift (w act) descAction p = goAction p $ \WorkflowAction{..} -> let actName = runMaybeT $ do @@ -272,17 +280,41 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do <*> pure actFinal lastAct <- descAction $ re _nullable . _Snoc . swapped - return (cID, rScope, ww, mwi, wiDesc, lastAct) + persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do + let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes + guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act + lift . maybeT_ . hoist (zoom _1) $ do + viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia + guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole' + State.modify' $ Set.insert wpUser' + iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do + let users = setOf (typesCustom @WorkflowChildren) ps + guard . not $ null users + WorkflowPayloadView{..} <- hoistMaybe $ do + WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes + Map.lookup pLbl wgnPayloadView + guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole' + at pLbl ?= users + + persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' + + return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat -- TODO: columns [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . toPathPiece , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x + , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x -> + let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname) + in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell ] where + personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded))) + <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded))) + stateCell = \case (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) (Just n, Nothing) -> textCell n From ed80725937d1566693d2f7b97cb3cad5e2269897 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 15 Apr 2021 15:41:30 +0200 Subject: [PATCH 6/7] chore(release): 25.10.0 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5e3b3da3c..8a82ef56c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +## [25.10.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.3...v25.10.0) (2021-04-15) + + +### Features + +* **workflows:** list involved users ([d8878a9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d8878a905e07f1b5fb5159ecdaf70f27e9c1dc37)) + ## [25.9.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.2...v25.9.3) (2021-04-14) ## [25.9.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.1...v25.9.2) (2021-04-14) diff --git a/package-lock.json b/package-lock.json index 5d30186f5..400589d5f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.3", + "version": "25.10.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9ec1611c2..2f8013dd7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.9.3", + "version": "25.10.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index c8280026f..f6de3f536 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.9.3 +version: 25.10.0 dependencies: - base - yesod From 407aa5edde99570e41a172c6d5562cc06f2c4e83 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 3 May 2021 11:44:05 +0200 Subject: [PATCH 7/7] refactor(participants-intersect): do intersect in haskell not sql --- messages/uniworx/misc/de-de-formal.msg | 4 +-- messages/uniworx/misc/en-eu.msg | 4 +-- src/Handler/Participants.hs | 30 +++++++++---------- src/Handler/Utils/Form.hs | 3 +- src/Handler/Workflow/Instance/Form.hs | 2 +- .../widgets/massinput/courses/add.hamlet | 2 +- .../widgets/massinput/courses/cell.hamlet | 2 ++ 7 files changed, 24 insertions(+), 23 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index b34955a0b..68be69df4 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -2849,7 +2849,7 @@ InfoLecturerTutorials: Tutorien InfoLecturerExams: Prüfungen InfoLecturerAllocations: Zentralanmeldungen -ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName: #{tid} - #{ssh} - #{csh}: #{coursen} ParticipantsIntersectCourses: Kurse AllocationUsersTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber @@ -2941,7 +2941,7 @@ AllocationUsersCount: Teilnehmer AllocationCoursesCount: Kurse AllocationCourseEligible: Berücksichtigt -CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +CourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName: #{tid} - #{ssh} - #{csh}: #{coursen} BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden! BearerTokenAuthorityGroups: Token-Authorität (Gruppen) diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index a7a607e59..3e201a5fa 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -2849,7 +2849,7 @@ InfoLecturerTutorials: Tutorials InfoLecturerExams: Exams InfoLecturerAllocations: Central allocations -ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen} ParticipantsIntersectCourses: Courses AllocationUsersTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Applicants @@ -2941,7 +2941,7 @@ AllocationUsersCount: Participants AllocationCoursesCount: Courses AllocationCourseEligible: Considered -CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen} +CourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen} BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions inte bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer! BearerTokenAuthorityGroups: Authority (groups) diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index e04cf9496..569d8ea46 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -96,23 +96,21 @@ postParticipantsIntersectR = do } intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do - let coursePairs = do - cid <- Set.toList cids - other <- Set.toList . snd $ Set.split cid cids - return (cid, other) - intersections <- fmap Map.fromList . forM coursePairs $ \cidPair@(lCid, uCid) -> fmap (\[E.Value n] -> (cidPair, n)) . E.select . E.from $ \user -> do - E.where_ . E.exists . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId - E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val lCid - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.where_ . E.exists . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId - E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] - let intersections' = Map.union intersections selfIntersections + courseUsers <- flip mapFromSetM cids $ \cid -> fmap (Set.fromList . map E.unValue) . E.select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + return $ participant E.^. CourseParticipantUser courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404 + + let coursePairs = Set.fromAscList $ do + cid <- Set.toAscList cids + other <- Set.toAscList . snd $ Set.split cid cids + return (cid, other) + intersections = flip Map.fromSet coursePairs $ \(lCid, uCid) + -> Set.size $ Map.findWithDefault Set.empty lCid courseUsers `Set.intersection` Map.findWithDefault Set.empty uCid courseUsers + selfIntersections = Map.mapKeysMonotonic (\cid -> (cid, cid)) $ Set.size <$> courseUsers + intersections' = Map.union intersections selfIntersections + return (courses, intersections') let diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0cbf85785..1e8472019 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2098,12 +2098,13 @@ courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired m course <- query E.orderBy [ E.desc $ course E.^. CourseTerm , E.asc $ course E.^. CourseSchool + , E.asc $ course E.^. CourseShorthand , E.asc $ course E.^. CourseName ] return course miAdd' nudge btn csrf = do - let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions + let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions (courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses) diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs index 246ac38cf..ffa9c6fa1 100644 --- a/src/Handler/Workflow/Instance/Form.hs +++ b/src/Handler/Workflow/Instance/Form.hs @@ -39,7 +39,7 @@ workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ , WSCourse <$> apopt (selectField' Nothing courseOptions) (fslI MsgCourse) (mPrev ^? _Just . _wisCourse) ) ] - where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseName + where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName data WorkflowInstanceForm = WorkflowInstanceForm diff --git a/templates/widgets/massinput/courses/add.hamlet b/templates/widgets/massinput/courses/add.hamlet index 879d67f4f..7103db24a 100644 --- a/templates/widgets/massinput/courses/add.hamlet +++ b/templates/widgets/massinput/courses/add.hamlet @@ -1,5 +1,5 @@ $newline never - + #{csrf} ^{fvWidget addView} diff --git a/templates/widgets/massinput/courses/cell.hamlet b/templates/widgets/massinput/courses/cell.hamlet index 5fd8639ae..ed4d08078 100644 --- a/templates/widgets/massinput/courses/cell.hamlet +++ b/templates/widgets/massinput/courses/cell.hamlet @@ -3,5 +3,7 @@ $newline never #{courseTerm} #{courseSchool} + + #{courseShorthand} #{courseName}