diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 8d96b8a3f..5164e67fc 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -35,10 +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 Control.Monad.Trans.State.Strict (execStateT) +import qualified Control.Monad.State.Class as State --- import qualified Data.RFC5051 as RFC5051 +import qualified Data.RFC5051 as RFC5051 data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj @@ -204,8 +204,8 @@ resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescrip resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData) resultLastAction = _dbrOutput . _6 --- resultPersons :: Traversal' WorkflowWorkflowData (Entity User) --- resultPersons = _dbrOutput . _7 . traverse +resultPersons :: Traversal' WorkflowWorkflowData (Entity User) +resultPersons = _dbrOutput . _7 . traverse actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text) actionTo = _1 @@ -307,53 +307,52 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do <*> pure actFinal lastAct <- descAction $ re _nullable . _Snoc . swapped - -- 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 . 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' + persons <- lift . lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' - -- return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) - return (cID, rScope, ww, mwi, wiDesc, lastAct, error "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 :: CryptoFileNameWorkflowWorkflow -> Text) - -- , 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 + , 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))) + 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 - -- (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] - -- actorCell = \case - -- Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) - -- Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) - -- Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) - -- Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) - -- Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) - -- Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname + stateCell = \case + (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) + (Just n, Nothing) -> textCell n + (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] + actorCell = \case + Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) + Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) + Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) + Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) + Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) + Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _ anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f @@ -361,15 +360,15 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do cID <- view resultWorkflowWorkflowId rScope <- hoistMaybe =<< view resultRouteScope return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) - -- anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f - -- where mkLink = runReaderT $ do - -- rScope <- hoistMaybe =<< view resultRouteScope - -- return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - -- anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f - -- where mkLink = runReaderT $ do - -- rScope <- hoistMaybe =<< view resultRouteScope - -- win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) - -- return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f + where mkLink = runReaderT $ do + rScope <- hoistMaybe =<< view resultRouteScope + return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) + anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f + where mkLink = runReaderT $ do + rScope <- hoistMaybe =<< view resultRouteScope + win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) + return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) dbtSorting = mconcat [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope