124 lines
5.2 KiB
Haskell
124 lines
5.2 KiB
Haskell
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
|
|
|
|
import Handler.Utils.Memcached
|
|
|
|
|
|
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
|
|
memcachedByInvalidate (AuthCacheWorkflowInstanceInitiators win rScope) $ Proxy @(Set (WorkflowRole UserId))
|
|
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
|
|
when (isTopWorkflowScope rScope) $
|
|
memcachedByInvalidate NavCacheHaveTopWorkflowInstancesRoles $ Proxy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId))
|
|
|
|
redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
|