From d8878a905e07f1b5fb5159ecdaf70f27e9c1dc37 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 15 Apr 2021 14:38:52 +0200 Subject: [PATCH] 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