- #{graph'}
- |]
- where graph' = decodeUtf8 $ Yaml.encode graph
- dbtSorting = mconcat
- [ singletonMap "name" . SortColumn $ views queryWorkflowDefinition (E.^. WorkflowDefinitionName)
- , singletonMap "scope" . SortColumn . views queryWorkflowDefinition $ E.orderByEnum . (E.^. WorkflowDefinitionScope)
- , singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle
- , singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionDescription
- , singletonMap "instance-title" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle
- , singletonMap "instance-description" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionDescription
- , singletonMap "instances" . SortColumn $ view queryWorkflowInstanceCount
- , singletonMap "workflows" . SortColumn $ view queryWorkflowCount
- ]
- dbtFilter = mconcat
- [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
- , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
- , singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
- , singletonMap "instance-title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
- ]
- dbtFilterUI mPrev = mconcat
- [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)
- , prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ WorkflowScope') (fslI MsgWorkflowDefinitionScope)
- , prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowDescriptionTitle)
- , prismAForm (singletonFilter "instance-title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
- ]
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
- dbtParams = def
- dbtIdent :: Text
- dbtIdent = "workflow-definitions"
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
- workflowDefinitionsDBTableValidator = def
- & defaultPagesize PagesizeAll
- & defaultSorting [SortAscBy "scope", SortAscBy "name"]
- in dbTableWidget' workflowDefinitionsDBTableValidator workflowDefinitionsDBTable
-
- siteLayoutMsg MsgWorkflowDefinitionListTitle $ do
- setTitleI MsgWorkflowDefinitionListTitle
-
- definitionsTable
diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs
deleted file mode 100644
index 827986354..000000000
--- a/src/Handler/Workflow/Definition/New.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Handler.Workflow.Definition.New
- ( getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR
- ) where
-
-import Import
-import Handler.Utils
-import Handler.Workflow.Definition.Form
-import Utils.Workflow
-
-
-getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html
-getAdminWorkflowDefinitionNewR = postAdminWorkflowDefinitionNewR
-postAdminWorkflowDefinitionNewR = do
- (((_, newForm), newEncoding), act) <- runDB $ do
- form@((newRes, _), _) <- runFormPost $ workflowDefinitionForm Nothing
-
- act <- formResultMaybe newRes $ \WorkflowDefinitionForm{ .. } -> do
- wdfGraph' <- fromWorkflowGraphForm wdfGraph
- workflowDefinitionGraph <- insertSharedWorkflowGraph wdfGraph'
-
- insRes <- insertUnique WorkflowDefinition
- { workflowDefinitionGraph
- , workflowDefinitionScope = wdfScope
- , workflowDefinitionName = wdfName
- , workflowDefinitionInstanceCategory = wdfInstanceCategory
- }
-
- for_ insRes $ \wdId -> iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) ->
- insert WorkflowDefinitionDescription
- { workflowDefinitionDescriptionDefinition = wdId
- , workflowDefinitionDescriptionLanguage = wddLang
- , workflowDefinitionDescriptionTitle = wddTitle
- , workflowDefinitionDescriptionDescription = wddDesc
- }
- for_ insRes $ \wdId -> iforM_ wdfInstanceDescriptions $ \wddLang (wddTitle, wddDesc) ->
- insert WorkflowDefinitionInstanceDescription
- { workflowDefinitionInstanceDescriptionDefinition = wdId
- , workflowDefinitionInstanceDescriptionLanguage = wddLang
- , workflowDefinitionInstanceDescriptionTitle = wddTitle
- , workflowDefinitionInstanceDescriptionDescription = wddDesc
- }
-
- case insRes of
- Just _ -> return . Just $ do
- addMessageI Success MsgWorkflowDefinitionCreated
- redirect AdminWorkflowDefinitionListR
- Nothing -> return . Just $
- addMessageI Error MsgWorkflowDefinitionCollision
-
- return (form, act)
-
- forM_ act id
-
- let newWidget = wrapForm newForm def
- { formAction = Just $ SomeRoute AdminWorkflowDefinitionNewR
- , formEncoding = newEncoding
- }
-
- siteLayoutMsg MsgWorkflowDefinitionNewTitle $ do
- setTitleI MsgWorkflowDefinitionNewTitle
-
- newWidget
diff --git a/src/Handler/Workflow/Instance.hs b/src/Handler/Workflow/Instance.hs
deleted file mode 100644
index 4c9e1c883..000000000
--- a/src/Handler/Workflow/Instance.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Handler.Workflow.Instance
- ( module Handler.Workflow.Instance
- ) where
-
-import Handler.Workflow.Instance.List as Handler.Workflow.Instance
-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
diff --git a/src/Handler/Workflow/Instance/Delete.hs b/src/Handler/Workflow/Instance/Delete.hs
deleted file mode 100644
index e674b0709..000000000
--- a/src/Handler/Workflow/Instance/Delete.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Handler.Workflow.Instance.Delete
- ( getGWIDeleteR, postGWIDeleteR
- , getSWIDeleteR, postSWIDeleteR
- , workflowInstanceDeleteR
- ) where
-
-import Import
-
-import Utils.Workflow
-
-
-getGWIDeleteR, postGWIDeleteR :: WorkflowInstanceName -> Handler Html
-getGWIDeleteR = postGWIDeleteR
-postGWIDeleteR = workflowInstanceDeleteR WSGlobal
-
-getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html
-getSWIDeleteR = postSWIDeleteR
-postSWIDeleteR ssh = workflowInstanceDeleteR $ WSSchool ssh
-
-workflowInstanceDeleteR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceDeleteR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/Edit.hs b/src/Handler/Workflow/Instance/Edit.hs
deleted file mode 100644
index 57e6b0752..000000000
--- a/src/Handler/Workflow/Instance/Edit.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Handler.Workflow.Instance.Edit
- ( getGWIEditR, postGWIEditR
- , getSWIEditR, postSWIEditR
- , workflowInstanceEditR
- , getAWIEditR, postAWIEditR
- ) where
-
-import Import
-
-import Utils.Workflow
-
-
-getGWIEditR, postGWIEditR :: WorkflowInstanceName -> Handler Html
-getGWIEditR = postGWIEditR
-postGWIEditR = workflowInstanceEditR WSGlobal
-
-getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html
-getSWIEditR = postSWIEditR
-postSWIEditR ssh = workflowInstanceEditR $ WSSchool ssh
-
-workflowInstanceEditR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceEditR = error "not implemented"
-
-
-getAWIEditR, postAWIEditR :: CryptoUUIDWorkflowInstance -> Handler Html
-getAWIEditR = postAWIEditR
-postAWIEditR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs
deleted file mode 100644
index 41e582a50..000000000
--- a/src/Handler/Workflow/Instance/Form.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module Handler.Workflow.Instance.Form
- ( WorkflowInstanceForm(..), FileIdent
- , workflowInstanceForm
- ) where
-
-import Import
-
-import Handler.Utils
-
-import Handler.Utils.Workflow.Form
-import Utils.Workflow
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-
-workflowInstanceScopeForm :: Maybe WorkflowScope'
- -> FieldSettings UniWorX
- -> Maybe IdWorkflowScope
- -> AForm Handler IdWorkflowScope
-workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ classifyWorkflowScope <$> mPrev
- where
- scopeOptions' = maybe id (flip Map.restrictKeys . Set.singleton) scopeRestr scopeOptions
- scopeOptions = Map.fromList
- [ ( WSGlobal'
- , pure WSGlobal
- )
- , ( WSTerm'
- , WSTerm <$> apopt termField (fslI MsgTableTerm) (mPrev ^? _Just . _wisTerm)
- )
- , ( WSSchool'
- , WSSchool <$> apopt schoolField (fslI MsgTableSchool) (mPrev ^? _Just . _wisSchool)
- )
- , ( WSTermSchool'
- , WSTermSchool <$> apopt termField (fslI MsgTableTerm) (mPrev ^? _Just . _wisTerm)
- <*> apopt schoolField (fslI MsgTableSchool) (mPrev ^? _Just . _wisSchool)
- )
- , ( WSCourse'
- , WSCourse <$> apopt (selectField' Nothing courseOptions) (fslI MsgTableCourse) (mPrev ^? _Just . _wisCourse)
- )
- ]
- where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName
-
-
-data WorkflowInstanceForm = WorkflowInstanceForm
- { wifScope :: IdWorkflowScope
- , wifName :: WorkflowInstanceName
- , wifCategory :: Maybe WorkflowInstanceCategory
- , wifDescriptions :: Map Lang (Text, Maybe StoredMarkup)
- , wifGraph :: WorkflowGraphForm
- } deriving (Generic, Typeable)
-
-makeLenses_ ''WorkflowInstanceForm
-
-workflowInstanceForm :: Maybe WorkflowDefinitionId
- -> Maybe WorkflowInstanceForm
- -> Html
- -> MForm DB (FormResult WorkflowInstanceForm, Widget)
-workflowInstanceForm forcedDefId template = renderWForm FormStandard $ do
- defEnt <- for forcedDefId $ lift . lift . getJustEntity
- defDescs <- for defEnt $ \(Entity dId _) -> do
- descs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. dId] []
- return $ Map.fromList
- [ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
- | Entity _ WorkflowDefinitionInstanceDescription{..} <- descs
- ]
- defGraph <- for defEnt $ toWorkflowGraphForm <=< lift . lift . getSharedDBWorkflowGraph . workflowDefinitionGraph . entityVal
-
- wifScopeRes <- aFormToWForm . hoistAForm lift $ workflowInstanceScopeForm (workflowDefinitionScope . entityVal <$> defEnt) (fslI MsgWorkflowScope) (wifScope <$> template)
- wifNameRes <- wreq ciField (fslI MsgWorkflowInstanceName) (fmap wifName template <|> fmap (workflowDefinitionName . entityVal) defEnt)
- wifCategoryRes <- wopt ciField (fslI MsgWorkflowInstanceCategory) (fmap wifCategory template <|> fmap (workflowDefinitionInstanceCategory . entityVal) defEnt)
- wifDescriptions <- aFormToWForm . hoistAForm lift $ workflowDescriptionsForm WorkflowDescriptionsFormDefinition (fmap wifDescriptions template <|> defDescs)
- wifGraphRes <- aFormToWForm $ workflowGraphForm ((template ^? _Just . _wifGraph) <|> defGraph)
-
- return $ WorkflowInstanceForm
- <$> wifScopeRes
- <*> wifNameRes
- <*> wifCategoryRes
- <*> wifDescriptions
- <*> wifGraphRes
diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs
deleted file mode 100644
index d0046ae91..000000000
--- a/src/Handler/Workflow/Instance/Initiate.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-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
- }
-
- 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")
diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs
deleted file mode 100644
index e2515faf5..000000000
--- a/src/Handler/Workflow/Instance/List.hs
+++ /dev/null
@@ -1,247 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-
-module Handler.Workflow.Instance.List
- ( getAdminWorkflowInstanceListR
- , getGlobalWorkflowInstanceListR
- , getSchoolWorkflowInstanceListR
- , workflowInstanceListR
- , getTopWorkflowInstanceListR
- ) where
-
-import Import
-
-import Handler.Utils
-import Utils.Workflow
-import Handler.Utils.Workflow
-import Handler.Workflow.Instance.Update
-
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-
-import qualified Data.CaseInsensitive as CI
-
-import qualified Data.List.NonEmpty as NonEmpty
-
-import qualified Data.Map as Map
-
-
-type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance)
-
-queryWorkflowInstance :: Equality' WorkflowInstanceTableExpr (E.SqlExpr (Entity WorkflowInstance))
-queryWorkflowInstance = id
-
-queryWorkflowCount :: Getter WorkflowInstanceTableExpr (E.SqlExpr (E.Value Int64))
-queryWorkflowCount = to $ \(view queryWorkflowInstance -> workflowInstance) ->
- E.subSelectCount . E.from $ \workflow ->
- E.where_ $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
-
-
-type WorkflowInstanceData = DBRow
- ( Entity WorkflowInstance
- , Maybe (Entity WorkflowInstanceDescription)
- , Int64
- )
-
-resultWorkflowInstance :: Lens' WorkflowInstanceData (Entity WorkflowInstance)
-resultWorkflowInstance = _dbrOutput . _1
-
-resultDescription :: Traversal' WorkflowInstanceData (Entity WorkflowInstanceDescription)
-resultDescription = _dbrOutput . _2 . _Just
-
-resultWorkflowCount :: Lens' WorkflowInstanceData Int64
-resultWorkflowCount = _dbrOutput . _3
-
-
-getAdminWorkflowInstanceListR :: Handler Html
-getAdminWorkflowInstanceListR = do
- instancesTable <- runDB $ do
- scopeOptions <- do
- scopes <- fmap (map $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
- return $ workflowInstance E.^. WorkflowInstanceScope
- fmap mkOptionList . for scopes $ \scope -> do
- eScope <- traverseOf _wisCourse encrypt scope :: DB CryptoIDWorkflowScope
- wScope <- maybeT notFound $ toRouteWorkflowScope scope
- MsgRenderer mr <- getMsgRenderer
- return Option
- { optionDisplay = mr wScope
- , optionInternalValue = scope
- , optionExternalValue = toPathPiece eScope
- }
-
- let workflowInstancesDBTable = DBTable{..}
- where
- dbtSQLQuery = runReaderT $ do
- workflowInstance <- view queryWorkflowInstance
- workflowCount <- view queryWorkflowCount
-
- return (workflowInstance, workflowCount)
- dbtRowKey = (E.^. WorkflowInstanceId)
- dbtProj = dbtProjFilteredPostSimple $ \(wi@(Entity wiId _), E.Value iCount) ->
- (wi, , iCount) <$> selectWorkflowInstanceDescription wiId
- dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
- dbtColonnade = mconcat
- [ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n
- , sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope . re _DBWorkflowScope) $
- sqlCell . maybeT (return mempty) . fmap i18n . toRouteWorkflowScope
- , sortable (Just "title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty i18nCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionTitle)
- , sortable (Just "workflows") (i18nCell MsgWorkflowInstanceWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
- , sortable (Just "description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionDescription . _Just)
- ]
- where
- anchorEdit :: (WorkflowInstanceData -> Widget) -> _
- anchorEdit f x@(view $ resultWorkflowInstance . _entityKey -> wiId) = anchorCellM mkLink $ f x
- where mkLink = do
- cID <- encrypt wiId
- return $ AdminWorkflowInstanceR cID AWIEditR
- dbtSorting = mconcat
- [ singletonMap "name" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceName)
- , singletonMap "scope" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceScope)
- , singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle
- , singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionDescription
- , singletonMap "workflows" . SortColumn $ view queryWorkflowCount
- ]
- dbtFilter = mconcat
- [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName)
- , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope)
- , singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
- ]
- dbtFilterUI mPrev = mconcat
- [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName)
- , prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return scopeOptions) (fslI MsgWorkflowScope)
- , prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
- ]
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
- dbtParams = def
- dbtIdent :: Text
- dbtIdent = "workflow-instances"
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
- workflowInstancesDBTableValidator = def
- & defaultSorting [SortAscBy "scope", SortAscBy "name"]
- in dbTableDB' workflowInstancesDBTableValidator workflowInstancesDBTable
-
- siteLayoutMsg MsgWorkflowInstanceListTitle $ do
- setTitleI MsgWorkflowInstanceListTitle
-
- instancesTable
-
-
-getGlobalWorkflowInstanceListR :: Handler Html
-getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
-
-getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
-getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
-
-
-workflowInstanceListR :: RouteWorkflowScope -> Handler Html
-workflowInstanceListR rScope = workflowsDisabledWarning title heading $ do
- instances <- runDB $ do
- dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope
-
- wis <- selectList [ WorkflowInstanceScope ==. dbScope ] []
- wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
- descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
- desc <- lift . runMaybeT $ do
- langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
- lang <- selectLanguage langs
- hoistMaybe . preview _head $ do
- Entity _ desc@WorkflowInstanceDescription{..} <- descs
- guard $ workflowInstanceDescriptionLanguage == lang
- return desc
- mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
- mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
- mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
- mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute workflowInstanceName
- guard $ mayInitiate || mayEdit || mayList || mayUpdate
- canUpdate <- lift $ workflowInstanceCanUpdate wiId
- return (wi, desc, canUpdate)
-
- return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc, _)
- -> ( NTop workflowInstanceCategory
- , workflowInstanceDescriptionTitle <$> mDesc
- , workflowInstanceName
- )
-
- 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)
-
- (heading, title) = case rScope of
- WSGlobal -> (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
- WSSchool ssh -> (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
- _other -> error "not implemented"
-
-
-getTopWorkflowInstanceListR :: Handler Html
-getTopWorkflowInstanceListR = workflowsDisabledWarning title heading $ do
- gInstances <- runDB $ do
- wis <- selectList [] []
- wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
- guard $ isTopWorkflowScope workflowInstanceScope
- rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
- descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
- desc <- lift . runMaybeT $ do
- langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
- lang <- selectLanguage langs
- hoistMaybe . preview _head $ do
- Entity _ desc@WorkflowInstanceDescription{..} <- descs
- guard $ workflowInstanceDescriptionLanguage == lang
- return desc
- mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
- mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
- mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
- mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute' rScope workflowInstanceName
- guard $ mayInitiate || mayEdit || mayList || mayUpdate
- canUpdate <- lift $ workflowInstanceCanUpdate wiId
- return (rScope, [(wi, desc, canUpdate)])
-
- let iSortProj (Entity _ WorkflowInstance{..}, mDesc, _)
- = ( NTop workflowInstanceCategory
- , workflowInstanceDescriptionTitle <$> mDesc
- , workflowInstanceName
- )
- return $ sortOn iSortProj <$> Map.fromListWith (<>) wis'
-
- siteLayoutMsg heading $ do
- setTitleI title
- let instanceList rScope instances = $(widgetFile "workflows/instances")
- where
- 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")
-
- $(widgetFile "workflows/top-instances")
-
- where
- 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)
-
- (title, heading) = (MsgTopWorkflowInstancesTitle, MsgTopWorkflowInstancesHeading)
diff --git a/src/Handler/Workflow/Instance/New.hs b/src/Handler/Workflow/Instance/New.hs
deleted file mode 100644
index e715c62ba..000000000
--- a/src/Handler/Workflow/Instance/New.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-module Handler.Workflow.Instance.New
- ( getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR
- , adminWorkflowInstanceNewR
- , getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR
- , getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR
- , workflowInstanceNewR
- ) where
-
-import Import
-import Handler.Utils
-import Handler.Utils.Workflow.Form
-import Utils.Workflow
-
-import Handler.Workflow.Instance.Form
-
-getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR :: Handler Html
-getAdminWorkflowInstanceNewR = postAdminWorkflowInstanceNewR
-postAdminWorkflowInstanceNewR = adminWorkflowInstanceNewR Nothing
-
-adminWorkflowInstanceNewR :: Maybe WorkflowDefinitionId -> Handler Html
-adminWorkflowInstanceNewR wdId = do
- cRoute <- getCurrentRoute
- (((_, instForm), instEncoding), act) <- runDB $ do
- form@((instRes, _), _) <- runFormPost $ workflowInstanceForm wdId Nothing
-
- act <- formResultMaybe instRes $ \WorkflowInstanceForm{..} -> do
- wifGraph' <- fromWorkflowGraphForm wifGraph
- workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
- let wifScope' = wifScope
- & over _wisTerm unTermKey
- & over _wisSchool unSchoolKey
- & over _wisCourse (view _SqlKey)
- instId <- insertUnique WorkflowInstance
- { workflowInstanceDefinition = wdId
- , workflowInstanceGraph
- , workflowInstanceScope = wifScope'
- , workflowInstanceName = wifName
- , workflowInstanceCategory = wifCategory
- }
-
- for_ instId $ \instId' -> iforM_ wifDescriptions $ \widLang (widTitle, widDesc) ->
- insert WorkflowInstanceDescription
- { workflowInstanceDescriptionInstance = instId'
- , workflowInstanceDescriptionLanguage = widLang
- , workflowInstanceDescriptionTitle = widTitle
- , workflowInstanceDescriptionDescription = widDesc
- }
-
- return . Just $ case instId of
- Nothing -> addMessageI Error MsgWorkflowInstanceCollision
- Just _
- | is _Just wdId -> do
- addMessageI Success MsgWorkflowDefinitionInstantiated
- redirect AdminWorkflowInstanceListR
- | otherwise -> do
- addMessageI Success MsgWorkflowInstanceCreated
- redirect AdminWorkflowInstanceListR
-
- return (form, act)
-
- forM_ act id
-
- let instWidget = wrapForm instForm def
- { formAction = SomeRoute <$> cRoute
- , formEncoding = instEncoding
- }
-
- siteLayoutMsg MsgWorkflowDefinitionInstantiateTitle $ do
- setTitleI MsgWorkflowDefinitionInstantiateTitle
-
- instWidget
-
-
-getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR :: Handler Html
-getGlobalWorkflowInstanceNewR = postGlobalWorkflowInstanceNewR
-postGlobalWorkflowInstanceNewR = workflowInstanceNewR WSGlobal
-
-getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR :: SchoolId -> Handler Html
-getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR
-postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool
-
-workflowInstanceNewR :: RouteWorkflowScope -> Handler Html
-workflowInstanceNewR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/Update.hs b/src/Handler/Workflow/Instance/Update.hs
deleted file mode 100644
index 5453fba79..000000000
--- a/src/Handler/Workflow/Instance/Update.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-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 )
diff --git a/src/Handler/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow.hs
deleted file mode 100644
index d7e669f20..000000000
--- a/src/Handler/Workflow/Workflow.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Handler.Workflow.Workflow
- ( module Handler.Workflow.Workflow
- ) where
-
-import Handler.Workflow.Workflow.List as Handler.Workflow.Workflow
-import Handler.Workflow.Workflow.Workflow as Handler.Workflow.Workflow
-import Handler.Workflow.Workflow.Edit as Handler.Workflow.Workflow
-import Handler.Workflow.Workflow.Delete as Handler.Workflow.Workflow
-import Handler.Workflow.Workflow.New as Handler.Workflow.Workflow
diff --git a/src/Handler/Workflow/Workflow/Delete.hs b/src/Handler/Workflow/Workflow/Delete.hs
deleted file mode 100644
index 315b7a2ef..000000000
--- a/src/Handler/Workflow/Workflow/Delete.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Handler.Workflow.Workflow.Delete
- ( getGWWDeleteR, postGWWDeleteR
- , getSWWDeleteR, postSWWDeleteR
- , workflowDeleteR
- ) where
-
-import Import
-
-import Utils.Workflow
-
-
-getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html
-getGWWDeleteR = postGWWDeleteR
-postGWWDeleteR = workflowDeleteR WSGlobal
-
-getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
-getSWWDeleteR = postSWWDeleteR
-postSWWDeleteR ssh = workflowDeleteR $ WSSchool ssh
-
-workflowDeleteR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
-workflowDeleteR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/Edit.hs b/src/Handler/Workflow/Workflow/Edit.hs
deleted file mode 100644
index ea84d7f96..000000000
--- a/src/Handler/Workflow/Workflow/Edit.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Handler.Workflow.Workflow.Edit
- ( getGWWEditR, postGWWEditR
- , getSWWEditR, postSWWEditR
- , workflowEditR
- ) where
-
-import Import
-
-import Utils.Workflow
-
-
-getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html
-getGWWEditR = postGWWEditR
-postGWWEditR = workflowEditR WSGlobal
-
-getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
-getSWWEditR = postSWWEditR
-postSWWEditR ssh = workflowEditR $ WSSchool ssh
-
-workflowEditR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
-workflowEditR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs
deleted file mode 100644
index a884afb36..000000000
--- a/src/Handler/Workflow/Workflow/List.hs
+++ /dev/null
@@ -1,527 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-
-module Handler.Workflow.Workflow.List
- ( getGlobalWorkflowWorkflowListR
- , getSchoolWorkflowWorkflowListR
- , workflowWorkflowListR
- , getGWIWorkflowsR
- , getSWIWorkflowsR
- , workflowInstanceWorkflowsR
- , getAdminWorkflowWorkflowListR
- , getTopWorkflowWorkflowListR
- ) where
-
-import Import hiding (Last(..), WriterT)
-
-import Utils.Workflow
-import Handler.Utils.Workflow
-
-import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor)
-
-import qualified Database.Esqueleto.Legacy 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
-
-import qualified Data.Conduit.Combinators as C
-
-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 qualified Data.RFC5051 as RFC5051
-
-
-data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj
- { wwProjFilterMayAccess :: Maybe Bool
- , wwProjFilterWorkflowWorkflow :: Maybe [[CI Char]]
- , wwProjFilterCurrentState :: Maybe [[CI Char]]
- , wwProjFilterFinal :: Maybe Bool
- }
-
-instance Default WorkflowWorkflowListFilterProj where
- def = WorkflowWorkflowListFilterProj
- { wwProjFilterMayAccess = Nothing
- , wwProjFilterWorkflowWorkflow = Nothing
- , wwProjFilterCurrentState = Nothing
- , wwProjFilterFinal = Nothing
- }
-
-makeLenses_ ''WorkflowWorkflowListFilterProj
-
-
-getGlobalWorkflowWorkflowListR :: Handler Html
-getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
-
-getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
-getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
-
-workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
-workflowWorkflowListR rScope = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do
- scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
- workflowWorkflowList headings columns . runReader $ do
- workflowWorkflow <- view queryWorkflowWorkflow
- return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
- where
- columns = def
- { wwListColumnScope = False
- }
- headings = (MsgWorkflowWorkflowListScopeTitle rScope, MsgWorkflowWorkflowListScopeHeading rScope)
-
-
-getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
-getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal
-
-getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
-getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
-
-workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope) $ do
- (scope, desc) <- runDB $ do
- scope <- maybeT notFound $ fromRouteWorkflowScope rScope
- wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
- desc <- selectWorkflowInstanceDescription wiId
- return (scope, desc)
- let headings = case desc of
- Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading)
- Just (Entity _ WorkflowInstanceDescription{..})
- -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle
- , MsgWorkflowWorkflowListNamedInstanceHeading 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 headings def $ const E.true
- where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading)
-
-getTopWorkflowWorkflowListR :: Handler Html
-getTopWorkflowWorkflowListR = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
- where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading)
-
-
-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
- , [Entity User]
- )
--- ^ @Maybe `WorkflowWorkflowActionData`@ corresponds to last action
-
-type WorkflowWorkflowActionData = ( Maybe Text
- , UTCTime
- , Maybe WorkflowHistoryItemActor
- , Maybe Icon
- )
-
-data JsonWorkflowWorkflow = JsonWorkflowWorkflow
- { jwwScope :: Maybe RouteWorkflowScope
- , jwwInstance :: Maybe JsonWorkflowInstance
- , jwwLastAction :: Maybe JsonWorkflowAction
- , jwwPayload :: Map WorkflowPayloadLabel JsonWorkflowPayload
- } deriving (Generic)
-
-data JsonWorkflowAction = JsonWorkflowAction
- { jwaIx :: CryptoUUIDWorkflowStateIndex
- , jwaTo :: Maybe WorkflowGraphNodeLabel
- , jwaUser :: Maybe JsonWorkflowUser
- , jwaTime :: UTCTime
- } deriving (Generic)
-
-data JsonWorkflowInstance = JsonWorkflowInstance
- { jwiScope :: RouteWorkflowScope
- , jwiName :: WorkflowInstanceName
- } deriving (Generic)
-
-data JsonWorkflowPayload = JsonWorkflowPayload
- { jwpPayload :: [WorkflowFieldPayloadW Void JsonWorkflowUser]
- , jwpHasFiles :: Bool
- } deriving (Generic)
-
-data JsonWorkflowUser
- = JsonWorkflowUserUser
- { jwuDisplayName :: UserDisplayName
- , jwuMatriculation :: Maybe UserMatriculation
- , jwuDisplayEmail :: UserEmail
- }
- | JsonWorkflowUserAnonymous
- | JsonWorkflowUserHidden
- | JsonWorkflowUserGone
- deriving (Generic)
-
-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
-
-resultPersons :: Traversal' WorkflowWorkflowData (Entity User)
-resultPersons = _dbrOutput . _7 . traverse
-
-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 (title, heading) WWListColumns{..} sqlPred = do
- mAuthId <- maybeAuthId
-
- workflowTable <- runDB $
- let
- workflowWorkflowDBTable = DBTable{..}
- where
- dbtSQLQuery = runReaderT $ do
- workflowWorkflow <- view queryWorkflowWorkflow
- workflowInstance <- view queryWorkflowInstance
- lift . E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. workflowInstance E.?. WorkflowInstanceId
- lift <=< asks $ E.where_ . sqlPred
- return (workflowWorkflow, workflowInstance)
- dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
- ww@(Entity wwId WorkflowWorkflow{..}) <- view $ _dbtProjRow . _dbrOutput . _1
- mwi <- view $ _dbtProjRow . _dbrOutput . _2
-
- cID <- encrypt wwId
- forMM_ (view $ _dbtProjFilter . _wwProjFilterWorkflowWorkflow) $ \criteria ->
- let haystack = map CI.mk . unpack $ toPathPiece cID
- in guard $ any (`isInfixOf` haystack) criteria
-
- rScope <- lift . lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
- forMM_ (view $ _dbtProjFilter . _wwProjFilterMayAccess) $ \needle -> do
- rScope' <- hoistMaybe rScope
- guardM . lift . lift $ (== needle) . is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)) False
-
- wiDesc <- lift . lift . $cachedHereBinary (entityKey <$> mwi) . runMaybeT $ do
- Entity wiId _ <- hoistMaybe mwi
- MaybeT $ selectWorkflowInstanceDescription wiId
- WorkflowGraph{..} <- lift . lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
- let 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 . 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 $ 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 . for wpUser' $ \uid -> $cachedHereBinary uid $ getEntity uid
- 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
-
- 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 . lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) 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
- ]
- where
- 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
-
- 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 $ \(criteria :: Set Text) ->
- let criteria' = map CI.mk . unpack <$> Set.toList criteria
- in _wwProjFilterWorkflowWorkflow ?~ criteria'
- , singletonMap "current-state" . FilterProjected $ \(criteria :: Set Text) -> -- TODO
- let criteria' = map CI.mk . unpack <$> Set.toList criteria
- in _wwProjFilterCurrentState ?~ criteria'
- , singletonMap "final" . FilterProjected $ \(criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of -- TODO
- Nothing -> id
- Just needle -> _wwProjFilterFinal ?~ needle
- , singletonMap "may-access" . FilterProjected $ \(Any criterion) -> _wwProjFilterMayAccess ?~ criterion
- ]
- -- [ 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" . FilterPreProjected $ \(x :: DBRow (Entity WorkflowWorkflow, Maybe (Entity WorkflowInstance))) (Any b) -> fmap (== b) . maybeT (return False) $ do
- -- let Entity wwId WorkflowWorkflow{..} = x ^. _dbrOutput . _1
- -- cID <- encrypt wwId
- -- rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
- -- 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 :: Monoid.Last Bool) -> case Monoid.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
- dbtExtraReps = [ DBTExtraRep $ toPrettyJSON <$> repWorkflowWorkflowJson, DBTExtraRep $ toYAML <$> repWorkflowWorkflowJson ]
-
- repWorkflowWorkflowJson :: ConduitT (E.Value WorkflowWorkflowId, WorkflowWorkflowData) Void DB (Map CryptoFileNameWorkflowWorkflow JsonWorkflowWorkflow)
- repWorkflowWorkflowJson = C.foldMapM $ \(E.Value wwId, res) -> do
- cID <- encrypt wwId
- Map.singleton cID <$> do
- let jwwScope = guardOnM wwListColumnScope $ res ^. resultRouteScope
- jwwInstance <- fmap join . for (guardOnM wwListColumnInstance $ res ^. resultWorkflowInstance) $ \(Entity _ WorkflowInstance{..}) -> runMaybeT $ do
- jwiScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
- let jwiName = workflowInstanceName
- return JsonWorkflowInstance{..}
- let Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
- WorkflowGraph{..} <- getSharedIdWorkflowGraph workflowWorkflowGraph
- (fmap getLast -> wState) <-
- let go :: forall m.
- ( MonadHandler m
- , HandlerSite m ~ UniWorX
- , MonadCatch m
- , MonadUnliftIO m
- )
- => WorkflowActionInfo FileReference UserId
- -> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) ()
- go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT_ $ do
- stCID <- encryptWorkflowStateIndex wwId stIx
-
- rScope <- hoistMaybe $ res ^. resultRouteScope
-
- let toJsonUser (Just (Entity _ User{..})) = JsonWorkflowUserUser
- { jwuDisplayName = userDisplayName
- , jwuMatriculation = userMatrikelnummer
- , jwuDisplayEmail = userDisplayEmail
- }
- toJsonUser Nothing = JsonWorkflowUserGone
-
- 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
- canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-
- aUser <- for wpUser $ \wpUser' -> lift . maybeT (return JsonWorkflowUserHidden) $ do
- viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
- guardM $ anyM (otoList viewActors) hasWorkflowRole'
- resUser <- lift . lift $ traverse getEntity wpUser'
- return $ maybe JsonWorkflowUserAnonymous toJsonUser resUser
-
- payload <- do
- payload' <- fmap Map.fromList . forMaybeM (Map.toList currentPayload) $ \x@(payloadLbl, _) -> x <$ do
- WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
- guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole'
- forM payload' $ \(otoList -> payloads) -> fmap (uncurry JsonWorkflowPayload . over _2 getAny) . execWriterT @_ @(_, Any) . forM_ payloads $ \case
- WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
- WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
- WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
- WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
- WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t)
- WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t)
- WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
- WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . toJsonUser =<< lift (lift . lift $ getEntity uid)
-
- nTo <- runMaybeT $ do
- WGN{..} <- hoistMaybe $ Map.lookup wpTo wgNodes
- WorkflowNodeView{..} <- hoistMaybe wgnViewers
- guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole'
- return wpTo
-
- tell . Just $ Last (stCID, nTo, aUser, wpTime, payload)
-
- wState = review _DBWorkflowState workflowWorkflowState
- in runConduit $ sourceWorkflowActionInfos wwId wState .| execWriterC (C.mapM_ go)
-
- let jwwLastAction = wState <&> \(jwaIx, jwaTo, jwaUser, jwaTime, _) -> JsonWorkflowAction{..}
- jwwPayload = wState ^. _Just . _5
-
- return JsonWorkflowWorkflow{..}
- 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
- $(widgetFile "workflows/workflow-list")
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''JsonWorkflowWorkflow
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''JsonWorkflowAction
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''JsonWorkflowInstance
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''JsonWorkflowPayload
-
-deriveJSON defaultOptions
- { constructorTagModifier = camelToPathPiece' 3
- , fieldLabelModifier = camelToPathPiece' 1
- } ''JsonWorkflowUser
diff --git a/src/Handler/Workflow/Workflow/New.hs b/src/Handler/Workflow/Workflow/New.hs
deleted file mode 100644
index c9d7c1e04..000000000
--- a/src/Handler/Workflow/Workflow/New.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Handler.Workflow.Workflow.New
- ( getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR
- ) where
-
-import Import
-
-
-getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR :: Handler Html
-getAdminWorkflowWorkflowNewR = postAdminWorkflowWorkflowNewR
-postAdminWorkflowWorkflowNewR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs
deleted file mode 100644
index 441fa1d54..000000000
--- a/src/Handler/Workflow/Workflow/Workflow.hs
+++ /dev/null
@@ -1,280 +0,0 @@
-module Handler.Workflow.Workflow.Workflow
- ( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
- , getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
- , workflowR
- , WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor
- ) where
-
-import Import hiding (Last(..), Encoding(None))
-
-import Utils.Form
-import Utils.Workflow
-
-import Data.Semigroup (Last(..))
-
-import Handler.Utils
-import Handler.Utils.Workflow
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Sequence as Seq
-
-import qualified Control.Monad.State.Class as State
-import Control.Monad.Trans.RWS.Strict (RWST)
-
-import qualified Crypto.Saltine.Class as Saltine
-import qualified Data.Binary as Binary
-import qualified Data.ByteArray as BA
-import Crypto.Hash.Algorithms (SHAKE256)
-
-import qualified Data.Text as Text
-import Data.RFC5051 (compareUnicode)
-
-import qualified Data.Scientific as Scientific
-import Text.Blaze (toMarkup)
-import Data.Void (absurd)
-
-import qualified Data.Conduit.Combinators as C
-
-
-data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone
- 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, Maybe Icon)) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
- , whiVia :: Maybe Text
- , whiTo :: Maybe (Text, Maybe Icon)
- } deriving (Generic, Typeable)
-
-data WorkflowCurrentState = WorkflowCurrentState
- { wcsState :: Maybe (Text, Maybe Icon)
- , wcsMessages :: Set Message
- , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
- }
-
-makePrisms ''WorkflowHistoryItemActor'
-
-
-getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
-getGWWWorkflowR = postGWWWorkflowR
-postGWWWorkflowR = workflowR WSGlobal
-
-getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
-getGWWFilesR = getWorkflowFilesR WSGlobal
-
-getSWWWorkflowR, postSWWWorkflowR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
-getSWWWorkflowR = postSWWWorkflowR
-postSWWWorkflowR ssh = workflowR $ WSSchool ssh
-
-getSWWFilesR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
-getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh
-
-
-workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
-workflowR rScope cID = workflowsDisabledWarning title heading $ do
- (mEdge, (workflowState, workflowHistory)) <- runDB $ do
- wwId <- decrypt cID
- WorkflowWorkflow{..} <- get404 wwId
- maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
- mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
- wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
- let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-
- mEdge <- for mEdgeForm $ \edgeForm -> do
- ((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
- edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
- nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
-
- wInstance <- for workflowWorkflowInstance $ \wiId -> do
- wInstance@WorkflowInstance{..} <- get404 wiId
- wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
- return (wiScope, Entity wiId wInstance)
-
- update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
-
- return . Just $ do
- whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do
- memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
- memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles wiScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
- when (isTopWorkflowScope wiScope) $
- memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
- memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
- memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
-
- addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess
-
- redirect canonRoute
- return ((edgeAct, edgeView), edgeEnc)
-
- (fmap getLast -> workflowState, workflowHistory) <-
- let go :: forall m.
- ( MonadHandler m
- , HandlerSite m ~ UniWorX
- , MonadCatch m
- , MonadUnliftIO m
- )
- => WorkflowActionInfo FileReference UserId
- -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
- go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT_ $ do
- mAuthId <- maybeAuthId
-
- stCID <- encryptWorkflowStateIndex wwId stIx
- let nodeView nodeLbl = do
- WGN{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes
- WorkflowNodeView{..} <- hoistMaybe wgnViewers
- guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
- (, 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
-
- whiTo <- lift . runMaybeT $ nodeView wpTo
- let wcsState = whiTo
-
- whiUser <- for wpUser $ \wpUser' -> if
- | is _Just mAuthId
- , wpUser' == mAuthId -> return WHIASelf
- | otherwise -> lift . maybeT (return WHIAHidden) $ do
- viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
- guardM $ anyM (otoList viewActors) hasWorkflowRole'
- resUser <- lift . lift $ traverse getEntity wpUser'
- return $ case resUser of
- Nothing -> WHIAOther Nothing
- Just Nothing -> WHIAGone
- Just (Just uEnt) -> WHIAOther $ Just uEnt
-
- whiVia <- traverse selectLanguageI18n $ preview _wgeDisplayLabel =<< mVia
- whiFrom <- for wpFrom $ lift . runMaybeT . nodeView
-
- let renderPayload payload = do
- sBoxKey <- secretBoxKey
- let payloadLabelToDigest :: WorkflowPayloadLabel -> ByteString
- payloadLabelToDigest = BA.convert . kmaclazy @(SHAKE256 256) ("workflow-workflow-payload-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (wwId, )
- payloadLabelSort = (compareUnicode `on` views (_2 . _1) Text.toLower)
- <> comparing (views _1 payloadLabelToDigest)
- payload' <- fmap (map (view _2) . sortBy payloadLabelSort) . forMaybeM (Map.toList payload) $ \(payloadLbl, newPayload) -> do
- WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
- guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole'
- let fRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID (WWFilesR payloadLbl stCID))
- (payloadLbl, ) . (, (newPayload, fRoute)) <$> selectLanguageI18n wpvDisplayLabel
- let
- payloadSort :: WorkflowFieldPayloadW Void (Maybe (Entity User))
- -> WorkflowFieldPayloadW Void (Maybe (Entity User))
- -> Ordering
- payloadSort = workflowPayloadSort ordFiles ordUsers
- where
- ordFiles = absurd
- ordUsers a' b' = case (a', b') of
- (Nothing, _) -> GT
- (_, Nothing) -> LT
- (Just (Entity _ uA), Just (Entity _ uB))
- -> (compareUnicode `on` userSurname) uA uB
- <> (compareUnicode `on` userDisplayName) uA uB
- <> comparing userIdent uA uB
-
- forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any) . forM_ payloads $ \case
- WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
- WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
- WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
- WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
- WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t)
- WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t)
- WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
- WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
-
- payloadChanges <- State.state $ \oldPayload ->
- ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
- , currentPayload
- )
- whiPayloadChanges <- renderPayload payloadChanges
- wcsPayload <- renderPayload currentPayload
-
- wcsMessages <- do
- let msgs = maybe Set.empty wgnMessages $ Map.lookup wpTo wgNodes
- flip foldMapM msgs $ \WorkflowNodeMessage{..} -> lift . maybeT (return Set.empty) . fmap Set.singleton $ do
- guardM $ anyM (otoList wnmViewers) hasWorkflowRole'
- history' <- hoistMaybe . fromNullable $ Seq.fromList history
- whenIsJust wnmRestriction $ guard . checkWorkflowRestriction (Just history')
- let messageStatus = wnmStatus
- messageIcon = Nothing
- messageContent <- selectLanguageI18n wnmContent
- return Message{..}
-
- tell ( Just $ Last WorkflowCurrentState{..}
- , pure WorkflowHistoryItem{..}
- )
- WorkflowGraph{..} = wGraph
- wState = review _DBWorkflowState workflowWorkflowState
- in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . runConduit $ sourceWorkflowActionInfos wwId wState .| execRWSC () Map.empty (C.mapM_ go)
- return (mEdge, (workflowState, workflowHistory))
-
- sequenceOf_ (_Just . _1 . _1 . _Just) mEdge
-
- let headingWgt
- | Just WorkflowCurrentState{..} <- workflowState
- , Just (_, Just icn) <- wcsState
- = [whamlet|_{heading} #{icon icn}|]
- | otherwise = i18n heading
-
- siteLayout headingWgt $ do
- setTitleI title
- let mEdgeView = mEdge <&> \((_, edgeView'), edgeEnc) -> wrapForm edgeView' FormSettings
- { formMethod = POST
- , formAction = Just . SomeRoute $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
- , formEncoding = edgeEnc
- , formAttrs = []
- , formSubmit = FormSubmit
- , formAnchor = Nothing :: Maybe Text
- }
- historyToWidget WorkflowHistoryItem{..} = $(widgetFile "workflows/workflow/history-item")
- payloadToWidget :: WorkflowFieldPayloadW Void (Maybe (Entity User)) -> Widget
- payloadToWidget = \case
- WorkflowFieldPayloadW (WFPText t )
- -> [whamlet|
- $newline never
-
- #{t}
- |]
- WorkflowFieldPayloadW (WFPNumber n ) -> toWidget . toMarkup $ formatScientific Scientific.Fixed Nothing n
- WorkflowFieldPayloadW (WFPBool b ) -> i18n $ WorkflowPayloadBool b
- WorkflowFieldPayloadW (WFPDay d ) -> formatTimeW SelFormatDate d
- WorkflowFieldPayloadW (WFPTime t ) -> formatTimeW SelFormatTime t
- WorkflowFieldPayloadW (WFPDateTime t ) -> formatTimeW SelFormatDateTime t
- WorkflowFieldPayloadW (WFPUser mUserEnt) -> case mUserEnt of
- Nothing -> i18n MsgWorkflowPayloadUserGone
- Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname
- WorkflowFieldPayloadW (WFPFile v ) -> absurd v
- $(widgetFile "workflows/workflow")
- where
- (heading, title) = case rScope of
- WSGlobal -> (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
- WSSchool ssh -> (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
- _other -> error "not implemented"
-
-getWorkflowFilesR :: RouteWorkflowScope
- -> CryptoFileNameWorkflowWorkflow
- -> WorkflowPayloadLabel
- -> CryptoUUIDWorkflowStateIndex
- -> Handler TypedContent
-getWorkflowFilesR rScope wwCID wpl stCID = do
- fRefs <- runDB $ do
- wwId <- decrypt wwCID
- WorkflowWorkflow{..} <- get404 wwId
- maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
- stIx <- decryptWorkflowStateIndex wwId stCID
- payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
- mAuthId <- maybeAuthId
- payloads' <- fmap (Map.findWithDefault Set.empty wpl . workflowStateCurrentPayloads) . filterM (mayViewWorkflowAction mAuthId wwId) $ otoList payloads
- let
- payloads'' :: [FileReference]
- payloads'' = payloads' ^.. folded . _WorkflowFieldPayloadW . _WorkflowFieldPayload
- when (null payloads'') notFound
- return payloads''
-
- archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgWorkflowWorkflowFilesArchiveName wwCID wpl stCID
-
- serveSomeFiles archiveName $ yieldMany fRefs
diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs
index 7ab592eb1..d304ebd2f 100644
--- a/src/Jobs/Handler/Files.hs
+++ b/src/Jobs/Handler/Files.hs
@@ -34,7 +34,6 @@ import Control.Monad.Logger (askLoggerIO, runLoggingT)
import System.Clock
import qualified Data.Set as Set
-import qualified Data.Sequence as Seq
import Jobs.Handler.Intervals.Utils
@@ -77,12 +76,6 @@ fileReferences fHash'@(E.just -> fHash)
E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. chunkLock E.^. FileChunkLockHash
]
-workflowFileReferences :: MonadResource m => Map Text (ConduitT () FileContentReference (SqlPersistT m) ())
-workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece
- [ (''SharedWorkflowGraph, E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
- , (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
- ]
-
dispatchJobDetectMissingFiles :: JobHandler UniWorX
dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
@@ -103,9 +96,6 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
E.distinctOnOrderBy [E.asc ref] $ return ref
transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind)
- iforM_ workflowFileReferences $ \refKind refSource ->
- transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
-
let allMissingDb :: Set Minio.Object
allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
filterMissingDb :: forall m. Monad m
@@ -203,15 +193,6 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
E.where_ $ chunkIdFilter unreferencedChunkHash
-
- let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
- let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
- E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
- E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
- return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
- E.where_ $ chunkIdFilter unreferencedChunkHash
- chunkSize = 100
- in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles
let
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 78ac1db9e..bc779af34 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -47,7 +47,6 @@ import Data.Time.Format
import qualified Data.Time.Zones as TZ
-import Utils.Workflow
data ManualMigration
@@ -99,7 +98,6 @@ data ManualMigration
| Migration20201106StoredMarkup
| Migration20201119RoomTypes
| Migration20210115ExamPartsFrom
- | Migration20210201SharedWorkflowGraphs
| Migration20210208StudyFeaturesRelevanceCachedUUIDs
| Migration20210318CrontabSubmissionRatedNotification
| Migration20210608SeparateTermActive
@@ -981,55 +979,6 @@ customMigrations = mapF $ \case
migrateExam _ = return ()
in runConduit $ getExam .| C.mapM_ migrateExam
- Migration20210201SharedWorkflowGraphs -> do
- unlessM (tableExists "shared_workflow_graph")
- [executeQQ|CREATE TABLE "shared_workflow_graph" ("hash" bytea primary key, "graph" jsonb not null)|]
-
- whenM (tableExists "workflow_definition") $ do
- [executeQQ|ALTER TABLE "workflow_definition" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
- let getDefinitions = [queryQQ|SELECT "id", "graph" FROM "workflow_definition"|]
- migrateDefinition [ fromPersistValue -> Right (wdId :: WorkflowDefinitionId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
- swgId <- insertSharedWorkflowGraph graph
- [executeQQ|UPDATE "workflow_definition" SET "graph_id" = #{swgId} WHERE "id" = #{wdId}|]
- migrateDefinition _ = return ()
- in runConduit $ getDefinitions .| C.mapM_ migrateDefinition
-
- [executeQQ|
- ALTER TABLE "workflow_definition" DROP COLUMN "graph";
- ALTER TABLE "workflow_definition" ALTER COLUMN "graph_id" SET not null;
- ALTER TABLE "workflow_definition" RENAME COLUMN "graph_id" TO "graph";
- |]
-
- whenM (tableExists "workflow_instance") $ do
- [executeQQ|ALTER TABLE "workflow_instance" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
- let getInstances = [queryQQ|SELECT "id", "graph" FROM "workflow_instance"|]
- migrateInstance [ fromPersistValue -> Right (wiId :: WorkflowInstanceId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
- swgId <- insertSharedWorkflowGraph graph
- [executeQQ|UPDATE "workflow_instance" SET "graph_id" = #{swgId} WHERE "id" = #{wiId}|]
- migrateInstance _ = return ()
- in runConduit $ getInstances .| C.mapM_ migrateInstance
-
- [executeQQ|
- ALTER TABLE "workflow_instance" DROP COLUMN "graph";
- ALTER TABLE "workflow_instance" ALTER COLUMN "graph_id" SET not null;
- ALTER TABLE "workflow_instance" RENAME COLUMN "graph_id" TO "graph";
- |]
-
- whenM (tableExists "workflow_workflow") $ do
- [executeQQ|ALTER TABLE "workflow_workflow" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
- let getWorkflows = [queryQQ|SELECT "id", "graph" FROM "workflow_workflow"|]
- migrateWorkflow [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
- swgId <- insertSharedWorkflowGraph graph
- [executeQQ|UPDATE "workflow_workflow" SET "graph_id" = #{swgId} WHERE "id" = #{wwId}|]
- migrateWorkflow _ = return ()
- in runConduit $ getWorkflows .| C.mapM_ migrateWorkflow
-
- [executeQQ|
- ALTER TABLE "workflow_workflow" DROP COLUMN "graph";
- ALTER TABLE "workflow_workflow" ALTER COLUMN "graph_id" SET not null;
- ALTER TABLE "workflow_workflow" RENAME COLUMN "graph_id" TO "graph";
- |]
-
Migration20210208StudyFeaturesRelevanceCachedUUIDs ->
whenM (tableExists "study_features") $ do
[executeQQ|
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 5b5562675..5c4dacfb6 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -17,7 +17,6 @@ import Model.Types.Allocation as Types
import Model.Types.Languages as Types
import Model.Types.File as Types
import Model.Types.User as Types
-import Model.Types.Workflow as Types
import Model.Types.Changelog as Types
import Model.Types.Markup as Types
import Model.Types.Room as Types
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index e4793092e..da0758f10 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -54,8 +54,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthExamOffice
| AuthSystemExamOffice
| AuthEvaluation
- | AuthAllocationAdmin
- | AuthWorkflow
+ | AuthAllocationAdmin
| AuthAllocationRegistered
| AuthCourseRegistered
| AuthTutorialRegistered
diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs
deleted file mode 100644
index 0b92b546e..000000000
--- a/src/Model/Types/Workflow.hs
+++ /dev/null
@@ -1,1269 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
-module Model.Types.Workflow
- ( WorkflowGraph(..), WorkflowGraphReference(..)
- , WorkflowGraphNodeLabel
- , WorkflowGraphNode(..)
- , WorkflowNodeView(..)
- , WorkflowNodeMessage(..)
- , WorkflowGraphEdgeLabel
- , WorkflowGraphEdge(..)
- , WorkflowEdgeMessage(..)
- , WorkflowGraphRestriction(..)
- , WorkflowGraphEdgeFormOrder
- , WorkflowGraphEdgeForm(..)
- , WorkflowRole(..)
- , WorkflowPayloadView(..)
- , WorkflowPayloadSpec(..), _WorkflowPayloadSpec
- , WorkflowPayloadFieldReference
- , WorkflowPayloadTimeCapture, WorkflowPayloadTimeCapturePrecision(..)
- , WorkflowPayloadTextPreset(..)
- , WorkflowPayloadField(..)
- , WorkflowScope(..)
- , WorkflowScope'(..), classifyWorkflowScope
- , WorkflowPayloadLabel(..)
- , WorkflowStateIndex(..), workflowStateIndex, workflowStateSection
- , WorkflowState
- , WorkflowActionInfo(..), workflowActionInfos
- , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime
- , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload', IsWorkflowFieldPayload
- , workflowPayloadSort
- , WorkflowFieldPayload(..), _WorkflowFieldPayload
- , workflowStatePayload, workflowStateCurrentPayloads
- , WorkflowChildren
- ) where
-
-import Import.NoModel
-
-import Model.Types.Security (AuthDNF, PredDNF)
-import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..))
-
-import Database.Persist.Sql (PersistFieldSql(..))
-import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
-import Data.ByteArray (ByteArrayAccess)
-
-import Data.Maybe (fromJust)
-
-import Data.Aeson (genericToJSON, genericParseJSON)
-import qualified Data.Aeson as JSON
-import qualified Data.Aeson.Types as JSON
-import qualified Data.Aeson.Encoding as JSON
-import Data.Aeson.Lens (_Null)
-import Data.Aeson.Types (Parser)
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
-import qualified Data.CaseInsensitive as CI
-
-import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..))
-import Data.Typeable (cast)
-
-import Data.Generics.Product.Types
-
-import Unsafe.Coerce
-
-import Utils.Lens.TH
-
-import Data.List (inits)
-
-import Data.RFC5051 (compareUnicode)
-
-import qualified Data.Binary as Binary
-
-
------ WORKFLOW GRAPH -----
-
-newtype WorkflowGraph fileid userid = WorkflowGraph
- { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)
- }
- deriving (Generic, Typeable)
-
-deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid)
-deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid)
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid)
-deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraph fileid userid)
-
-newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
- deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
- deriving newtype ( PersistField
- , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
- , ByteArrayAccess
- , Binary
- )
- deriving anyclass (Hashable, NFData)
-
-instance PersistFieldSql WorkflowGraphReference where
- sqlType _ = sqlType $ Proxy @(Digest SHA3_256)
-
------ WORKFLOW GRAPH: NODES -----
-
-newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
- deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
- deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
- deriving anyclass (NFData)
-
-instance PersistFieldSql WorkflowGraphNodeLabel where
- sqlType _ = sqlType $ Proxy @(CI Text)
-
-data WorkflowGraphNode fileid userid = WGN
- { wgnFinal :: Maybe Icon
- , wgnViewers :: Maybe (WorkflowNodeView userid)
- , wgnMessages :: Set (WorkflowNodeMessage userid)
- , wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
- , wgnPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView userid)
- }
- deriving (Generic, Typeable)
-
-deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid)
-deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid)
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid)
-deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphNode fileid userid)
-
-data WorkflowNodeView userid = WorkflowNodeView
- { wnvViewers :: NonNull (Set (WorkflowRole userid))
- , wnvDisplayLabel :: I18nText
- }
- deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
- deriving anyclass (NFData)
-
-data WorkflowNodeMessage userid = WorkflowNodeMessage
- { wnmViewers :: NonNull (Set (WorkflowRole userid))
- , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
- , wnmStatus :: MessageStatus
- , wnmContent :: I18nHtml
- }
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
------ WORKFLOW GRAPH: EDGES -----
-
-newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
- deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
- deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
- deriving anyclass (NFData)
-
-instance PersistFieldSql WorkflowGraphEdgeLabel where
- sqlType _ = sqlType $ Proxy @(CI Text)
-
-data WorkflowGraphRestriction
- = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
- | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
- | WorkflowGraphRestrictionInitial
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
-data WorkflowGraphEdge fileid userid
- = WorkflowGraphEdgeManual
- { wgeSource :: WorkflowGraphNodeLabel
- , wgeActors :: Set (WorkflowRole userid)
- , wgeForm :: WorkflowGraphEdgeForm fileid userid
- , wgeDisplayLabel :: I18nText
- , wgeViewActor :: Set (WorkflowRole userid)
- , wgeMessages :: Set (WorkflowEdgeMessage userid)
- }
- | WorkflowGraphEdgeAutomatic
- { wgeSource :: WorkflowGraphNodeLabel
- , wgeRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
- }
- | WorkflowGraphEdgeInitial
- { wgeActors :: Set (WorkflowRole userid)
- , wgeForm :: WorkflowGraphEdgeForm fileid userid
- , wgeDisplayLabel :: I18nText
- , wgeViewActor :: Set (WorkflowRole userid)
- , wgeMessages :: Set (WorkflowEdgeMessage userid)
- }
- deriving (Generic, Typeable)
-
-deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid)
-deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid)
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid)
-deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdge fileid userid)
-
-data WorkflowEdgeMessage userid = WorkflowEdgeMessage
- { wemViewers :: NonNull (Set (WorkflowRole userid))
- , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
- , wemStatus :: MessageStatus
- , wemContent :: I18nHtml
- }
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
--- | A wrapped `Scientific`
---
--- Due to arbitrary precision this allows inserting new fields anywhere
-newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGraphEdgeFormOrder :: Maybe Scientific }
- deriving (Read, Show, Generic, Typeable)
- deriving (Eq, Ord) via (NTop (Maybe Scientific))
- deriving (Semigroup, Monoid) via (Maybe (Min Scientific))
- deriving anyclass (NFData)
-
-newtype WorkflowGraphEdgeForm fileid userid
- = WorkflowGraphEdgeForm
- { wgefFields :: Map WorkflowPayloadLabel (NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid)))))
- -- ^ field requirement forms a cnf:
- --
- -- - all labels must be filled
- -- - for each label any field must be filled
- -- - optional fields are always considered to be filled
- --
- -- since fields can reference other labels this allows arbitrary requirements to be encoded.
- }
- deriving (Generic, Typeable)
-
-deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid)
-deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid)
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid)
-deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdgeForm fileid userid)
-
------ WORKFLOW GRAPH: ROLES / ACTORS -----
-
-data WorkflowRole userid
- = WorkflowRoleUser { workflowRoleUser :: userid }
- | WorkflowRolePayloadReference { workflowRolePayloadLabel :: WorkflowPayloadLabel }
- | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF }
- | WorkflowRoleInitiator
- deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
- deriving anyclass (NFData)
-
-
------ WORKFLOW GRAPH: PAYLOAD SPECIFICATION -----
-
-data WorkflowPayloadView userid = WorkflowPayloadView
- { wpvViewers :: NonNull (Set (WorkflowRole userid))
- , wpvDisplayLabel :: I18nText
- }
- deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
- deriving anyclass (NFData)
-
-data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload)
- deriving (Typeable)
-
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid)
-instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadSpec fileid userid) where
- rnf (WorkflowPayloadSpec pField) = rnf pField
-
-data WorkflowPayloadFieldReference
- deriving (Typeable)
-
-data WorkflowPayloadTimeCapture
- deriving (Typeable)
-
-data WorkflowPayloadTimeCapturePrecision
- = WFCaptureDate | WFCaptureTime | WFCaptureDateTime
- deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
- deriving anyclass (Universe, Finite, NFData)
-instance Default WorkflowPayloadTimeCapturePrecision where
- def = WFCaptureDateTime
-
-data WorkflowPayloadTextPreset = WorkflowPayloadTextPreset
- { wptpText :: Text
- , wptpLabel :: I18nText
- , wptpTooltip :: Maybe I18nHtml
- } deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
--- Don't forget to update the NFData instance for every change!
-data WorkflowPayloadField fileid userid (payload :: Type) where
- WorkflowPayloadFieldText :: { wpftLabel :: I18nText
- , wpftPlaceholder :: Maybe I18nText
- , wpftTooltip :: Maybe I18nHtml
- , wpftDefault :: Maybe Text
- , wpftLarge :: Bool
- , wpftOptional :: Bool
- , wpftPresets :: Maybe (NonEmpty WorkflowPayloadTextPreset)
- } -> WorkflowPayloadField fileid userid Text
- WorkflowPayloadFieldNumber :: { wpfnLabel :: I18nText
- , wpfnPlaceholder :: Maybe I18nText
- , wpfnTooltip :: Maybe I18nHtml
- , wpfnDefault
- , wpfnMin
- , wpfnMax
- , wpfnStep :: Maybe Scientific
- , wpfnOptional :: Bool
- } -> WorkflowPayloadField fileid userid Scientific
- WorkflowPayloadFieldBool :: { wpfbLabel :: I18nText
- , wpfbTooltip :: Maybe I18nHtml
- , wpfbDefault :: Maybe Bool
- , wpfbOptional :: Maybe I18nText -- ^ Optional if `Just`; encodes label of `Nothing`-Option
- } -> WorkflowPayloadField fileid userid Bool
- WorkflowPayloadFieldDay :: { wpfdLabel :: I18nText
- , wpfdTooltip :: Maybe I18nHtml
- , wpfdDefault :: Maybe Day
- , wpfdOptional :: Bool
- , wpfdMaxPast, wpfdMaxFuture :: Maybe Integer
- } -> WorkflowPayloadField fileid userid Day
- WorkflowPayloadFieldFile :: { wpffLabel :: I18nText
- , wpffTooltip :: Maybe I18nHtml
- , wpffConfig :: FileField fileid
- , wpffOptional :: Bool
- } -> WorkflowPayloadField fileid userid (Set fileid)
- WorkflowPayloadFieldUser :: { wpfuLabel :: I18nText
- , wpfuTooltip :: Maybe I18nHtml
- , wpfuDefault :: Maybe userid
- , wpfuOptional :: Bool
- } -> WorkflowPayloadField fileid userid userid
- WorkflowPayloadFieldCaptureUser :: WorkflowPayloadField fileid userid userid
- WorkflowPayloadFieldCaptureDateTime :: { wpfcdtPrecision :: WorkflowPayloadTimeCapturePrecision
- , wpfcdtLabel :: I18nText
- , wpfcdtTooltip :: Maybe I18nHtml
- } -> WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture
- WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel
- } -> WorkflowPayloadField fileid userid WorkflowPayloadFieldReference
- WorkflowPayloadFieldMultiple :: { wpfmLabel :: I18nText
- , wpfmTooltip :: Maybe I18nHtml
- , wpfmDefault :: Maybe (NonEmpty (WorkflowFieldPayloadW fileid userid))
- , wpfmSub :: WorkflowPayloadSpec fileid userid
- , wpfmMin :: Natural
- , wpfmRange :: Maybe Natural -- ^ `wpfmMax = (+ wpfmMin) <$> wpfmRange
- } -> WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))
- deriving (Typeable)
-
-deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadField fileid userid payload)
-deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid, Eq (FileField fileid)) => Eq (WorkflowPayloadField fileid userid payload)
-deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid, Ord (FileField fileid)) => Ord (WorkflowPayloadField fileid userid payload)
-
-instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowPayloadSpec fileid userid) where
- (WorkflowPayloadSpec a) == (WorkflowPayloadSpec b)
- = case typeOf a `eqTypeRep` typeOf b of
- Just HRefl -> a == b
- Nothing -> False
-
-instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowPayloadSpec fileid userid) where
- (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b)
- = case typeOf a `eqTypeRep` typeOf b of
- Just HRefl -> a `compare` b
- Nothing -> case (a, b) of
- (WorkflowPayloadFieldText{}, _) -> LT
- (WorkflowPayloadFieldNumber{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldNumber{}, _) -> LT
- (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldBool{}, _) -> LT
- (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldDay{}, _) -> LT
- (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldDay{}) -> GT
- (WorkflowPayloadFieldFile{}, _) -> LT
- (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldDay{}) -> GT
- (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT
- (WorkflowPayloadFieldUser{}, _) -> LT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldDay{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldFile{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldUser{}) -> GT
- (WorkflowPayloadFieldCaptureUser{}, _) -> LT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldDay{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldFile{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldUser{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldCaptureUser{}) -> GT
- (WorkflowPayloadFieldCaptureDateTime{}, _) -> LT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldText{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldNumber{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldBool{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldDay{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldFile{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldUser{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureUser{}) -> GT
- (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureDateTime{}) -> GT
- (WorkflowPayloadFieldReference{}, _) -> LT
- (WorkflowPayloadFieldMultiple{}, _) -> GT
-
-instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadField fileid userid payload) where
- rnf = \case
- WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` wpftPresets `deepseq` ()
- WorkflowPayloadFieldNumber{..} -> wpfnLabel `deepseq` wpfnPlaceholder `deepseq` wpfnTooltip `deepseq` wpfnDefault `deepseq` wpfnMin `deepseq` wpfnMax `deepseq` wpfnStep `deepseq` wpfnOptional `deepseq` ()
- WorkflowPayloadFieldBool{..} -> wpfbLabel `deepseq` wpfbTooltip `deepseq` wpfbDefault `deepseq` wpfbOptional `deepseq` ()
- WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` wpfdMaxPast `deepseq` wpfdMaxFuture `deepseq` ()
- WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` ()
- WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` ()
- WorkflowPayloadFieldCaptureUser -> ()
- WorkflowPayloadFieldCaptureDateTime{..} -> wpfcdtPrecision `deepseq` wpfcdtLabel `deepseq` wpfcdtTooltip `deepseq` ()
- WorkflowPayloadFieldReference{..} -> wpfrTarget `deepseq` ()
- WorkflowPayloadFieldMultiple{..} -> wpfmLabel `deepseq` wpfmTooltip `deepseq` wpfmDefault `deepseq` wpfmSub `deepseq` wpfmMin `deepseq` wpfmRange `deepseq` ()
-
-_WorkflowPayloadSpec :: forall payload fileid userid.
- ( Typeable payload, Typeable fileid, Typeable userid )
- => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload)
-_WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> cast pF
-
-data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFCaptureDateTime' | WPFReference' | WPFMultiple'
- deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
- deriving anyclass (Universe, Finite, NFData)
-
-
------ WORKFLOW INSTANCE -----
-
-data WorkflowScope termid schoolid courseid
- = WSGlobal
- | WSTerm { wisTerm :: termid }
- | WSSchool { wisSchool :: schoolid }
- | WSTermSchool { wisTerm :: termid, wisSchool :: schoolid }
- | WSCourse { wisCourse :: courseid }
- deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
- deriving anyclass (Hashable, NFData)
-
-data WorkflowScope'
- = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
- deriving anyclass (Universe, Finite, NFData)
-
-classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope'
-classifyWorkflowScope = \case
- WSGlobal -> WSGlobal'
- WSTerm{} -> WSTerm'
- WSSchool{} -> WSSchool'
- WSTermSchool{} -> WSTermSchool'
- WSCourse{} -> WSCourse'
-
------ WORKFLOW: PAYLOAD -----
-
-newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text }
- deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
- deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
- deriving anyclass (NFData)
-
-instance PersistFieldSql WorkflowPayloadLabel where
- sqlType _ = sqlType $ Proxy @(CI Text)
-
-newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
- deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
- deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)
- deriving anyclass (NFData)
-
-type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))
-
-workflowStateIndex :: Alternative m
- => WorkflowStateIndex
- -> WorkflowState fileid userid
- -> m (WorkflowAction fileid userid)
-workflowStateIndex (fromIntegral -> i) = maybe empty pure . flip index i . toNullable
-
-workflowStateSection :: MonadPlus m
- => WorkflowStateIndex
- -> WorkflowState fileid userid
- -> m (WorkflowState fileid userid)
-workflowStateSection i wSt = maybe mzero return . fromNullable . Seq.fromList =<< traverse (`workflowStateIndex` wSt) [0..i]
-
-data WorkflowAction fileid userid = WorkflowAction
- { wpTo :: WorkflowGraphNodeLabel
- , wpVia :: WorkflowGraphEdgeLabel
- , wpPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid))
- , wpUser :: Maybe (Maybe userid) -- ^ Outer `Maybe` encodes automatic/manual, inner `Maybe` encodes whether user was authenticated
- , wpTime :: UTCTime
- }
- deriving (Eq, Ord, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
-data WorkflowActionInfo fileid userid = WorkflowActionInfo
- { waiIx :: WorkflowStateIndex
- , waiFrom :: Maybe WorkflowGraphNodeLabel
- , waiHistory :: [WorkflowAction fileid userid]
- , waiAction :: WorkflowAction fileid userid
- }
- deriving (Eq, Ord, Show, Generic, Typeable)
- deriving anyclass (NFData)
-
-workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid]
-workflowActionInfos wState
- = [ WorkflowActionInfo{..}
- | waiFrom <- Nothing : map (Just . wpTo) wState'
- | waiAction <- wState'
- | waiIx <- [minBound..]
- | waiHistory <- tailEx $ inits wState'
- ]
- where wState' = otoList wState
-
-data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
- deriving (Typeable)
-
-instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayloadW fileid userid) where
- rnf (WorkflowFieldPayloadW fPayload) = rnf fPayload
-
-instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where
- (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b)
- = case typeOf a `eqTypeRep` typeOf b of
- Just HRefl -> a == b
- Nothing -> False
-
-instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (WorkflowFieldPayloadW fileid userid) where
- (WorkflowFieldPayloadW a) `compare` (WorkflowFieldPayloadW b)
- = case typeOf a `eqTypeRep` typeOf b of
- Just HRefl -> a `compare` b
- Nothing -> case (a, b) of
- (WFPText{}, _) -> LT
- (WFPNumber{}, WFPText{}) -> GT
- (WFPNumber{}, _) -> LT
- (WFPBool{}, WFPText{}) -> GT
- (WFPBool{}, WFPNumber{}) -> GT
- (WFPBool{}, _) -> LT
- (WFPDay{}, WFPText{}) -> GT
- (WFPDay{}, WFPNumber{}) -> GT
- (WFPDay{}, WFPBool{}) -> GT
- (WFPDay{}, _) -> LT
- (WFPTime{}, WFPText{}) -> GT
- (WFPTime{}, WFPNumber{}) -> GT
- (WFPTime{}, WFPBool{}) -> GT
- (WFPTime{}, WFPDay{}) -> GT
- (WFPTime{}, _) -> LT
- (WFPDateTime{}, WFPText{}) -> GT
- (WFPDateTime{}, WFPNumber{}) -> GT
- (WFPDateTime{}, WFPBool{}) -> GT
- (WFPDateTime{}, WFPDay{}) -> GT
- (WFPDateTime{}, WFPTime{}) -> GT
- (WFPDateTime{}, _) -> LT
- (WFPFile{}, WFPText{}) -> GT
- (WFPFile{}, WFPNumber{}) -> GT
- (WFPFile{}, WFPBool{}) -> GT
- (WFPFile{}, WFPDay{}) -> GT
- (WFPFile{}, WFPTime{}) -> GT
- (WFPFile{}, WFPDateTime{}) -> GT
- (WFPFile{}, _) -> LT
- (WFPUser{}, _) -> GT
-
-workflowPayloadSort
- :: forall fileid userid.
- (fileid -> fileid -> Ordering)
- -> (userid -> userid -> Ordering)
- -> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering)
--- ^ @workflowPayloadSort compare compare /= compare@
-workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
- (WFPText a', WFPText b' ) -> compareUnicode a' b'
- (WFPText{}, _ ) -> LT
- (WFPNumber a', WFPNumber b') -> compare a' b'
- (WFPNumber{}, WFPText{} ) -> GT
- (WFPNumber{}, _ ) -> LT
- (WFPBool a', WFPBool b' ) -> compare a' b'
- (WFPBool{}, WFPText{} ) -> GT
- (WFPBool{}, WFPNumber{} ) -> GT
- (WFPBool{}, _ ) -> LT
- (WFPDay a', WFPDay b' ) -> compare a' b'
- (WFPDay{}, WFPText{} ) -> GT
- (WFPDay{}, WFPNumber{} ) -> GT
- (WFPDay{}, WFPBool{} ) -> GT
- (WFPDay{}, _ ) -> LT
- (WFPTime a', WFPTime b' ) -> compare a' b'
- (WFPTime{}, WFPText{} ) -> GT
- (WFPTime{}, WFPNumber{} ) -> GT
- (WFPTime{}, WFPBool{} ) -> GT
- (WFPTime{}, WFPDay{} ) -> GT
- (WFPTime{}, _ ) -> LT
- (WFPDateTime a', WFPDateTime b') -> compare a' b'
- (WFPDateTime{}, WFPText{} ) -> GT
- (WFPDateTime{}, WFPNumber{} ) -> GT
- (WFPDateTime{}, WFPBool{} ) -> GT
- (WFPDateTime{}, WFPDay{} ) -> GT
- (WFPDateTime{}, WFPTime{} ) -> GT
- (WFPDateTime{}, _ ) -> LT
- (WFPFile a', WFPFile b' ) -> ordFiles a' b'
- (WFPFile{}, WFPText{} ) -> GT
- (WFPFile{}, WFPNumber{} ) -> GT
- (WFPFile{}, WFPBool{} ) -> GT
- (WFPFile{}, WFPDay{} ) -> GT
- (WFPFile{}, WFPTime{} ) -> GT
- (WFPFile{}, WFPDateTime{}) -> GT
- (WFPFile{}, _ ) -> LT
- (WFPUser a', WFPUser b' ) -> ordUsers a' b'
- (WFPUser{}, _ ) -> GT
-
-instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
- show (WorkflowFieldPayloadW payload) = show payload
-
--- Don't forget to update the NFData instance for every change!
-data WorkflowFieldPayload fileid userid (payload :: Type) where
- WFPText :: Text -> WorkflowFieldPayload fileid userid Text
- WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific
- WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool
- WFPDay :: Day -> WorkflowFieldPayload fileid userid Day
- WFPTime :: TimeOfDay -> WorkflowFieldPayload fileid userid TimeOfDay
- WFPDateTime :: UTCTime -> WorkflowFieldPayload fileid userid UTCTime
- WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid
- WFPUser :: userid -> WorkflowFieldPayload fileid userid userid
- deriving (Typeable)
-
-deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload)
-deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload)
-deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload)
-
-instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayload fileid userid payload) where
- rnf = \case
- WFPText t -> rnf t
- WFPNumber n -> rnf n
- WFPBool b -> rnf b
- WFPDay d -> rnf d
- WFPTime t -> rnf t
- WFPDateTime t -> rnf t
- WFPFile f -> rnf f
- WFPUser u -> rnf u
-
-_WorkflowFieldPayloadW :: forall payload fileid userid.
- ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid )
- => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload)
-_WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW fp) -> cast fp
-
-data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPTime' | WFPDateTime' | WFPFile' | WFPUser'
- deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
- deriving anyclass (Universe, Finite, NFData, Binary)
-
-type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload
-
-class Typeable payload => IsWorkflowFieldPayload fileid fileid' userid userid' payload payload' where
- _WorkflowFieldPayload :: Prism (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload'
-
-instance IsWorkflowFieldPayload fileid fileid userid userid Text Text where
- _WorkflowFieldPayload = prism' WFPText $ \case { WFPText x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid fileid userid userid Scientific Scientific where
- _WorkflowFieldPayload = prism' WFPNumber $ \case { WFPNumber x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid fileid userid userid Bool Bool where
- _WorkflowFieldPayload = prism' WFPBool $ \case { WFPBool x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid fileid userid userid Day Day where
- _WorkflowFieldPayload = prism' WFPDay $ \case { WFPDay x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid fileid userid userid TimeOfDay TimeOfDay where
- _WorkflowFieldPayload = prism' WFPTime $ \case { WFPTime x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid fileid userid userid UTCTime UTCTime where
- _WorkflowFieldPayload = prism' WFPDateTime $ \case { WFPDateTime x -> Just x; _other -> Nothing }
-instance Typeable fileid => IsWorkflowFieldPayload fileid fileid' userid userid fileid fileid' where
- _WorkflowFieldPayload = prism WFPFile $ \case { WFPFile x -> Right x; other -> Left $ unsafeCoerce other }
-instance Typeable userid => IsWorkflowFieldPayload fileid fileid userid userid' userid userid' where
- _WorkflowFieldPayload = prism WFPUser $ \case { WFPUser x -> Right x; other -> Left $ unsafeCoerce other }
-
--- workflowStatePayload :: forall fileid userid payload.
--- ( IsWorkflowFieldPayload' fileid userid payload
--- , Ord fileid, Ord userid, Ord payload
--- , Typeable fileid, Typeable userid
--- , Show userid, Show fileid
--- )
--- => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
--- workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (Set.fromList . concatMap extractPayload . otoList) wpPayload
--- where
--- extractPayload :: WorkflowFieldPayloadW fileid userid -> [payload]
--- extractPayload = \case
--- WorkflowFieldPayloadW fieldPayload@(WFPMultiple ps) -> traceShow ("multiple", fieldPayload) . concatMap extractPayload $ otoList ps
--- WorkflowFieldPayloadW fieldPayload
--- | Just HRefl <- traceShow ("single", fieldPayload) $ typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload)
--- -> fieldPayload ^.. _WorkflowFieldPayload
--- | otherwise
--- -> traceShow ("none", fieldPayload) mempty
-
-workflowStateCurrentPayloads :: forall fileid userid mono.
- ( Element mono ~ WorkflowAction fileid userid
- , MonoFoldable mono
- )
- => mono
- -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid))
-workflowStateCurrentPayloads = Map.unionsWith (\_ v -> v) . map wpPayload . otoList
-
------ Lenses needed here -----
-
-makeLenses_ ''WorkflowAction
-
------ Generic traversal -----
-
-type family Concat as bs where
- Concat '[] bs = bs
- Concat as '[] = as
- Concat (a ': as) bs = a ': Concat as bs
-
-data WorkflowChildren
-type instance Children WorkflowChildren a = ChildrenWorkflowChildren a
-type family ChildrenWorkflowChildren a where
- ChildrenWorkflowChildren (Map k v) = '[v]
- ChildrenWorkflowChildren (Set a) = '[a]
- ChildrenWorkflowChildren (Seq a) = '[a]
- ChildrenWorkflowChildren [a] = '[a]
- ChildrenWorkflowChildren (NonEmpty a) = '[a]
- ChildrenWorkflowChildren (NonNull mono) = '[Element mono]
- ChildrenWorkflowChildren (CI a) = '[a]
- ChildrenWorkflowChildren UUID = '[]
- ChildrenWorkflowChildren Html = '[]
- ChildrenWorkflowChildren Scientific = '[]
- ChildrenWorkflowChildren (BackendKey SqlBackend) = '[]
- ChildrenWorkflowChildren (Key record) = '[]
- ChildrenWorkflowChildren FileContentReference = '[]
- ChildrenWorkflowChildren UTCTime = '[]
- ChildrenWorkflowChildren Day = '[]
- ChildrenWorkflowChildren (WorkflowPayloadSpec fileid userid)
- = ChildrenWorkflowChildren I18nText
- `Concat` ChildrenWorkflowChildren (Maybe I18nText)
- `Concat` ChildrenWorkflowChildren (Maybe I18nHtml)
- `Concat` ChildrenWorkflowChildren (Maybe Text)
- `Concat` ChildrenWorkflowChildren (Maybe Scientific)
- `Concat` ChildrenWorkflowChildren (Maybe Bool)
- `Concat` ChildrenWorkflowChildren (Maybe Day)
- `Concat` ChildrenWorkflowChildren (Maybe fileid)
- `Concat` ChildrenWorkflowChildren (Maybe userid)
- `Concat` ChildrenWorkflowChildren Bool
- `Concat` ChildrenWorkflowChildren WorkflowPayloadLabel
- ChildrenWorkflowChildren (WorkflowFieldPayloadW fileid userid)
- = ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Text)
- `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Scientific)
- `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Bool)
- `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Day)
- `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid fileid)
- `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid userid)
- ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid payload)
- = ChildrenWorkflowChildren payload
- ChildrenWorkflowChildren a = Children ChGeneric a
-
-instance HasTypesCustom WorkflowChildren a a a a where
- typesCustom = id
-
-instance HasTypesCustom WorkflowChildren a' b' a b => HasTypesCustom WorkflowChildren (NonEmpty a') (NonEmpty b') a b where
- typesCustom = traverse . typesCustom @WorkflowChildren
-
-instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where
- typesCustom = traverse . typesCustom @WorkflowChildren
-
-instance (Ord b', HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Set a') (Set b') a b where
- typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @WorkflowChildren
-
-instance (HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Seq a') (Seq b') a b where
- typesCustom = traverse . typesCustom @WorkflowChildren
-
-instance (HasTypesCustom WorkflowChildren mono mono' a a', MonoFoldable mono') => HasTypesCustom WorkflowChildren (NonNull mono) (NonNull mono') a a' where
- typesCustom = iso toNullable impureNonNull . typesCustom @WorkflowChildren
-
-instance (HasTypesCustom WorkflowChildren a' b' a b, FoldCase b') => HasTypesCustom WorkflowChildren (CI a') (CI b') a b where
- typesCustom = iso CI.original CI.mk . typesCustom @WorkflowChildren
-
-instance (Typeable userid, Typeable fileid, Typeable fileid', Ord fileid', userid ~ userid', FileReferenceTitleMapConvertible (FileFieldUserOption Bool) fileid fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') fileid fileid' where
- typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = traverseOf (_fieldAdditionalFiles . _FileReferenceTitleMap . _1) f wpffConfig <&> \wpffConfig' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffConfig = wpffConfig', .. }
- typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> traverseOf (typesCustom @WorkflowChildren) f sub <*> traverseOf (traverse . traverse . typesCustom @WorkflowChildren) f def'
- where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
-
-instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where
- typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid', .. }
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}
- typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> typesCustom @WorkflowChildren f sub <*> (traverse . typesCustom @WorkflowChildren) f def'
- where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}
- typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
-
-instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where
- typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) of
- Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid' userid' payload') @payload @payload' f p
- Nothing -> pure pw
-
-instance {-# OVERLAPPING #-} (Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') userid userid' where
- typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid userid) of
- Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid userid) @(WorkflowFieldPayload fileid' userid' userid') @userid @userid' f p
- Nothing -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid') pw -- We have proof that @p@ does not contain a value of type @userid@, therefor coercion is safe
-
-instance {-# OVERLAPPING #-} (Typeable userid, Typeable fileid, IsWorkflowFieldPayload' fileid userid fileid, IsWorkflowFieldPayload' fileid' userid' fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') fileid fileid' where
- typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid fileid) of
- Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid fileid) @(WorkflowFieldPayload fileid' userid' fileid') @fileid @fileid' f p
- Nothing -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid' userid) pw -- We have proof that @p@ does not contain a value of type @fileid@, therefor coercion is safe
-
-instance (IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where
- typesCustom f x = case x ^? _WorkflowFieldPayload of
- Just x' -> review _WorkflowFieldPayload <$> f x'
- Nothing -> error "@WorkflowFieldPayload fileid userid payload@ does not contain value of type @payload@; this means `IsWorkflowFieldPayload` is invalid"
-
-instance (Ord userid, Ord fileid, Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') payload payload' where
- typesCustom = _wpPayload . typesCustom @WorkflowChildren
-
-instance {-# OVERLAPPING #-} (Ord userid', Ord fileid, Typeable fileid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') userid userid' where
- typesCustom f WorkflowAction{..} = WorkflowAction wpTo wpVia
- <$> traverseOf (typesCustom @WorkflowChildren @_ @_ @userid @userid') f wpPayload
- <*> traverseOf (_Just . _Just) f wpUser
- <*> pure wpTime
-
-
-workflowStatePayload :: forall fileid userid payload.
- ( HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid userid) payload payload
- , Ord payload
- )
- => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
-workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (setOf $ folded . typesCustom @WorkflowChildren @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid) @payload @payload) wpPayload
-
-
------ PathPiece instances -----
-
-nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
-nullaryPathPiece ''WorkflowFieldPayload' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
-
-nullaryPathPiece ''WorkflowPayloadField' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
-
-derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--"
-
-nullaryPathPiece ''WorkflowPayloadTimeCapturePrecision $ camelToPathPiece' 2
-
------ ToJSON / FromJSON instances -----
-
-omitNothing :: [JSON.Pair] -> [JSON.Pair]
-omitNothing = filter . hasn't $ _2 . _Null
-
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 2
- , constructorTagModifier = camelToPathPiece' 2
- } ''WorkflowRole
-
-deriveToJSON workflowNodeViewAesonOptions ''WorkflowNodeView
-deriveToJSON workflowNodeMessageAesonOptions ''WorkflowNodeMessage
-deriveToJSON workflowEdgeMessageAesonOptions ''WorkflowEdgeMessage
-deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
-pathPieceJSON ''WorkflowFieldPayload'
-pathPieceJSON ''WorkflowPayloadField'
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- , constructorTagModifier = camelToPathPiece' 3
- } ''WorkflowGraphRestriction
-
-pathPieceJSON ''WorkflowPayloadTimeCapturePrecision
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''WorkflowPayloadTextPreset
-
-instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where
- parseJSON = genericParseJSON workflowNodeMessageAesonOptions
-instance (FromJSON userid, Ord userid) => FromJSON (WorkflowEdgeMessage userid) where
- parseJSON = genericParseJSON workflowEdgeMessageAesonOptions
-instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where
- parseJSON = genericParseJSON workflowNodeViewAesonOptions
-instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where
- parseJSON = genericParseJSON workflowPayloadViewAesonOptions
-
-instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraph fileid userid) where
- toJSON = toJSON . wgNodes
-instance ( FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , FromJSON (FileField fileid)
- , Ord (FileField fileid)
- ) => FromJSON (WorkflowGraph fileid userid) where
- parseJSON = fmap WorkflowGraph . parseJSON
-
-instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdge fileid userid) where
- toJSON = genericToJSON workflowGraphEdgeAesonOptions
-instance ( FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , FromJSON (FileField fileid)
- , Ord (FileField fileid)
- ) => FromJSON (WorkflowGraphEdge fileid userid) where
- parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do
- mode <- o JSON..: "mode" :: JSON.Parser Text
- if | mode == "manual" -> do
- wgeSource <- o JSON..: "source"
- wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
- wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
- wgeDisplayLabel <- o JSON..: "display-label"
- wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
- wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
- return WorkflowGraphEdgeManual{..}
- | mode == "automatic" -> do
- wgeSource <- o JSON..: "source"
- wgeRestriction <- o JSON..:? "restriction"
- return WorkflowGraphEdgeAutomatic{..}
- | mode == "initial" -> do
- wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
- wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
- wgeDisplayLabel <- o JSON..: "display-label"
- wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
- wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
- return WorkflowGraphEdgeInitial{..}
- | otherwise -> fail "Could not parse WorkflowGraphEdge, expected mode to be one of: manual, automatic, initial"
-
-instance ToJSON WorkflowGraphEdgeFormOrder where
- toJSON WorkflowGraphEdgeFormOrder{..} = case unWorkflowGraphEdgeFormOrder of
- Nothing -> JSON.String "_"
- Just sci -> JSON.Number sci
-instance FromJSON WorkflowGraphEdgeFormOrder where
- parseJSON v = fmap WorkflowGraphEdgeFormOrder $
- Just <$> parseJSON v
- <|> JSON.withText "WorkflowGraphEdgeFormOrder" (maybe (fail "WorkflowGraphEdgeFormOrder: could not parse String as Number") (return . Just) . readMay) v
- <|> JSON.withText "WorkflowGraphEdgeFormOrder" (bool (fail "WorkflowGraphEdgeFormOrder: unexpected String, expecting either number or \"_\"") (pure Nothing) . (== "_")) v
-
-instance ToJSONKey WorkflowGraphEdgeFormOrder where
- toJSONKey = JSON.ToJSONKeyText (maybe "_" toText' . unWorkflowGraphEdgeFormOrder) (maybe (JSON.text "_") toEncoding' . unWorkflowGraphEdgeFormOrder)
- where toText' = decodeUtf8 . toStrict . JSON.encodingToLazyByteString . JSON.scientific
- toEncoding' = JSON.scientificText
-instance FromJSONKey WorkflowGraphEdgeFormOrder where
- fromJSONKey = JSON.FromJSONKeyTextParser $ parseJSON . JSON.String
-
-instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdgeForm fileid userid) where
- toJSON WorkflowGraphEdgeForm{..} = toJSON . flip map wgefFields $ \(toNullable -> disj) -> flip Set.map disj $ \(toNullable -> orderedFields) -> if
- | [(WorkflowGraphEdgeFormOrder Nothing, field)] <- Map.toList orderedFields
- -> toJSON field
- | otherwise
- -> toJSON orderedFields
-
-instance ( FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , FromJSON (FileField fileid), Ord (FileField fileid)
- ) => FromJSON (WorkflowGraphEdgeForm fileid userid) where
- parseJSON = JSON.withObject "WorkflowGraphEdgeForm" $ \o -> do
- o' <- parseJSON $ JSON.Object o :: JSON.Parser (Map WorkflowPayloadLabel (NonNull (Set JSON.Value)))
- fmap WorkflowGraphEdgeForm . for o' $ \(Set.toList . toNullable -> o'') -> fmap (impureNonNull . Set.fromList) . for o'' $ \o''' ->
- parseJSON o'''
- <|> impureNonNull . Map.singleton (WorkflowGraphEdgeFormOrder Nothing) <$> parseJSON o'''
-
-instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadSpec fileid userid) where
- toJSON (WorkflowPayloadSpec f) = toJSON f
-
-instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadField fileid userid payload) where
- toJSON WorkflowPayloadFieldText{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFText'
- , "label" JSON..= wpftLabel
- , "placeholder" JSON..= wpftPlaceholder
- , "tooltip" JSON..= wpftTooltip
- , "default" JSON..= wpftDefault
- , "large" JSON..= wpftLarge
- , "optional" JSON..= wpftOptional
- , "presets" JSON..= wpftPresets
- ]
- toJSON WorkflowPayloadFieldNumber{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFNumber'
- , "label" JSON..= wpfnLabel
- , "placeholder" JSON..= wpfnPlaceholder
- , "tooltip" JSON..= wpfnTooltip
- , "default" JSON..= wpfnDefault
- , "min" JSON..= wpfnMin
- , "max" JSON..= wpfnMax
- , "step" JSON..= wpfnStep
- , "optional" JSON..= wpfnOptional
- ]
- toJSON WorkflowPayloadFieldBool{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFBool'
- , "label" JSON..= wpfbLabel
- , "tooltip" JSON..= wpfbTooltip
- , "default" JSON..= wpfbDefault
- , "optional" JSON..= wpfbOptional
- ]
- toJSON WorkflowPayloadFieldDay{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFDay'
- , "label" JSON..= wpfdLabel
- , "tooltip" JSON..= wpfdTooltip
- , "default" JSON..= wpfdDefault
- , "optional" JSON..= wpfdOptional
- , "max-past" JSON..= wpfdMaxPast
- , "max-future" JSON..= wpfdMaxFuture
- ]
- toJSON WorkflowPayloadFieldFile{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFFile'
- , "label" JSON..= wpffLabel
- , "tooltip" JSON..= wpffTooltip
- , "config" JSON..= wpffConfig
- , "optional" JSON..= wpffOptional
- ]
- toJSON WorkflowPayloadFieldUser{..} = JSON.object $ omitNothing
- [ "tag" JSON..= WPFUser'
- , "label" JSON..= wpfuLabel
- , "tooltip" JSON..= wpfuTooltip
- , "default" JSON..= wpfuDefault
- , "optional" JSON..= wpfuOptional
- ]
- toJSON WorkflowPayloadFieldCaptureUser{} = JSON.object
- [ "tag" JSON..= WPFCaptureUser'
- ]
- toJSON WorkflowPayloadFieldCaptureDateTime{..} = JSON.object
- [ "tag" JSON..= WPFCaptureDateTime'
- , "label" JSON..= wpfcdtLabel
- , "tooltip" JSON..= wpfcdtTooltip
- , "precision" JSON..= wpfcdtPrecision
- ]
- toJSON WorkflowPayloadFieldReference{..} = JSON.object
- [ "tag" JSON..= WPFReference'
- , "target" JSON..= wpfrTarget
- ]
- toJSON WorkflowPayloadFieldMultiple{..} = JSON.object
- [ "tag" JSON..= WPFMultiple'
- , "label" JSON..= wpfmLabel
- , "tooltip" JSON..= wpfmTooltip
- , "default" JSON..= wpfmDefault
- , "sub" JSON..= wpfmSub
- , "min" JSON..= wpfmMin
- , "range" JSON..= wpfmRange
- ]
-
-instance ( FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , FromJSON (FileField fileid)
- ) => FromJSON (WorkflowPayloadSpec fileid userid) where
- parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do
- fieldTag <- o JSON..: "tag"
- case fieldTag of
- WPFText' -> do
- wpftLabel <- o JSON..: "label"
- wpftPlaceholder <- o JSON..:? "placeholder"
- wpftTooltip <- o JSON..:? "tooltip"
- wpftDefault <- o JSON..:? "default"
- wpftLarge <- o JSON..:? "large" JSON..!= False
- wpftOptional <- o JSON..: "optional"
- wpftPresets <- o JSON..:? "presets"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
- WPFNumber' -> do
- wpfnLabel <- o JSON..: "label"
- wpfnPlaceholder <- o JSON..:? "placeholder"
- wpfnTooltip <- o JSON..:? "tooltip"
- wpfnDefault <- (o JSON..:? "default" :: Parser (Maybe Scientific))
- wpfnMin <- o JSON..:? "min"
- wpfnMax <- o JSON..:? "max"
- wpfnStep <- o JSON..:? "step"
- wpfnOptional <- o JSON..: "optional"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
- WPFBool' -> do
- wpfbLabel <- o JSON..: "label"
- wpfbTooltip <- o JSON..:? "tooltip"
- wpfbOptional <- o JSON..:? "optional"
- wpfbDefault <- (o JSON..:? "default" :: Parser (Maybe Bool))
- return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
- WPFDay' -> do
- wpfdLabel <- o JSON..: "label"
- wpfdTooltip <- o JSON..:? "tooltip"
- wpfdOptional <- o JSON..: "optional"
- wpfdDefault <- (o JSON..:? "default" :: Parser (Maybe Day))
- wpfdMaxPast <- o JSON..:? "max-past"
- wpfdMaxFuture <- o JSON..:? "max-future"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
- WPFFile' -> do
- wpffLabel <- o JSON..: "label"
- wpffTooltip <- o JSON..:? "tooltip"
- wpffConfig <- o JSON..: "config"
- wpffOptional <- o JSON..: "optional"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
- WPFUser' -> do
- wpfuLabel <- o JSON..: "label"
- wpfuTooltip <- o JSON..:? "tooltip"
- wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid))
- wpfuOptional <- o JSON..: "optional"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
- WPFCaptureUser' -> pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
- WPFCaptureDateTime' -> do
- wpfcdtPrecision <- o JSON..:? "precision" JSON..!= def
- wpfcdtLabel <- o JSON..: "label"
- wpfcdtTooltip <- o JSON..:? "tooltip"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}
- WPFReference' -> do
- wpfrTarget <- o JSON..: "target"
- return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
- WPFMultiple' -> do
- wpfmLabel <- o JSON..: "label"
- wpfmTooltip <- o JSON..:? "tooltip"
- wpfmDefault <- o JSON..:? "default"
- wpfmSub <- o JSON..: "sub"
- wpfmMin <- o JSON..: "min"
- 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 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 = 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
- , fieldLabelModifier = camelToPathPiece' 1
- } ''WorkflowScope
-
-pathPieceJSON ''WorkflowScope'
-
-deriveToJSON workflowActionAesonOptions ''WorkflowAction
-
-instance ( FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- ) => FromJSON (WorkflowAction fileid userid) where
- parseJSON = genericParseJSON workflowActionAesonOptions
-
-instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where
- toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object
- [ "tag" JSON..= WFPText'
- , toPathPiece WFPText' JSON..= t
- ]
- toJSON (WorkflowFieldPayloadW (WFPNumber n)) = JSON.object
- [ "tag" JSON..= WFPNumber'
- , toPathPiece WFPNumber' JSON..= n
- ]
- toJSON (WorkflowFieldPayloadW (WFPBool b)) = JSON.object
- [ "tag" JSON..= WFPBool'
- , toPathPiece WFPBool' JSON..= b
- ]
- toJSON (WorkflowFieldPayloadW (WFPDay d)) = JSON.object
- [ "tag" JSON..= WFPDay'
- , toPathPiece WFPDay' JSON..= d
- ]
- toJSON (WorkflowFieldPayloadW (WFPTime d)) = JSON.object
- [ "tag" JSON..= WFPTime'
- , toPathPiece WFPTime' JSON..= d
- ]
- toJSON (WorkflowFieldPayloadW (WFPDateTime t)) = JSON.object
- [ "tag" JSON..= WFPDateTime'
- , toPathPiece WFPDateTime' JSON..= t
- ]
- toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object
- [ "tag" JSON..= WFPFile'
- , toPathPiece WFPFile' JSON..= fid
- ]
- toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object
- [ "tag" JSON..= WFPUser'
- , toPathPiece WFPUser' JSON..= uid
- ]
-instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where
- parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do
- fieldTag <- o JSON..: "tag"
- case fieldTag of
- WFPText' -> do
- t <- o JSON..: toPathPiece WFPText'
- return $ WorkflowFieldPayloadW $ WFPText t
- WFPNumber' -> do
- n <- o JSON..: toPathPiece WFPNumber'
- return $ WorkflowFieldPayloadW $ WFPNumber n
- WFPBool' -> do
- b <- o JSON..: toPathPiece WFPBool'
- return $ WorkflowFieldPayloadW $ WFPBool b
- WFPDay' -> do
- d <- o JSON..: toPathPiece WFPDay'
- return $ WorkflowFieldPayloadW $ WFPDay d
- WFPTime' -> do
- t <- o JSON..: toPathPiece WFPTime'
- return $ WorkflowFieldPayloadW $ WFPTime t
- WFPDateTime' -> do
- t <- o JSON..: toPathPiece WFPDateTime'
- return $ WorkflowFieldPayloadW $ WFPDateTime t
- WFPFile' -> do
- fid <- o JSON..: toPathPiece WFPFile'
- return $ WorkflowFieldPayloadW $ WFPFile fid
- WFPUser' -> do
- uid <- o JSON..: toPathPiece WFPUser'
- return $ WorkflowFieldPayloadW $ WFPUser uid
-
-
-
------ PersistField / PersistFieldSql instances -----
-
-instance ( ToJSON fileid, ToJSON userid
- , FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , ToJSON (FileField fileid), FromJSON (FileField fileid)
- , Ord (FileField fileid)
- ) => PersistField (WorkflowGraph fileid userid) where
- toPersistValue = toPersistValueJSON
- fromPersistValue = fromPersistValueJSON
-instance ( ToJSON fileid, ToJSON userid
- , FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- , ToJSON (FileField fileid), FromJSON (FileField fileid)
- , Ord (FileField fileid)
- ) => PersistFieldSql (WorkflowGraph fileid userid) where
- sqlType _ = sqlTypeJSON
-
-
-instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid
- , FromJSON termid, FromJSON schoolid, FromJSON courseid
- , Typeable termid, Typeable schoolid, Typeable courseid
- ) => PersistField (WorkflowScope termid schoolid courseid) where
- toPersistValue = toPersistValueJSON
- fromPersistValue = fromPersistValueJSON
-instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid
- , FromJSON termid, FromJSON schoolid, FromJSON courseid
- , Typeable termid, Typeable schoolid, Typeable courseid
- ) => PersistFieldSql (WorkflowScope termid schoolid courseid) where
- sqlType _ = sqlTypeJSON
-
-derivePersistFieldJSON ''WorkflowScope'
-
-instance ( ToJSON fileid, ToJSON userid
- , FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- ) => PersistField (WorkflowState fileid userid) where
- toPersistValue = toPersistValueJSON
- fromPersistValue = fromPersistValueJSON
-instance ( ToJSON fileid, ToJSON userid
- , FromJSON fileid, FromJSON userid
- , Ord fileid, Ord userid
- , Typeable fileid, Typeable userid
- ) => PersistFieldSql (WorkflowState fileid userid) where
- sqlType _ = sqlTypeJSON
-
-
------ Binary instances -----
-
-instance Binary WorkflowScope'
-instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)
-
-instance Binary userid => Binary (WorkflowRole userid)
-
-instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowAction fileid userid)
-instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowFieldPayloadW fileid userid) where
- get = Binary.get >>= \case
- WFPText' -> WorkflowFieldPayloadW . WFPText <$> Binary.get
- WFPNumber' -> WorkflowFieldPayloadW . WFPNumber <$> Binary.get
- WFPBool' -> WorkflowFieldPayloadW . WFPBool <$> Binary.get
- WFPDay' -> WorkflowFieldPayloadW . WFPDay <$> Binary.get
- WFPTime' -> WorkflowFieldPayloadW . WFPTime <$> Binary.get
- WFPDateTime' -> WorkflowFieldPayloadW . WFPDateTime <$> Binary.get
- WFPFile' -> WorkflowFieldPayloadW . WFPFile <$> Binary.get
- WFPUser' -> WorkflowFieldPayloadW . WFPUser <$> Binary.get
- put = \case
- WorkflowFieldPayloadW (WFPText t ) -> Binary.put WFPText' >> Binary.put t
- WorkflowFieldPayloadW (WFPNumber n ) -> Binary.put WFPNumber' >> Binary.put n
- WorkflowFieldPayloadW (WFPBool b ) -> Binary.put WFPBool' >> Binary.put b
- WorkflowFieldPayloadW (WFPDay d ) -> Binary.put WFPDay' >> Binary.put d
- WorkflowFieldPayloadW (WFPTime t ) -> Binary.put WFPTime' >> Binary.put t
- WorkflowFieldPayloadW (WFPDateTime t) -> Binary.put WFPDateTime' >> Binary.put t
- WorkflowFieldPayloadW (WFPFile fid) -> Binary.put WFPFile' >> Binary.put fid
- WorkflowFieldPayloadW (WFPUser uid) -> Binary.put WFPUser' >> Binary.put uid
-
-
------ TH Jail -----
-
-makeWrapped ''WorkflowGraphReference
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 59f8266fa..d21cd8f63 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -253,21 +253,6 @@ makeLenses_ ''Rating'
makeLenses_ ''FallbackPersonalisedSheetFilesKey
-makeLenses_ ''WorkflowDefinition
-makeLenses_ ''WorkflowDefinitionDescription
-makeLenses_ ''WorkflowDefinitionInstanceDescription
-makeLenses_ ''WorkflowScope
-makeLenses_ ''WorkflowInstance
-makeLenses_ ''WorkflowInstanceDescription
-makeLenses_ ''WorkflowWorkflow
-makeLenses_ ''WorkflowPayloadTextPreset
-
-makeLenses_ ''WorkflowGraph
-makeLenses_ ''WorkflowGraphNode
-
-makeLenses_ ''WorkflowGraphEdge
-makePrisms ''WorkflowGraphEdge
-
makeWrapped ''Textarea
makeLenses_ ''SentMail
diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs
deleted file mode 100644
index 9fe28aab5..000000000
--- a/src/Utils/Workflow.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-module Utils.Workflow
- ( RouteWorkflowScope, DBWorkflowScope, IdWorkflowScope, CryptoIDWorkflowScope
- , _DBWorkflowScope
- , fromRouteWorkflowScope, toRouteWorkflowScope
- , DBWorkflowGraph, IdWorkflowGraph
- , _DBWorkflowGraph
- , DBWorkflowState, IdWorkflowState
- , _DBWorkflowState
- , DBWorkflowAction, IdWorkflowAction
- , decryptWorkflowStateIndex, encryptWorkflowStateIndex
- , isTopWorkflowScope, isTopWorkflowScopeSql
- , selectWorkflowInstanceDescription
- , SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
- , insertSharedWorkflowGraph
- , getWorkflowWorkflowState', getWorkflowWorkflowState
- , WorkflowWorkflowStateParseException(..)
- ) where
-
-import Import.NoFoundation
-import Foundation.Type
-
-import qualified Data.CryptoID.Class.ImplicitNamespace as I
-import qualified Crypto.MAC.KMAC as Crypto
-import qualified Data.ByteArray as BA
-import qualified Data.Binary as Binary
-import Crypto.Hash.Algorithms (SHAKE256)
-import qualified Crypto.Hash as Crypto
-import Language.Haskell.TH (nameBase)
-import qualified Data.Aeson as Aeson
-
-import Handler.Utils.Memcached
-
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-import qualified Database.Esqueleto.Internal.Internal as E
-
-{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
-
-
-type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
-type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
-type IdWorkflowScope = WorkflowScope TermId SchoolId CourseId
-type CryptoIDWorkflowScope = WorkflowScope TermId SchoolId CryptoUUIDCourse
-
-
-_DBWorkflowScope :: Iso' IdWorkflowScope DBWorkflowScope
-_DBWorkflowScope = iso toScope' toScope
- where
- toScope' scope = scope
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolId CourseId)) unTermKey
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolShorthand CourseId)) unSchoolKey
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand CourseId) @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @CourseId @SqlBackendKey) (view _SqlKey)
- toScope scope' = scope'
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolShorthand SqlBackendKey)) TermKey
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
- & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
-
-fromRouteWorkflowScope :: ( MonadHandler m
- , BackendCompatible SqlReadBackend backend
- )
- => RouteWorkflowScope
- -> MaybeT (ReaderT backend m) IdWorkflowScope
-fromRouteWorkflowScope rScope = $cachedHereBinary rScope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-
-toRouteWorkflowScope :: ( MonadHandler m
- , BackendCompatible SqlReadBackend backend
- )
- => IdWorkflowScope
- -> MaybeT (ReaderT backend m) RouteWorkflowScope
-toRouteWorkflowScope scope = $cachedHereBinary scope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
-
-
-type IdWorkflowGraph = WorkflowGraph FileReference UserId
-type DBWorkflowGraph = WorkflowGraph FileReference SqlBackendKey
-
-
-_DBWorkflowGraph :: Iso' IdWorkflowGraph DBWorkflowGraph
-_DBWorkflowGraph = iso toDB fromDB
- where
- toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
- fromDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference SqlBackendKey) @(WorkflowGraph FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
-
-
-type IdWorkflowState = WorkflowState FileReference UserId
-type DBWorkflowState = WorkflowState FileReference SqlBackendKey
-
-
-_DBWorkflowState :: Iso' IdWorkflowState DBWorkflowState
-_DBWorkflowState = iso toDB fromDB
- where
- 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
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (Exception)
-
-workflowStateIndexCryptoIDKey :: (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => WorkflowWorkflowId -> m CryptoIDKey
-workflowStateIndexCryptoIDKey wwId = cryptoIDKey $ \cIDKey -> either (const $ throwM WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
- Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'workflowStateIndexCryptoIDKey) (toStrict $ Binary.encode wwId) cIDKey
-
-encryptWorkflowStateIndex :: ( MonadCrypto m
- , MonadCryptoKey m ~ CryptoIDKey
- , MonadHandler m
- )
- => WorkflowWorkflowId -> WorkflowStateIndex -> m CryptoUUIDWorkflowStateIndex
-encryptWorkflowStateIndex wwId stIx = do
- cIDKey <- workflowStateIndexCryptoIDKey wwId
- $cachedHereBinary (wwId, stIx) . flip runReaderT cIDKey $ I.encrypt stIx
-
-decryptWorkflowStateIndex :: ( MonadCrypto m
- , MonadCryptoKey m ~ CryptoIDKey
- , MonadHandler m
- )
- => WorkflowWorkflowId -> CryptoUUIDWorkflowStateIndex -> m WorkflowStateIndex
-decryptWorkflowStateIndex wwId cID = do
- cIDKey <- workflowStateIndexCryptoIDKey wwId
- $cachedHereBinary (wwId, cID) . flip runReaderT cIDKey $ I.decrypt cID
-
-
-isTopWorkflowScope :: WorkflowScope termid schoolid courseid -> Bool
-isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScope
-
-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'
-
-
-data SharedWorkflowGraphException
- = SharedWorkflowGraphNotFound SharedWorkflowGraphId
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (Exception)
-
-getSharedDBWorkflowGraph :: ( MonadHandler m
- , BackendCompatible SqlReadBackend backend
- )
- => SharedWorkflowGraphId
- -> ReaderT backend m DBWorkflowGraph
-getSharedDBWorkflowGraph swgId = $cachedHereBinary swgId . withReaderT (projectBackend @SqlReadBackend) $ do
- maybe (liftHandler . throwM $ SharedWorkflowGraphNotFound swgId) (return . sharedWorkflowGraphGraph) =<< get swgId
-
-getSharedIdWorkflowGraph :: ( MonadHandler m
- , BackendCompatible SqlReadBackend backend
- )
- => SharedWorkflowGraphId
- -> ReaderT backend m IdWorkflowGraph
-getSharedIdWorkflowGraph = fmap (review _DBWorkflowGraph) . getSharedDBWorkflowGraph
-
-insertSharedWorkflowGraph :: ( MonadIO m
- , BackendCompatible SqlBackend backend
- )
- => DBWorkflowGraph
- -> ReaderT backend m SharedWorkflowGraphId
-insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
- swgId' <$ repsert swgId' (SharedWorkflowGraph swgId graph)
- where
- swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
- swgId' = SharedWorkflowGraphKey swgId
-
-
-newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue
- deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
- deriving anyclass (Binary)
-
-newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text
- deriving stock (Show, Generic, Typeable)
- deriving anyclass (Exception)
-
-getWorkflowWorkflowState' :: forall backend m.
- ( MonadHandler m, HandlerSite m ~ UniWorX
- , BackendCompatible SqlReadBackend backend
- , MonadThrow m
- )
- => WorkflowWorkflowId
- -> Maybe WorkflowWorkflow
- -> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
-getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do
- res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do
- E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId
- return
- ( workflowWorkflow E.^. WorkflowWorkflowInstance
- , workflowWorkflow E.^. WorkflowWorkflowScope
- , workflowWorkflow E.^. WorkflowWorkflowGraph
- , E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState
- )
- let
- ( E.Value workflowWorkflowInstance
- , E.Value workflowWorkflowScope
- , E.Value workflowWorkflowGraph
- , E.Value (wwState :: PersistValue) -- Don't parse
- ) = res
- wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState
- case wwState' of
- Left err -> lift . throwM $ WorkflowWorkflowStateParseException err
- Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..}
-getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do
- memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState
-
-getWorkflowWorkflowState :: forall backend m.
- ( MonadHandler m, HandlerSite m ~ UniWorX
- , BackendCompatible SqlReadBackend backend
- , MonadThrow m
- )
- => WorkflowWorkflowId
- -> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
-getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing
diff --git a/src/Utils/Workflow/Lint.hs b/src/Utils/Workflow/Lint.hs
deleted file mode 100644
index 581ebaa4e..000000000
--- a/src/Utils/Workflow/Lint.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-module Utils.Workflow.Lint
- ( lintWorkflowGraph
- , WorkflowGraphLinterIssue(..)
- ) where
-
-import Import.NoFoundation
-
-import qualified Data.Set as Set
-import qualified Data.MultiSet as MultiSet
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
-
-
-{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
-
-
-data WorkflowGraphLinterIssue
- = WGLUnknownGraphNodeLabel WorkflowGraphNodeLabel
- | WGLPayloadInvisibleInTargetNode (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) WorkflowPayloadLabel
- | WGLFinalNodeHasOutgoingEdges WorkflowGraphNodeLabel | WGLNonFinalNodeHasNoOutgoingEdges WorkflowGraphNodeLabel
- | WGLUndefinedFieldOrder (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (NonNull (MultiSet WorkflowPayloadLabel))
- | WGLNodeUnreachable WorkflowGraphNodeLabel
- | WGLNodeUnfinalizable WorkflowGraphNodeLabel
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-instance Exception WorkflowGraphLinterIssue where
- displayException = \case
- WGLUnknownGraphNodeLabel nodeLbl
- -> unpack [st|Unknown GraphNodeLabel: #{tshow (toPathPiece nodeLbl)}|]
- WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl
- -> unpack [st|Payload #{tshow (toPathPiece payloadLbl)} has form on edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} but no viewers on target node|]
- WGLFinalNodeHasOutgoingEdges nodeLbl
- -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is marked “final” but has outgoing edges|]
- WGLNonFinalNodeHasNoOutgoingEdges nodeLbl
- -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} isn't marked “final” but has no outgoing edges|]
- WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloads
- -> unpack [st|Form for edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} has ill defined field order for payload(s): “#{intercalate ", " (map (tshow . toPathPiece) (MultiSet.elems (toNullable payloads)))}”|]
- WGLNodeUnreachable nodeLbl
- -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is unreachable from all initial edges|]
- WGLNodeUnfinalizable nodeLbl
- -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} has no path to a final node|]
-
-lintWorkflowGraph :: forall fileid userid. WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue))
-lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph)
- [ checkEdgesForUnknownGraphNodeLabel
- , checkFormPayloadVisibleInTargetNode -- TODO: Satisfiability of automatic edges?
- , finalMatchesOutgoingEdges
- , checkUndefinedFieldOrder
- , checkNodeUnreachable -- TODO: Satisfiability of automatic edges
- , checkNodeUnfinalizable -- TODO: Satisfiability of automatic edges
- -- Future ideas:
- -- - WorkflowRolePayloadReference for unknown payload
- -- - wgePayloadRestriction for unknown payload
- -- - FieldReference for payload not defined in same form
- -- - WorkflowRolePayloadReference to payload without user fields
- -- - all initial edges have only payload-reference
- -- - cycles of automatic edges (also consider payload restrictions; computationally equivalent to SAT)
- -- - unsatisfiable restrictions
- ]
- where
- checkEdgesForUnknownGraphNodeLabel WorkflowGraph{wgNodes} = foldMap (pure . WGLUnknownGraphNodeLabel) $ Set.fromList edgeNodeLabels `Set.difference` Map.keysSet wgNodes
- where
- edges = foldMap (Map.elems . wgnEdges) wgNodes
- edgeNodeLabels = flip foldMap edges $ \case
- WorkflowGraphEdgeManual{wgeSource} -> pure wgeSource
- WorkflowGraphEdgeAutomatic{wgeSource} -> pure wgeSource
- WorkflowGraphEdgeInitial{} -> []
- checkFormPayloadVisibleInTargetNode WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbl) -> WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl) . Set.toList $ doCheck node) wgNodes
- where
- doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, WorkflowPayloadLabel)
- doCheck WGN{wgnEdges, wgnPayloadView} = ifoldMap (\edgeLbl -> Set.map (edgeLbl, ) . doCheck') wgnEdges
- where
- doCheck' :: WorkflowGraphEdge fileid userid -> Set WorkflowPayloadLabel
- doCheck' wge = fromMaybe Set.empty $ do
- WorkflowGraphEdgeForm{wgefFields} <- wge ^? _wgeForm
- return $ Map.keysSet wgefFields `Set.difference` Map.keysSet wgnPayloadView
- finalMatchesOutgoingEdges WorkflowGraph{wgNodes} = foldMap (\nodeLbl -> pure $ bool WGLFinalNodeHasOutgoingEdges WGLNonFinalNodeHasNoOutgoingEdges (nodeLbl `Set.notMember` markedFinalNodes) nodeLbl) $ markedFinalNodes `setSymmDiff` edgeFinalNodes
- where
- markedFinalNodes = Set.fromList $ do
- (nodeLbl, WGN{wgnFinal}) <- Map.toList wgNodes
- guard $ is _Just wgnFinal
- return nodeLbl
- edgeFinalNodes = Set.fromList $ do
- nodeLbl <- Map.keys wgNodes
- guard $ noneOf (folded . _wgnEdges . folded . _wgeSource) (== nodeLbl) wgNodes
- return nodeLbl
- checkUndefinedFieldOrder WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbls) -> WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloadLbls) . Set.toList $ doCheck node) wgNodes
- where
- doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, NonNull (MultiSet WorkflowPayloadLabel))
- doCheck WGN{wgnEdges} = ifoldMap (\edgeLbl -> foldMap (Set.singleton . (edgeLbl, )) . doCheck') wgnEdges
- where
- doCheck' :: WorkflowGraphEdge fileid userid -> [NonNull (MultiSet WorkflowPayloadLabel)]
- doCheck' wge = do
- WorkflowGraphEdgeForm{wgefFields} <- hoistMaybe $ wge ^? _wgeForm
- let MergeMap orderMap = ifoldMap go wgefFields
- where
- go :: WorkflowPayloadLabel
- -> NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid))))
- -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
- go payloadLbl = foldMap (go' . Map.keysSet . toNullable) . Set.toList . toNullable
- where
- go' :: Set WorkflowGraphEdgeFormOrder
- -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
- go' = foldMap $ \formOrder -> MergeMap . Map.singleton formOrder . impureNonNull $ MultiSet.singleton payloadLbl
- filter ((> 1) . MultiSet.size . toNullable) $ Map.elems orderMap
- checkNodeUnreachable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnreachable) $ Map.keysSet wgNodes `Set.difference` reachableNodes
- where
- initialNodes = Map.keysSet $ Map.filter isInitial wgNodes
- where isInitial WGN{wgnEdges} = any (is _WorkflowGraphEdgeInitial) wgnEdges
- reachableNodes = extendAfter graph initialNodes
- checkNodeUnfinalizable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnfinalizable) $ Map.keysSet wgNodes `Set.difference` finalizableNodes
- where
- finalNodes = Map.keysSet $ Map.filter (has $ _wgnFinal . _Just) wgNodes
- finalizableNodes = extendBefore graph finalNodes
-
-extendAfter, extendBefore :: forall fileid userid. WorkflowGraph fileid userid -> Set WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel
-extendAfter WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
- where
- go :: Set WorkflowGraphNodeLabel -- ^ Already known reachable
- -> Seq WorkflowGraphNodeLabel -- ^ Queue to check
- -> Set WorkflowGraphNodeLabel
- go known Seq.Empty = known
- go known (n Seq.:<| ns)
- | n `Set.member` known = go known ns
- | otherwise = go (Set.insert n known) $ ns `searchStrategy` nextNodes
- where nextNodes = Map.keysSet $ Map.filter hasSource wgNodes
- hasSource WGN{wgnEdges} = anyOf (folded . _wgeSource) (== n) wgnEdges
-extendBefore WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
- where
- go :: Set WorkflowGraphNodeLabel
- -> Seq WorkflowGraphNodeLabel
- -> Set WorkflowGraphNodeLabel
- go known Seq.Empty = known
- go known (n Seq.:<| ns)
- | n `Set.member` known = go known ns
- | otherwise = go (Set.insert n known) $ ns `searchStrategy` prevNodes
- where
- prevNodes = flip foldMap (wgNodes Map.!? n) $ \WGN{wgnEdges} -> setOf (folded . _wgeSource) wgnEdges
-
-searchStrategy :: Seq WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel -> Seq WorkflowGraphNodeLabel
--- ^ BFS
-searchStrategy queue next = queue <> Seq.fromList (Set.toList next)
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index b57095456..1734b2f1b 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -33,31 +33,9 @@ import qualified Data.List as List (splitAt)
import qualified Data.Conduit.Combinators as C
-import qualified Data.Yaml as Yaml
-
-import Utils.Workflow
-import Utils.Workflow.Lint
-
-import System.Directory (getModificationTime, doesFileExist)
+import System.Directory (getModificationTime)
import System.FilePath.Glob (glob)
-import System.IO (hPutStrLn)
-
-import qualified Data.List.NonEmpty as NonEmpty
-
-
-data WorkflowIndexItem = WorkflowIndexItem
- { wiiGraphFile :: FilePath
- , wiiCategory :: Maybe WorkflowInstanceCategory
- , wiiDefinitionScope :: WorkflowScope'
- , wiiDefinitionDescription :: Maybe (I18n (Text, Maybe StoredMarkup))
- , wiiInstanceDescription :: Maybe (I18n (Text, Maybe StoredMarkup))
- , wiiInstances :: Set RouteWorkflowScope
- }
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''WorkflowIndexItem
-
testdataDir :: FilePath
testdataDir = "testdata"
@@ -1412,42 +1390,6 @@ fillDb = do
liftIO . LBS.writeFile (testdataDir "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities
- whenM (liftIO . doesFileExist $ testdataDir "workflows" "_index.yaml") $ do
- let displayLinterIssue :: MonadIO m => WorkflowGraphLinterIssue -> m ()
- displayLinterIssue = liftIO . hPutStrLn stderr . displayException
-
- wfIndex <- Yaml.decodeFileThrow @_ @(Map WorkflowDefinitionName WorkflowIndexItem) $ testdataDir "workflows" "_index.yaml"
-
- iforM_ wfIndex $ \wiName WorkflowIndexItem{..} -> handleSql displayLinterIssue $ do
- graph <- Yaml.decodeFileThrow $ testdataDir "workflows" wiiGraphFile
- for_ (lintWorkflowGraph graph) $ mapM_ throwM
- workflowDefinitionGraph <- insertSharedWorkflowGraph graph
- let workflowDef = WorkflowDefinition{..}
- where workflowDefinitionInstanceCategory = wiiCategory
- workflowDefinitionName = wiName
- workflowDefinitionScope = wiiDefinitionScope
- wdId <- insert workflowDef
- let descs = maybe Map.empty (\I18n{..} -> Map.insert (fromMaybe (NonEmpty.head appLanguages) i18nFallbackLang) i18nFallback i18nTranslations) wiiDefinitionDescription
- iDescs = maybe Map.empty (\I18n{..} -> Map.insert (fromMaybe (NonEmpty.head appLanguages) i18nFallbackLang) i18nFallback i18nTranslations) wiiInstanceDescription
- iforM_ descs $ \workflowDefinitionDescriptionLanguage (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription) ->
- let workflowDefinitionDescriptionDefinition = wdId
- in insert_ WorkflowDefinitionDescription{..}
- iforM_ iDescs $ \workflowDefinitionInstanceDescriptionLanguage (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription) ->
- let workflowDefinitionInstanceDescriptionDefinition = wdId
- in insert_ WorkflowDefinitionInstanceDescription{..}
- forM_ wiiInstances $ \rScope -> do
- dbScope <- fmap (view _DBWorkflowScope) . maybeT (error $ "Could not resolve scope: " <> show rScope) $ fromRouteWorkflowScope rScope
- wiId <-
- let workflowInstanceDefinition = Just wdId
- workflowInstanceGraph = workflowDefinitionGraph
- workflowInstanceScope = dbScope
- workflowInstanceName = workflowDefinitionName workflowDef
- workflowInstanceCategory = workflowDefinitionInstanceCategory workflowDef
- in insert WorkflowInstance{..}
- iforM_ iDescs $ \workflowInstanceDescriptionLanguage (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription) ->
- let workflowInstanceDescriptionInstance = wiId
- in insert_ WorkflowInstanceDescription{..}
-
forM_ universeF $ \changelogItem -> do
let ptn = "templates/i18n/changelog/" <> unpack (toPathPiece changelogItem) <> ".*"
files <- liftIO $ glob ptn
diff --git a/wflint.sh b/wflint.sh
deleted file mode 100755
index a21f22c47..000000000
--- a/wflint.sh
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/usr/bin/env bash
-
-set -e
-
-[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
-
-stack build --fast --flag uniworx:-library-only --flag uniworx:dev
-
-stack exec uniworx-wflint -- $@
diff --git a/wflint/WFLint.hs b/wflint/WFLint.hs
deleted file mode 100644
index 38b86fb54..000000000
--- a/wflint/WFLint.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module WFLint
- ( main
- ) where
-
-import Import
-import Utils.Workflow.Lint
-import Handler.Utils.Workflow.Form (FormWorkflowGraph)
-
-import qualified Data.ByteString as ByteString
-import qualified Data.Yaml as Yaml
-
-import System.IO (hPutStrLn)
-import System.Exit
-
-
-exitParseError, exitLintIssues :: Int
-exitParseError = 2
-exitLintIssues = 3
-
-die' :: (MonadIO m, Exception (Element mono), MonoFoldable mono) => Handle -> Int -> mono -> m a
-die' h err excs = liftIO $ do
- forM_ excs $ hPutStrLn h . displayException
- exitWith $ ExitFailure err
-
-main :: IO ()
-main = do
- mwf <- Yaml.decodeEither' <$> ByteString.getContents
- (wf :: FormWorkflowGraph) <- either (die' stderr exitParseError . Identity) return mwf
- for_ (lintWorkflowGraph wf) $ die' stdout exitLintIssues