feat(workflows): update instances from definitions

frontend/src/app.sass

@@ -103,8 +103,8 @@ body
 .emph
   font-style: italic
 
-a,
+a:not(.btn),
-a:visited
+a:visited:not(.btn)
   text-decoration: none
   font-weight: 600
   transition: color .2s ease, background-color .2s ease
@@ -275,6 +275,9 @@ button:not(.btn-link),
   display: grid
   grid: min-content / auto-flow max-content
 
+  > form
+    margin: 0 !important
+
   .buttongroup--inline
     display: inline-grid
 

messages/uniworx/categories/workflows/de-de-formal.msg

@@ -146,4 +146,11 @@ YAMLFieldDecodeFailure yamlFailure@String: Konnte YAML nicht parsen: #{yamlFailu
 
 WGFTextInput: Textfeld
 WGFFileUpload: Dateifeld
-WorkflowWorkflowListPersons: Beteiligte Benutzer
+WorkflowWorkflowListPersons: Beteiligte Benutzer
+
+BtnWorkflowInstanceUpdate !ident-ok: Update
+WorkflowInstanceUpdateNoActions: Keine Updates verfügbar
+WorkflowInstanceUpdateUpdatedGraph: Definitions-Update erfolgreich angewandt
+WorkflowInstanceUpdateUpdatedCategory: Kategorie-Update erfolgreich angewandt
+WorkflowInstanceUpdateDeletedDescriptionLanguage lang@Lang: Beschreibung/Titel in Sprache „#{lang}“ gelöscht
+WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt

messages/uniworx/categories/workflows/en-eu.msg

@@ -147,3 +147,10 @@ YAMLFieldDecodeFailure yamlFailure: Could not parse YAML: #{yamlFailure}
 WGFTextInput: Text field
 WGFFileUpload: File field
 WorkflowWorkflowListPersons: Involved users
+
+BtnWorkflowInstanceUpdate: Update
+WorkflowInstanceUpdateNoActions: No updates available
+WorkflowInstanceUpdateUpdatedGraph: Successfully applied updated definition
+WorkflowInstanceUpdateUpdatedCategory: Successfully applied updated category
+WorkflowInstanceUpdateDeletedDescriptionLanguage lang: Successfully deleted description/title for language “#{lang}”
+WorkflowInstanceUpdateUpdatedDescriptionLanguage lang: Successfully applied updated description/title for language “#{lang}”

messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg

@@ -96,6 +96,7 @@ BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows
 BreadcrumbWorkflowInstanceInitiate: Workflow starten
 BreadcrumbWorkflowInstanceList !ident-ok: Workflows
 BreadcrumbWorkflowInstanceNew: Neuer Workflow
+BreadcrumbWorkflowInstanceUpdate !ident-ok: Update
 BreadcrumbWorkflowWorkflowList: Laufende Workflows
 BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow !ident-ok: #{toPathPiece workflow}
 BreadcrumbWorkflowWorkflowFiles: Dateien

messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg

@@ -96,6 +96,7 @@ BreadcrumbWorkflowInstanceWorkflowList: Running workflows
 BreadcrumbWorkflowInstanceInitiate: Start workflow
 BreadcrumbWorkflowInstanceList: Workflows
 BreadcrumbWorkflowInstanceNew: New workflow
+BreadcrumbWorkflowInstanceUpdate !ident-ok: Update
 BreadcrumbWorkflowWorkflowList: Running workflows
 BreadcrumbWorkflowWorkflow workflow: #{toPathPiece workflow}
 BreadcrumbWorkflowWorkflowFiles: Files

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -121,6 +121,7 @@ MenuAdminWorkflowDefinitionDelete: Löschen
 MenuAdminWorkflowInstanceList: Workflow-Instanzen
 MenuAdminWorkflowInstanceNew: Neue Workflow-Instanz
 MenuAdminWorkflowDefinitionInstantiate: Instanziieren
+MenuWorkflowInstanceUpdate !ident-ok: Update
 MenuWorkflowInstanceDelete: Löschen
 MenuWorkflowInstanceWorkflows: Laufende Workflows
 MenuWorkflowInstanceInitiate: Workflow starten

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -122,6 +122,7 @@ MenuAdminWorkflowDefinitionDelete: Delete
 MenuAdminWorkflowInstanceList: Workflow instances
 MenuAdminWorkflowInstanceNew: New workflow instance
 MenuAdminWorkflowDefinitionInstantiate: Instantiate
+MenuWorkflowInstanceUpdate !ident-ok: Update
 MenuWorkflowInstanceDelete: Delete
 MenuWorkflowInstanceWorkflows: Running workflows
 MenuWorkflowInstanceInitiate: Start workflow

routes

@@ -80,6 +80,7 @@
   /delete                     GWIDeleteR       GET POST
   /workflows                  GWIWorkflowsR    GET             !¬empty
   /initiate                   GWIInitiateR     GET POST        !workflow
+  /update                     GWIUpdateR           POST
 /global-workflows             GlobalWorkflowWorkflowListR GET  !free
 !/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
   /                           GWWWorkflowR     GET POST        !workflow
@@ -146,6 +147,7 @@
     /delete                SWIDeleteR    GET POST
     /workflows             SWIWorkflowsR GET                   !¬empty
     /initiate              SWIInitiateR  GET POST              !workflow
+    /update                SWIUpdateR        POST
   /workflows               SchoolWorkflowWorkflowListR GET     !free
   !/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR:
     /                      SWWWorkflowR  GET POST              !workflow

src/Foundation/Navigation.hs

@@ -141,6 +141,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of
       i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
         | mayEdit -> SchoolWorkflowInstanceR win SWIEditR
         | otherwise -> SchoolWorkflowInstanceListR
+    SWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
   SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR
   SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of
     SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR
@@ -428,6 +429,7 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
     i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
       | mayEdit -> GlobalWorkflowInstanceR win GWIEditR
       | otherwise -> GlobalWorkflowInstanceListR
+  GWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just $ GlobalWorkflowInstanceR win GWIEditR
 breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
 breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
   GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR

src/Handler/Utils/Workflow/CanonicalRoute.hs

@@ -16,7 +16,7 @@ data WorkflowScopeRoute
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data WorkflowInstanceR
-  = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR
+  = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR | WIUpdateR
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data WorkflowWorkflowR
@@ -36,6 +36,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
           WIDeleteR    -> GWIDeleteR
           WIWorkflowsR -> GWIWorkflowsR
           WIInitiateR  -> GWIInitiateR
+          WIUpdateR    -> GWIUpdateR
         WorkflowWorkflowListR            -> GlobalWorkflowWorkflowListR
         WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of
           WWWorkflowR        -> GWWWorkflowR
@@ -50,6 +51,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
           WIDeleteR    -> SWIDeleteR
           WIWorkflowsR -> SWIWorkflowsR
           WIInitiateR  -> SWIInitiateR
+          WIUpdateR    -> SWIUpdateR
         WorkflowWorkflowListR            -> SchoolWorkflowWorkflowListR
         WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of
           WWWorkflowR        -> SWWWorkflowR
@@ -65,6 +67,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
         GWIDeleteR    -> WIDeleteR
         GWIWorkflowsR -> WIWorkflowsR
         GWIInitiateR  -> WIInitiateR
+        GWIUpdateR    -> WIUpdateR
       GlobalWorkflowWorkflowListR            -> Just ( WSGlobal, WorkflowWorkflowListR )
       GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of
         GWWWorkflowR        -> WWWorkflowR
@@ -79,6 +82,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
           SWIDeleteR    -> WIDeleteR
           SWIWorkflowsR -> WIWorkflowsR
           SWIInitiateR  -> WIInitiateR
+          SWIUpdateR    -> WIUpdateR
         SchoolWorkflowWorkflowListR            -> Just ( WSSchool ssh, WorkflowWorkflowListR )
         SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of
           SWWWorkflowR        -> WWWorkflowR

src/Handler/Workflow/Instance.hs

@@ -7,3 +7,4 @@ import Handler.Workflow.Instance.New as Handler.Workflow.Instance
 import Handler.Workflow.Instance.Edit as Handler.Workflow.Instance
 import Handler.Workflow.Instance.Delete as Handler.Workflow.Instance
 import Handler.Workflow.Instance.Initiate as Handler.Workflow.Instance
+import Handler.Workflow.Instance.Update as Handler.Workflow.Instance

src/Handler/Workflow/Instance/List.hs

@@ -13,6 +13,7 @@ import Import
 import Handler.Utils
 import Utils.Workflow
 import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Workflow.Instance.Update
 
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
@@ -151,10 +152,12 @@ workflowInstanceListR rScope = do
       mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
       mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
       mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
-      guard $ mayInitiate || mayEdit || mayList
+      mayUpdate <- lift  . hasWriteAccessTo $ toUpdateRoute workflowInstanceName
-      return (wi, desc)
+      guard $ mayInitiate || mayEdit || mayList || mayUpdate
+      canUpdate <- lift $ workflowInstanceCanUpdate wiId
+      return (wi, desc, canUpdate)
 
-    return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc)
+    return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc, _)
       -> ( NTop workflowInstanceCategory
          , workflowInstanceDescriptionTitle <$> mDesc
          , workflowInstanceName
@@ -168,11 +171,19 @@ workflowInstanceListR rScope = do
   siteLayoutMsg heading $ do
     setTitleI title
     let mPitch = Just $(i18nWidgetFile "workflow-instance-list-explanation")
+        updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
+          (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
+          lift $ wrapForm updateWdgt def
+            { formAction = Just . SomeRoute $ toUpdateRoute win
+            , formEncoding = updateEnctype
+            , formSubmit = FormNoSubmit
+            }
     $(widgetFile "workflows/instances")
   where
     toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
     toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
     toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
+    toUpdateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)
 
 getTopWorkflowInstanceListR :: Handler Html
 getTopWorkflowInstanceListR = do
@@ -192,10 +203,12 @@ getTopWorkflowInstanceListR = do
       mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
       mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
       mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
-      guard $ mayInitiate || mayEdit || mayList
+      mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute' rScope workflowInstanceName
-      return (rScope, [(wi, desc)])
+      guard $ mayInitiate || mayEdit || mayList || mayUpdate
+      canUpdate <- lift $ workflowInstanceCanUpdate wiId
+      return (rScope, [(wi, desc, canUpdate)])
 
-    let iSortProj (Entity _ WorkflowInstance{..}, mDesc)
+    let iSortProj (Entity _ WorkflowInstance{..}, mDesc, _)
           = ( NTop workflowInstanceCategory
             , workflowInstanceDescriptionTitle <$> mDesc
             , workflowInstanceName
@@ -209,8 +222,16 @@ getTopWorkflowInstanceListR = do
             toInitiateRoute = toInitiateRoute' rScope
             toEditRoute = toEditRoute' rScope
             toListRoute = toListRoute' rScope
+            toUpdateRoute = toUpdateRoute' rScope
             mPitch :: Maybe Widget
             mPitch = Nothing
+            updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
+              (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
+              lift $ wrapForm updateWdgt def
+                { formAction = Just . SomeRoute $ toUpdateRoute win
+                , formEncoding = updateEnctype
+                , formSubmit = FormNoSubmit
+                }
         showHeadings = Map.keys gInstances /= [WSGlobal]
         pitch = $(i18nWidgetFile "workflow-instance-list-explanation")
 
@@ -220,3 +241,4 @@ getTopWorkflowInstanceListR = do
     toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
     toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
     toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
+    toUpdateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)

src/Handler/Workflow/Instance/Update.hs

@@ -0,0 +1,117 @@
+module Handler.Workflow.Instance.Update
+  ( WorkflowInstanceUpdateButton(..)
+  , workflowInstanceCanUpdate
+  , postGWIUpdateR, postSWIUpdateR
+  ) where
+
+import Import
+import Utils.Form
+import Utils.Workflow
+
+import Handler.Utils.Workflow.CanonicalRoute
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
+
+
+data WorkflowInstanceUpdateButton
+  = BtnWorkflowInstanceUpdate
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''WorkflowInstanceUpdateButton $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''WorkflowInstanceUpdateButton id
+
+instance Button UniWorX WorkflowInstanceUpdateButton where
+  btnClasses _ = [BCIsButton]
+
+
+data WorkflowInstanceUpdateAction
+  = WIUpdateGraph SharedWorkflowGraphId
+  | WIUpdateCategory (Maybe WorkflowInstanceCategory)
+  | WIUpdateInstanceDescription Lang (Maybe (Text, Maybe StoredMarkup))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
+workflowInstanceUpdates :: WorkflowInstanceId
+                        -> DB (Set WorkflowInstanceUpdateAction)
+workflowInstanceUpdates wiId = execWriterT . maybeT_ $ do
+  WorkflowInstance{..} <- MaybeT . lift $ get wiId
+  wdId <- hoistMaybe workflowInstanceDefinition
+  WorkflowDefinition{..} <- MaybeT . lift $ get wdId
+
+  when (workflowDefinitionGraph /= workflowInstanceGraph) $
+    tellPoint $ WIUpdateGraph workflowDefinitionGraph
+
+  when (workflowDefinitionInstanceCategory /= workflowInstanceCategory) $
+    tellPoint $ WIUpdateCategory workflowDefinitionInstanceCategory
+
+  iDescs <- lift . lift $ selectList [WorkflowInstanceDescriptionInstance ==. wiId] []
+  dDescs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] []
+
+  let iDescs' = Map.fromList $ map (\(Entity _ WorkflowInstanceDescription{..}) -> (CI.mk workflowInstanceDescriptionLanguage, (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription))) iDescs
+      dDescs' = Map.fromList $ map (\(Entity _ WorkflowDefinitionInstanceDescription{..}) -> (CI.mk workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))) dDescs
+
+  forM_ (Map.keysSet iDescs' `Set.union` Map.keysSet dDescs') $ \lang -> if
+    | Just iDesc <- Map.lookup lang iDescs'
+    , Just dDesc <- Map.lookup lang dDescs'
+    , iDesc /= dDesc
+      -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
+    | Just dDesc <- Map.lookup lang dDescs'
+    , not $ Map.member lang iDescs'
+      -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
+    | Map.member lang iDescs'
+    , not $ Map.member lang dDescs'
+      -> tellPoint $ WIUpdateInstanceDescription (CI.original lang) Nothing
+    | otherwise
+      -> return ()
+
+workflowInstanceCanUpdate :: WorkflowInstanceId
+                          -> DB Bool
+workflowInstanceCanUpdate wiId = not . null <$> workflowInstanceUpdates wiId
+
+
+postGWIUpdateR :: WorkflowInstanceName -> Handler Void
+postGWIUpdateR = updateR WSGlobal
+
+postSWIUpdateR :: SchoolId -> WorkflowInstanceName -> Handler Void
+postSWIUpdateR ssh = updateR $ WSSchool ssh
+
+
+updateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler a
+updateR rScope win = do
+  runDB $ do
+    scope <- maybeT notFound $ fromRouteWorkflowScope rScope
+    wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope 
+    updates <- workflowInstanceUpdates wiId
+
+    when (null updates) $
+      addMessageI Warning MsgWorkflowInstanceUpdateNoActions
+
+    forM_ updates $ \case
+      WIUpdateGraph graphId -> do
+        update wiId [ WorkflowInstanceGraph =. graphId ]
+        addMessageI Success MsgWorkflowInstanceUpdateUpdatedGraph
+      WIUpdateCategory iCat -> do
+        update wiId [ WorkflowInstanceCategory =. iCat ]
+        addMessageI Success MsgWorkflowInstanceUpdateUpdatedCategory
+      WIUpdateInstanceDescription lang Nothing -> do
+        deleteBy $ UniqueWorkflowInstanceDescription wiId lang
+        addMessageI Success $ MsgWorkflowInstanceUpdateDeletedDescriptionLanguage lang
+      WIUpdateInstanceDescription lang (Just (title, mDesc)) -> do
+        void $ upsertBy
+          (UniqueWorkflowInstanceDescription wiId lang) 
+          WorkflowInstanceDescription
+            { workflowInstanceDescriptionInstance = wiId
+            , workflowInstanceDescriptionLanguage = lang
+            , workflowInstanceDescriptionTitle = title
+            , workflowInstanceDescriptionDescription = mDesc
+            }
+          [ WorkflowInstanceDescriptionTitle =. title
+          , WorkflowInstanceDescriptionDescription =. mDesc
+          ]
+        addMessageI Success $ MsgWorkflowInstanceUpdateUpdatedDescriptionLanguage lang
+        
+  redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )

