93 lines
4.3 KiB
Haskell
93 lines
4.3 KiB
Haskell
module Handler.Workflow.Instance.Initiate
|
|
( getGWIInitiateR, postGWIInitiateR
|
|
, getSWIInitiateR, postSWIInitiateR
|
|
, workflowInstanceInitiateR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Utils.Workflow
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Workflow
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
|
|
getGWIInitiateR, postGWIInitiateR :: WorkflowInstanceName -> Handler Html
|
|
getGWIInitiateR = postGWIInitiateR
|
|
postGWIInitiateR = workflowInstanceInitiateR WSGlobal
|
|
|
|
getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
|
getSWIInitiateR = postSWIInitiateR
|
|
postSWIInitiateR ssh = workflowInstanceInitiateR $ WSSchool ssh
|
|
|
|
workflowInstanceInitiateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
|
workflowInstanceInitiateR rScope win = workflowsDisabledWarning MsgWorkflowInstanceInitiateTitleDisabled MsgWorkflowInstanceInitiateHeadingDisabled $ do
|
|
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), mDesc) <- runDB $ do
|
|
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
|
|
Entity wiId wi@WorkflowInstance{..} <- getBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
|
edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing
|
|
|
|
descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
|
mDesc <- runMaybeT $ do
|
|
langs <- hoistMaybe . nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
|
lang <- selectLanguage langs
|
|
hoistMaybe . preview _head $ do
|
|
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
|
guard $ workflowInstanceDescriptionLanguage == lang
|
|
return desc
|
|
|
|
((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
|
|
|
|
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
|
|
wGraph <- getSharedIdWorkflowGraph workflowInstanceGraph
|
|
workflowWorkflowState <- view _DBWorkflowState <$> followEdge wGraph edgeRes' Nothing
|
|
|
|
wwId <- insert WorkflowWorkflow
|
|
{ workflowWorkflowInstance = Just wiId
|
|
, workflowWorkflowScope = workflowInstanceScope
|
|
, workflowWorkflowGraph = workflowInstanceGraph
|
|
, workflowWorkflowState
|
|
, workflowWorkflowArchived = Nothing -- FIXME: set to now + 2 months if current state is final state
|
|
}
|
|
|
|
return . Just $ do
|
|
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
|
|
memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles rScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
|
|
when (isTopWorkflowScope rScope) $
|
|
memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
|
|
|
|
|
|
addMessageI Success MsgWorkflowInstanceInitiateSuccess
|
|
|
|
cID <- encrypt wwId
|
|
redirectAlternatives $ NonEmpty.fromList
|
|
[ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR )
|
|
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR )
|
|
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
|
|
]
|
|
|
|
return (wi, ((edgeAct, edgeView), edgeEnc), mDesc)
|
|
|
|
sequence_ edgeAct
|
|
|
|
(heading, title) <- case rScope of
|
|
WSGlobal -> return (MsgGlobalWorkflowInstanceInitiateHeading $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgGlobalWorkflowInstanceInitiateTitle)
|
|
WSSchool ssh -> return (MsgSchoolWorkflowInstanceInitiateHeading ssh $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgSchoolWorkflowInstanceInitiateTitle ssh)
|
|
_other -> error "not implemented"
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI title
|
|
let edgeView = wrapForm edgeView' FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
|
, formEncoding = edgeEnc
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
$(widgetFile "workflows/instance-initiate")
|