feat(workflows): proper workflow-workflow-tables

frontend/src/app.sass

@@ -720,7 +720,7 @@ section
      background-color: hsla($hue, 75%, 50%, $opacity) !important
 
 
-.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text
+.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text, .cryptoid
   font-family: var(--font-monospace)
 
 .shown

messages/uniworx/de-de-formal.msg

@@ -3101,6 +3101,25 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWor
 SchoolWorkflowWorkflowWorkflowHeading ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
 SchoolWorkflowWorkflowWorkflowTitle ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
 
+WorkflowWorkflowListScopeTitle rScope@Text: Laufende Workflows - #{rScope}
+WorkflowWorkflowListScopeHeading rScope@Text: Laufende Workflows (#{rScope})
+WorkflowWorkflowListInstanceTitle: Laufende Workflows für Instanz
+WorkflowWorkflowListInstanceHeading: Laufende Workflows für Instanz
+WorkflowWorkflowListNamedInstanceTitle rScope@Text wiTitle@Text: Laufende Workflows - #{rScope}, #{wiTitle}
+WorkflowWorkflowListNamedInstanceHeading rScope@Text wiTitle@Text: Laufende Workflows (#{rScope}, #{wiTitle})
+WorkflowWorkflowListTopTitle: Laufende Workflows
+WorkflowWorkflowListTopHeading: Laufende Workflows
+AdminWorkflowWorkflowListTitle: Laufende Workflows
+AdminWorkflowWorkflowListHeading: Laufende Workflows
+
+WorkflowWorkflowListNumber: Nummer
+WorkflowWorkflowListScope: Bereich
+WorkflowWorkflowListInstance: Instanz
+WorkflowWorkflowListCurrentState: Aktueller Zustand
+WorkflowWorkflowListLastActionTime: Zeitpunkt, letzte Aktion
+WorkflowWorkflowListLastActionUser: Benutzer, letzte Aktion
+WorkflowWorkflowListIsFinal: Abgeschlossen?
+
 FormFieldWorkflowDatasetTip: Mindestens ein gekennzeichnetes Feld pro Datensatz muss ausgefüllt werden 
 
 ChangelogItemFeature: Feature

messages/uniworx/en-eu.msg

@@ -3061,6 +3061,25 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId: Workflow #{toPathPiece w
 SchoolWorkflowWorkflowWorkflowHeading ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
 SchoolWorkflowWorkflowWorkflowTitle ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
 
+WorkflowWorkflowListScopeTitle rScope: Running workflows - #{rScope}
+WorkflowWorkflowListScopeHeading rScope: Running workflows (#{rScope})
+WorkflowWorkflowListInstanceTitle: Running workflows for an instance
+WorkflowWorkflowListInstanceHeading: Running workflows for an instance
+WorkflowWorkflowListNamedInstanceTitle rScope wiTitle: Running workflows - #{rScope}, #{wiTitle}
+WorkflowWorkflowListNamedInstanceHeading rScope wiTitle: Running workflows (#{rScope}, #{wiTitle})
+WorkflowWorkflowListTopTitle: Running workflows
+WorkflowWorkflowListTopHeading: Running workflows
+AdminWorkflowWorkflowListTitle: Running workflows
+AdminWorkflowWorkflowListHeading: Running workflows
+
+WorkflowWorkflowListNumber: Number
+WorkflowWorkflowListScope: Scope
+WorkflowWorkflowListInstance: Instance
+WorkflowWorkflowListCurrentState: Current state
+WorkflowWorkflowListLastActionTime: Timestamp of last action
+WorkflowWorkflowListLastActionUser: User for last action
+WorkflowWorkflowListIsFinal: Finalised?
+
 FormFieldWorkflowDatasetTip: At least one of the marked fields must be filled
 WorkflowDefinitionGraph: Specification
 WorkflowDefinitionKeyDoesNotExist renderedCryptoID: Referenced id does not exist: #{renderedCryptoID}

src/Foundation/Navigation.hs

@@ -111,7 +111,16 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
     SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
     SchoolWorkflowInstanceNewR  -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
     SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
-      SWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) . Just $ SchoolR ssh SchoolWorkflowInstanceListR
+      SWIEditR -> do
+        mayList <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR
+        desc <- runDBRead . runMaybeT $ do
+          guard mayList
+          wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh
+          MaybeT $ selectWorkflowInstanceDescription wiId
+        let bRoute = SchoolR ssh SchoolWorkflowInstanceListR
+        case desc of
+          Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute
+          Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute
       SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
       SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
       SWIInitiateR -> do
@@ -379,7 +388,15 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
   breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing
   breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
   breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
-    GWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
+    GWIEditR -> do
+      mayList <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR
+      desc <- runDBRead . runMaybeT $ do
+        guard mayList
+        wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal
+        MaybeT $ selectWorkflowInstanceDescription wiId
+      case desc of
+        Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
+        Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR
     GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
     GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
     GWIInitiateR -> do

src/Handler/Utils/Table/Cells.hs

@@ -35,7 +35,7 @@ indicatorCell = writerCell . tell $ Any True
 writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
-maybeCell :: IsDBTable m a => Maybe a -> (a -> DBCell m a) -> DBCell m a
+maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
 maybeCell = flip foldMap
 
 htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
@@ -265,3 +265,6 @@ occurrencesCell = cell . occurrencesWidget
 
 roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a
 roomReferenceCell = cell . roomReferenceWidget
+
+cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
+cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece

src/Handler/Workflow/Instance/List.hs

@@ -77,11 +77,7 @@ getAdminWorkflowInstanceListR = do
             dbtRowKey = (E.^. WorkflowInstanceId)
             dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
               wi@(Entity wiId _) <- view _1
-              descLangs <- lift . E.select . E.from $ \workflowInstanceDescription -> do
+              desc <- lift $ selectWorkflowInstanceDescription wiId
-                E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
-                return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
-              descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
-              desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
               (wi, desc,)
                 <$> view (_2 . _Value)
             dbtColonnade :: Colonnade Sortable WorkflowInstanceData _

src/Handler/Workflow/Workflow/List.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.Workflow.Workflow.List
   ( getGlobalWorkflowWorkflowListR 
   , getSchoolWorkflowWorkflowListR
@@ -14,9 +16,18 @@ import Import
 import Utils.Workflow
 import Handler.Utils.Workflow.CanonicalRoute
 
+import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor)
+
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
+import Utils.Form
+import Handler.Utils hiding (columns)
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
 
 getGlobalWorkflowWorkflowListR :: Handler Html
 getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
@@ -27,7 +38,15 @@ getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
 workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
 workflowWorkflowListR rScope = do
   scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
-  workflowWorkflowList $ \workflowWorkflow -> workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
+  MsgRenderer mr <- getMsgRenderer
+  workflowWorkflowList (headings mr) columns . runReader $ do
+    workflowWorkflow <- view queryWorkflowWorkflow
+    return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
+  where
+     columns = def
+        { wwListColumnScope = False
+        }
+     headings mr = (MsgWorkflowWorkflowListScopeTitle $ mr rScope, MsgWorkflowWorkflowListScopeHeading $ mr rScope)
 
 
 getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
@@ -38,41 +57,264 @@ getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
 
 workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
 workflowInstanceWorkflowsR rScope win = do
-  scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
+  (scope, desc) <- runDB $ do
-  workflowWorkflowList $ \workflowWorkflow ->
+    scope <- maybeT notFound $ fromRouteWorkflowScope rScope
-    E.exists . E.from $ \workflowInstance ->
+    wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
+    desc <- selectWorkflowInstanceDescription wiId
+    return (scope, desc)
+  MsgRenderer mr <- getMsgRenderer
+  let headings = case desc of
+        Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading)
+        Just (Entity _ WorkflowInstanceDescription{..})
+          -> ( MsgWorkflowWorkflowListNamedInstanceTitle (mr rScope) workflowInstanceDescriptionTitle
+             , MsgWorkflowWorkflowListNamedInstanceHeading (mr rScope) workflowInstanceDescriptionTitle
+             )
+  workflowWorkflowList headings columns . runReader $ do
+    workflowWorkflow <- view queryWorkflowWorkflow
+    return . E.exists . E.from $ \workflowInstance ->
       E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
            E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
            E.&&. workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
+  where
+    columns = def
+        { wwListColumnInstance = False
+        , wwListColumnScope    = False
+        }
 
 
 getAdminWorkflowWorkflowListR :: Handler Html
-getAdminWorkflowWorkflowListR = workflowWorkflowList $ const E.true
+getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true
+  where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading)
 
 getTopWorkflowWorkflowListR :: Handler Html
-getTopWorkflowWorkflowListR = workflowWorkflowList $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
+getTopWorkflowWorkflowListR = workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
+  where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading)
 
 
-workflowWorkflowList :: (E.SqlExpr (Entity WorkflowWorkflow) -> E.SqlExpr (E.Value Bool))
+type WorkflowWorkflowTableExpr = E.SqlExpr (Entity WorkflowWorkflow)
+               `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity WorkflowInstance))
+
+queryWorkflowWorkflow :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Entity WorkflowWorkflow))
+queryWorkflowWorkflow = to $(E.sqlLOJproj 2 1)
+  
+queryWorkflowInstance :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Maybe (Entity WorkflowInstance)))
+queryWorkflowInstance = to $(E.sqlLOJproj 2 2)
+
+type WorkflowWorkflowData = DBRow
+  ( CryptoFileNameWorkflowWorkflow
+  , Maybe RouteWorkflowScope
+  , Entity WorkflowWorkflow
+  , Maybe (Entity WorkflowInstance)
+  , Maybe (Entity WorkflowInstanceDescription)
+  , Maybe WorkflowWorkflowActionData -- ^ Last Action
+  )
+
+type WorkflowWorkflowActionData = ( Maybe Text
+                                  , UTCTime
+                                  , Maybe WorkflowHistoryItemActor
+                                  , Maybe Icon
+                                  )
+
+resultWorkflowWorkflowId :: Lens' WorkflowWorkflowData CryptoFileNameWorkflowWorkflow
+resultWorkflowWorkflowId = _dbrOutput . _1
+
+resultRouteScope :: Lens' WorkflowWorkflowData (Maybe RouteWorkflowScope)
+resultRouteScope = _dbrOutput . _2
+
+_resultWorkflowWorkflow :: Lens' WorkflowWorkflowData (Entity WorkflowWorkflow)
+_resultWorkflowWorkflow = _dbrOutput . _3
+
+resultWorkflowInstance :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstance))
+resultWorkflowInstance = _dbrOutput . _4
+
+resultWorkflowInstanceDescription :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstanceDescription))
+resultWorkflowInstanceDescription = _dbrOutput . _5
+
+resultWorkflowInstanceTitle :: Getter WorkflowWorkflowData Text
+resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescription . _Just . _entityVal . _workflowInstanceDescriptionTitle of
+  Just dTitle -> dTitle
+  Nothing -> x ^. resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName . to CI.original
+
+resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData)
+resultLastAction = _dbrOutput . _6
+
+actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text)
+actionTo = _1
+
+actionTime :: Lens' WorkflowWorkflowActionData UTCTime
+actionTime = _2
+  
+actionActor :: Lens' WorkflowWorkflowActionData (Maybe WorkflowHistoryItemActor)
+actionActor = _3
+  
+actionFinal :: Lens' WorkflowWorkflowActionData (Maybe Icon)
+actionFinal = _4
+
+data WorkflowWorkflowListColumns = WWListColumns
+  { wwListColumnInstance :: Bool
+  , wwListColumnScope    :: Bool
+  }
+
+instance Default WorkflowWorkflowListColumns where
+  def = WWListColumns
+    { wwListColumnInstance = True
+    , wwListColumnScope    = True
+    }
+  
+workflowWorkflowList :: ( RenderMessage UniWorX title, RenderMessage UniWorX heading)
+                     => (title, heading)
+                     -> WorkflowWorkflowListColumns
+                     -> (WorkflowWorkflowTableExpr -> E.SqlExpr (E.Value Bool))
                      -> Handler Html
-workflowWorkflowList sqlPred = do -- not implemented; TODO: FIXME
+workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do 
-  wfRoutes <- runDB $ do
+  mAuthId <- maybeAuthId
-    wfs <- E.select . E.from $ \workflowWorkflow -> do
-      E.where_ $ sqlPred workflowWorkflow
-      return workflowWorkflow
-    flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
-      rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
-      cID <- encrypt wfId
-      let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-      guardM $ hasReadAccessTo route
-      return (cID, route)
   
-  defaultLayout
+  workflowTable <- runDB $
-    [whamlet|
+    let
-      $newline never
+      workflowWorkflowDBTable = DBTable{..}
-      <ul>
+        where
-        $forall (cID, route) <- wfRoutes
+          dbtSQLQuery = runReaderT $ do
-          <li>
+            workflowWorkflow <- view queryWorkflowWorkflow
-            <a href=@{route}>
+            workflowInstance <- view queryWorkflowInstance
-              #{toPathPiece cID}
+            lift . E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. workflowInstance E.?. WorkflowInstanceId
-    |]
+            lift <=< asks $ E.where_ . sqlPred
+            return (workflowWorkflow, workflowInstance)
+          dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
+          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+            ww@(Entity wwId WorkflowWorkflow{..}) <- view _1
+            mwi <- view _2
+            wiDesc <- lift . runMaybeT $ do
+              Entity wiId _ <- hoistMaybe mwi
+              MaybeT $ selectWorkflowInstanceDescription wiId
+            cID <- encrypt wwId
+            rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
+            let WorkflowGraph{..} = ww ^. _entityVal . _workflowWorkflowGraph . from _DBWorkflowGraph
+                hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
+                hasWorkflowRole' role = maybeT (return False) $ do
+                  rScope' <- hoistMaybe rScope
+                  let canonRoute = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
+                  lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
+
+            let
+              goAction p w = lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
+                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
+                    Just <$> lift (w act)
+              descAction p = goAction p $ \WorkflowAction{..} ->
+                let actName = runMaybeT $ do
+                      WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
+                      guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole'
+                      selectLanguageI18n wnvDisplayLabel
+                    actUser = for wpUser $ \wpUser' -> if
+                      | is _Just mAuthId
+                      , wpUser' == mAuthId -> return WHIASelf
+                      | otherwise -> maybeT (return WHIAHidden) $ do
+                          viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
+                          guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
+                          resUser <- lift $ traverse getEntity wpUser'
+                          return $ case resUser of
+                            Nothing          -> WHIAOther Nothing
+                            Just Nothing     -> WHIAGone
+                            Just (Just uEnt) -> WHIAOther $ Just uEnt
+                      where mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
+                    actFinal = do
+                      WGN{..} <- Map.lookup wpTo wgNodes
+                      wgnFinal
+                 in (,,,)
+                      <$> actName
+                      <*> pure wpTime
+                      <*> actUser
+                      <*> pure actFinal
+            lastAct <- descAction $ re _nullable . _Snoc . swapped
+
+            return (cID, rScope, ww, mwi, wiDesc, lastAct)
+          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 (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
+              stateCell = \case
+                (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text)
+                (Just n, Nothing) -> textCell n
+                (Just n, Just fin) -> cell [whamlet|#{icon fin}&nbsp;#{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
+                where mkLink = runReaderT $ 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)
+          dbtSorting = mconcat
+            [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId
+            , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope
+            , singletonMap "instance" . SortProjected . comparing $ preview resultWorkflowInstanceTitle
+            , singletonMap "current-state" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTo . _Just
+            , singletonMap "last-action-time" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTime
+            , singletonMap "last-action-user" . SortProjected . comparing . preview $ resultLastAction . _Just . actionActor . to (over (mapped . mapped) $ \(Entity _ User{..}) -> (userSurname, userDisplayName))
+            , singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
+            ]
+          dbtFilter = mconcat
+            [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
+                let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
+                    criteria' = map CI.mk . unpack <$> Set.toList criteria
+                 in any (`isInfixOf` cid) criteria'
+            , singletonMap "may-access" . FilterProjected $ \x (Any b) -> fmap (== b) . maybeT (return False) $ do
+                let cID = x ^. resultWorkflowWorkflowId
+                rScope <- hoistMaybe $ x ^. resultRouteScope
+                lift . lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
+            , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
+                let criteria' = map CI.mk . unpack <$> Set.toList criteria
+                 in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
+            , singletonMap "final" . FilterProjected $ \x (criterion :: Last Bool) -> case getLast criterion of
+                Nothing -> True
+                Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
+                                      && has (resultLastAction . _Just . actionFinal . _Just) x
+                                in needle == val
+            ]
+          dbtFilterUI = mconcat
+            [ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
+            , flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
+
+            , flip (prismAForm (singletonFilter "final" . maybePrism _PathPiece)) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgWorkflowWorkflowListIsFinal)
+            ]
+          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtParams = def
+          dbtIdent :: Text
+          dbtIdent = "workflow-workflows"
+          dbtCsvEncode = noCsvEncode
+          dbtCsvDecode = Nothing
+      workflowWorkflowDBTableValidator = def
+        & defaultSorting defSort
+        & forceFilter "may-access" (Any True)
+      defSort | wwListColumnInstance = SortAscBy "instance" : defSort'
+              | otherwise = defSort'
+        where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"]
+     in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable
+
+  siteLayoutMsg heading $ do
+    setTitleI title
+
+    workflowTable

src/Handler/Workflow/Workflow/Workflow.hs

@@ -2,6 +2,7 @@ module Handler.Workflow.Workflow.Workflow
   ( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
   , getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
   , workflowR
+  , WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor
   ) where
 
 import Import hiding (Last(..), Encoding(None))
@@ -38,25 +39,26 @@ import Data.Void (absurd)
 import Data.List (inits)
 
 
-data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHIAHidden | WHIAGone
+data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone
-  deriving (Generic, Typeable)
+  deriving (Eq, Ord, Functor, Traversable, Foldable, Generic, Typeable)
+type WorkflowHistoryItemActor = WorkflowHistoryItemActor' (Entity User)
   
 data WorkflowHistoryItem = WorkflowHistoryItem
   { whiUser :: Maybe WorkflowHistoryItemActor
   , whiTime :: UTCTime
   , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
-  , whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
+  , whiFrom :: Maybe (Maybe (Text, Maybe Icon)) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
   , whiVia :: Maybe Text
-  , whiTo :: Maybe Text
+  , whiTo :: Maybe (Text, Maybe Icon)
   } deriving (Generic, Typeable)
 
 data WorkflowCurrentState = WorkflowCurrentState
-  { wcsState :: Maybe Text
+  { wcsState :: Maybe (Text, Maybe Icon)
   , wcsMessages :: Set Message
   , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
   }
 
-makePrisms ''WorkflowHistoryItemActor
+makePrisms ''WorkflowHistoryItemActor'
 
 data OneOrMany a = None | One a | Many
   deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable)
@@ -130,9 +132,10 @@ workflowR rScope cID = do
             
             stCID <- encryptWorkflowStateIndex wwId stIx
             let nodeView nodeLbl = do
-                  WorkflowNodeView{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes >>= wgnViewers
+                  WGN{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes
+                  WorkflowNodeView{..} <- hoistMaybe wgnViewers
                   guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
-                  selectLanguageI18n wnvDisplayLabel
+                  (, wgnFinal) <$> selectLanguageI18n wnvDisplayLabel
                 whiTime = wpTime
                 mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
                 hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
@@ -241,8 +244,13 @@ workflowR rScope cID = do
     WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
     WSSchool ssh -> return (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
     _other -> error "not implemented"
+  let headingWgt
+        | Just WorkflowCurrentState{..} <- workflowState
+        , Just (_, Just icn) <- wcsState
+        = [whamlet|_{heading}&nbsp;#{icon icn}|]
+        | otherwise = i18n heading
 
-  siteLayoutMsg heading $ do
+  siteLayout headingWgt $ do
     setTitleI title
     let mEdgeView = mEdge <&> \((_, edgeView'), edgeEnc) -> wrapForm edgeView' FormSettings
           { formMethod = POST

src/Model/Types/TH/JSON.hs

@@ -68,15 +68,12 @@ predNFAesonOptions = defaultOptions
   }
   
 
-workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions :: Options
+workflowGraphEdgeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions :: Options
 workflowGraphEdgeAesonOptions = defaultOptions
   { constructorTagModifier = camelToPathPiece' 3
   , fieldLabelModifier = camelToPathPiece' 1
   , sumEncoding = TaggedObject "mode" $ error "There should be no field called ‘mode’"
   }
-workflowGraphNodeAesonOptions = defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  }
 workflowActionAesonOptions = defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   }

src/Model/Types/Workflow.hs

@@ -77,7 +77,7 @@ newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLab
   deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
 
 data WorkflowGraphNode fileid userid = WGN
-  { wgnFinal        :: Bool
+  { wgnFinal        :: Maybe Icon
   , wgnViewers      :: Maybe (WorkflowNodeView userid)
   , wgnMessages     :: Set (WorkflowNodeMessage userid)
   , wgnEdges        :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
@@ -814,15 +814,34 @@ instance ( FromJSON fileid, FromJSON userid
         wpfmRange       <-  o JSON..:? "range"
         return $ WorkflowPayloadSpec WorkflowPayloadFieldMultiple{..}
 
+defaultFinalIcon :: Icon
+defaultFinalIcon = IconOK
+
 instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphNode fileid userid) where
-  toJSON = genericToJSON workflowGraphNodeAesonOptions
+  toJSON WGN{..} = JSON.object
+    [ ("final" JSON..=) $ case wgnFinal of
+        Nothing -> toJSON False
+        Just icn | icn == defaultFinalIcon -> toJSON True
+        other -> toJSON other
+    , "viewers" JSON..= wgnViewers
+    , "messages" JSON..= wgnMessages
+    , "edges" JSON..= wgnEdges
+    , "payload-view" JSON..= wgnPayloadView
+    ]
 instance ( FromJSON fileid, FromJSON userid
          ,      Ord fileid,      Ord userid
          , Typeable fileid, Typeable userid
          , FromJSON (FileField fileid)
          , Ord (FileField fileid)
          ) => FromJSON (WorkflowGraphNode fileid userid) where
-  parseJSON = genericParseJSON workflowGraphNodeAesonOptions
+  parseJSON = JSON.withObject "WorkflowGraphNode" $ \o -> do
+    wgnFinal <- o JSON..:? "final"
+            <|> fmap (bool Nothing $ Just defaultFinalIcon) (o JSON..: "final")
+    wgnViewers <- o JSON..:? "viewers"
+    wgnMessages <- o JSON..:? "messages" JSON..!= Set.empty
+    wgnEdges <- o JSON..:? "edges" JSON..!= Map.empty
+    wgnPayloadView <- o JSON..:? "payload-view" JSON..!= Map.empty
+    return WGN{..}
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1

src/Utils/Workflow.hs

@@ -6,8 +6,10 @@ module Utils.Workflow
   , _DBWorkflowGraph
   , DBWorkflowState, IdWorkflowState
   , _DBWorkflowState
+  , DBWorkflowAction, IdWorkflowAction
   , decryptWorkflowStateIndex, encryptWorkflowStateIndex
   , isTopWorkflowScope, isTopWorkflowScopeSql
+  , selectWorkflowInstanceDescription
   ) where
 
 import Import.NoFoundation
@@ -77,6 +79,9 @@ _DBWorkflowState = iso toDB fromDB
     toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
     fromDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference SqlBackendKey) @(WorkflowState FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
 
+type IdWorkflowAction = WorkflowAction FileReference UserId
+type DBWorkflowAction = WorkflowAction FileReference SqlBackendKey
+
 
 data WorkflowStateIndexKeyException
   = WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom
@@ -112,3 +117,16 @@ isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . c
 isTopWorkflowScopeSql :: E.SqlExpr (E.Value DBWorkflowScope) -> E.SqlExpr (E.Value Bool)
 isTopWorkflowScopeSql = (`E.in_` E.valList [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScopeSql
   where classifyWorkflowScopeSql = (E.->. "tag")
+
+
+selectWorkflowInstanceDescription :: ( MonadHandler m
+                                     , BackendCompatible SqlReadBackend backend
+                                     )
+                                  => WorkflowInstanceId
+                                  -> ReaderT backend m (Maybe (Entity WorkflowInstanceDescription))
+selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBackend) $ do
+  descLangs <- E.select . E.from $ \workflowInstanceDescription -> do
+    E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
+    return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
+  descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
+  fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'

templates/workflows/workflow.hamlet

@@ -9,8 +9,10 @@ $maybe WorkflowCurrentState{..} <- workflowState
         <dt .deflist__dt>
           _{MsgWorkflowWorkflowWorkflowStateStateLabel}
         <dd .deflist__dd>
-          $maybe stLbl <- wcsState
+          $maybe (stLbl, stFin) <- wcsState
-              #{stLbl}
+            #{stLbl}
+            $maybe icn <- stFin
+              &nbsp;#{icon icn}
           $nothing
             <span .workflow-state--state-special>
               _{MsgWorkflowWorkflowWorkflowStateStateHidden}

templates/workflows/workflow/history-item.hamlet

@@ -37,16 +37,20 @@ $newline never
         <dt .deflist__dt>
           _{MsgWorkflowWorkflowWorkflowHistoryFromLabel}
         <dd .deflist__dd>
-          $maybe fromLbl <- mFromLbl
+          $maybe (fromLbl, fromFin) <- mFromLbl
             #{fromLbl}
+            $maybe icn <- fromFin
+              &nbsp;#{icon icn}
           $nothing
             <span .workflow-history--item-state-special>
               _{MsgWorkflowWorkflowWorkflowHistoryStateHidden}
       <dt .deflist__dt>
         _{MsgWorkflowWorkflowWorkflowHistoryToLabel}
       <dd .deflist__dd>
-        $maybe toLbl <- whiTo
+        $maybe (toLbl, toFin) <- whiTo
-            #{toLbl}
+          #{toLbl}
+          $maybe icn <- toFin
+            &nbsp;#{icon icn}
         $nothing
           <span .workflow-history--item-state-special>
             _{MsgWorkflowWorkflowWorkflowHistoryStateHidden}