templates/workflows/instances.hamlet

@@ -4,7 +4,7 @@ $maybe pitch <- mPitch
     ^{pitch}
 <section>
   <ul .workflow-instances>
-    $forall (Entity _ WorkflowInstance{workflowInstanceName}, mDesc) <- instances
+    $forall (Entity _ WorkflowInstance{workflowInstanceName}, mDesc, canUpdate) <- instances
       <li>
         $maybe WorkflowInstanceDescription{workflowInstanceDescriptionTitle} <- mDesc
           <p .workflow-instance--title>
@@ -17,6 +17,8 @@ $maybe pitch <- mPitch
           ^{linkButton mempty (i18n MsgMenuWorkflowInstanceWorkflows) [BCIsButton, BCPrimary] $ SomeRoute $ toListRoute workflowInstanceName}
           ^{linkButton mempty (i18n MsgMenuWorkflowInstanceInitiate) [BCIsButton] $ SomeRoute $ toInitiateRoute workflowInstanceName}
           ^{linkButton mempty (i18n MsgMenuWorkflowInstanceEdit) [BCIsButton] $ SomeRoute $ toEditRoute workflowInstanceName}
+          $if canUpdate
+            ^{updateForm workflowInstanceName}
 
         $maybe desc <- workflowInstanceDescriptionDescription =<< mDesc
           <div .workflow-instance--description>