- #{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/DateTime.hs b/src/Model/Types/DateTime.hs
index 8f9a3bd28..c5f7324a4 100644
--- a/src/Model/Types/DateTime.hs
+++ b/src/Model/Types/DateTime.hs
@@ -13,8 +13,11 @@ import Import.NoModel
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
+import Data.Either.Combinators (maybeToRight)
import Text.Read (readMaybe)
+import Data.Time.Calendar.WeekDate
+
import Database.Persist.Sql
import Web.HttpApiData
@@ -25,19 +28,29 @@ import Data.Aeson.Types as Aeson
----
-- Terms, Seaons, anything loosely related to time
-data Season = Summer | Winter
+data Season = Q1 | Q2 | Q3 | Q4
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
deriving anyclass (Binary, Universe, Finite, NFData)
-seasonToChar :: Season -> Char
-seasonToChar Summer = 'S'
-seasonToChar Winter = 'W'
+numSeasons :: Int -- to be flexible
+numSeasons = succ $ fromEnum(maxBound::Season)
-seasonFromChar :: Char -> Either Text Season
-seasonFromChar c
- | c ~= 'S' = Right Summer
- | c ~= 'W' = Right Winter
- | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
+seasonFromText' :: Text -> Either Text Season
+seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
+ where
+ errmsg = "Invalid season: ‘" <> tshow t <> "’"
+
+seasonFromText :: Text -> Either Text Season
+seasonFromText t
+ | Just (q, ne) <- Text.uncons t
+ , q ~= 'Q'
+ , Just (n, e) <- Text.uncons ne
+ , Text.null e = case n of '1' -> Right Q1
+ '2' -> Right Q2
+ '3' -> Right Q3
+ '4' -> Right Q4
+ _ -> Left $ "Invalid quarter number: ‘" <> tshow t <> "’"
+ | otherwise = Left $ "Invalid season: ‘" <> tshow t <> "’"
where
(~=) :: Char -> Char -> Bool
(~=) = (==) `on` CI.mk
@@ -50,8 +63,8 @@ data TermIdentifier = TermIdentifier
instance Enum TermIdentifier where
-- ^ Do not use for conversion – Enumeration only
- toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
- fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
+ toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..}
+ fromEnum TermIdentifier{..} = fromInteger year * numSeasons + fromEnum season
-- Conversion TermId <-> TermIdentifier::
-- from_TermId_to_TermIdentifier = unTermKey
@@ -82,32 +95,31 @@ shortened = iso shorten expand
| otherwise = year
termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
+termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season
-- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier
termFromText t
- | (s:ys) <- Text.unpack t
- , Just (review shortened -> year) <- readMaybe ys
- , Right season <- seasonFromChar s
+ | (ys,s) <- Text.break (~= 'Q') t
+ , Right season <- seasonFromText s
+ , Just (review shortened -> year) <- readMaybe $ Text.unpack ys
= Right TermIdentifier{..}
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
+ where
+ (~=) :: Char -> Char -> Bool
+ (~=) = (==) `on` CI.mk
termToRational :: TermIdentifier -> Rational
-termToRational TermIdentifier{..} = fromInteger year + seasonOffset
+termToRational TermIdentifier{..} = toRational year + seasonOffset
where
- seasonOffset
- | Summer <- season = 0
- | Winter <- season = 0.5
+ seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
termFromRational :: Rational -> TermIdentifier
termFromRational n = TermIdentifier{..}
where
- year = floor n
- remainder = n - fromInteger (floor n)
- season
- | remainder == 0 = Summer
- | otherwise = Winter
+ year = floor n
+ remainder = n - fromInteger (floor n) -- properFraction problematic for negative year values
+ season = toEnum $ floor $ remainder * fromIntegral numSeasons
instance PersistField TermIdentifier where
toPersistValue = PersistRational . termToRational
@@ -141,9 +153,31 @@ pathPieceCsv ''TermIdentifier
See Handler.Utils.Form.termsField and termActiveField
-}
+data TermDay
+ = TermDayStart | TermDayEnd
+ | TermDayLectureStart | TermDayLectureEnd
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
-withinTerm :: Day -> TermIdentifier -> Bool
-time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
+guessDay :: TermIdentifier
+ -> TermDay
+ -> Day
+guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1
+guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1
+guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
+guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
+guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
+guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
+ where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
+guessDay tid TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
+ where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
+
+withinTerm :: Day -> TermIdentifier -> Bool
+withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
+
+-- | Check only if last two digits within the year numbers match
+withinTermYear :: Day -> TermIdentifier -> Bool
+time `withinTermYear` term = timeYear `mod` 100 == termYear `mod` 100
where
timeYear = fst3 $ toGregorian time
termYear = year term
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/Holidays.hs b/src/Utils/Holidays.hs
new file mode 100644
index 000000000..71235acf6
--- /dev/null
+++ b/src/Utils/Holidays.hs
@@ -0,0 +1,123 @@
+{-|
+Module: Utils.Holidays
+Description: German bank holidays
+
+Following module Data.Time.Calendar.BankHoliday.EnglandAndWales
+-}
+module Utils.Holidays
+ ( Feiertagsgebiet(..)
+ , feiertage
+ , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
+ , isBankHoliday, isBankHolidayArea
+ ) where
+
+import Import.NoModel
+
+import qualified Data.Set as Set (Set, member, unions)
+import qualified Data.Map as Map
+
+--import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.Easter (gregorianEaster)
+
+
+-- | Some areas / companies within Germany.
+-- | The datatype is not yet complete.
+data Feiertagsgebiet = Deutschland | Hessen | Bayern | Munich | Fraport
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+-- | List the bank holidays for the given year >= 1995, in ascending order.
+-- | Holidays on a weekend are legally considered holidays in some German states, hence
+-- | the behaviour differs from Data.Time.Calendar.BankHoliday.EnglandAndWales by including holidays on Sundays.
+-- | Included for compatibility with Data.Time.Calendar.BankHoliday.EnglandAndWales
+bankHolidays :: Integer -> [Day]
+bankHolidays = bankHolidaysArea Deutschland
+
+-- | Bank holidays for a region within Germany and a given year >= 1995.
+-- | Holidays may occur on a sunday.
+-- | For convenience and compatibility.
+bankHolidaysArea :: Feiertagsgebiet -> Integer -> [Day]
+bankHolidaysArea land year = Map.keys $ feiertage land year
+
+-- | Bank holidays for a region within Germany and a given year >= 1995.
+-- | Holidays may occur on a sunday.
+bankHolidaysAreaSet :: Feiertagsgebiet -> Integer -> Set.Set Day
+bankHolidaysAreaSet land year = Map.keysSet $ feiertage land year
+
+-- | Bank holidays for a region within Germany and a given year >= 1995,
+-- | mapped to the german name of each day.
+-- | Holidays may occur on a sunday.
+feiertage :: Feiertagsgebiet -> Integer -> Map.Map Day String
+feiertage land year = case land of
+ Deutschland -> standardHolidays
+ Bayern -> bavarianHolidays
+ Munich -> munichHolidays
+ Hessen -> hessianHolidays
+ Fraport -> fraportHolidays
+ where
+ easterSunday = gregorianEaster year
+ easterSundayPlus = flip addDays easterSunday
+
+ standardHolidays = Map.fromList
+ [ (fromGregorian year 1 1, "Neujahr")
+ , (easterSundayPlus (-2) , "Karfreitag")
+ , (easterSunday , "Ostersonntag")
+ , (easterSundayPlus 1 , "Ostermontag")
+ , (fromGregorian year 5 1, "Erster Mai")
+ , (easterSundayPlus 39 , "Himmelfahrt")
+ , (easterSundayPlus 49 , "Pfingstsonntag")
+ , (easterSundayPlus 50 , "Pfingstmontag")
+ , (fromGregorian year 10 3, "Tag der deutschen Einheit")
+ , (fromGregorian year 12 25, "Erster Weihnachtstag")
+ , (fromGregorian year 12 26, "Zweiter Weihnachtstag")
+ ]
+
+ hessianHolidays = standardHolidays <> map_singleton
+ (easterSundayPlus 60 , "Fronleichnam")
+
+ bavarianHolidays = hessianHolidays <> Map.fromList
+ [ (fromGregorian year 1 6, "Heilige Drei Könige")
+ , (fromGregorian year 11 1, "Allerheiligen")
+ ]
+
+ munichHolidays = bavarianHolidays <> map_singleton
+ (fromGregorian year 8 15, "Maria Himmelfahrt")
+
+ fraportHolidays = hessianHolidays <> Map.fromList
+ [ (fromGregorian year 12 24, "Heiligabend")
+ , (fromGregorian year 12 31, "Sylvester")
+ ]
+
+ map_singleton = uncurry Map.singleton
+
+-- | For compatibility with with Data.Time.Calendar.BankHoliday.EnglandAndWales
+-- | only for works for year >= 1995
+isBankHoliday :: Day -> Bool
+isBankHoliday = isBankHolidayArea Deutschland
+
+{-- Inefficient, since entire year of holidays is computed for each call
+isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
+isBankHolidayArea land dd = dd `Set.member` holidays
+ where
+ (year, _, _) = toGregorian dd
+ holidays = bankHolidaysAreaSet land year
+-}
+
+-- | Returns whether a day is a bank holiday for years >= 1995
+-- | Repeated calls are handled efficiently using a lazy cache for 2020--2075
+isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
+isBankHolidayArea land dd = dd `Set.member` holidays
+ where
+ (year, _, _) = toGregorian dd
+ holidays
+ | year >= cacheMinYear
+ , year <= cacheMaxYear
+ , (Just hds) <- Map.lookup land cacheHolidays = hds
+ | otherwise = bankHolidaysAreaSet land year
+
+cacheMinYear, cacheMaxYear :: Integer
+cacheMinYear = 2020
+cacheMaxYear = 2075
+
+cacheHolidays :: Map.Map Feiertagsgebiet (Set.Set Day)
+cacheHolidays = Map.fromList [ (land, Set.unions $ bankHolidaysAreaSet land <$> [cacheMinYear..cacheMaxYear]) | land <- universeF ]
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/src/index.md b/src/index.md
index 4dceca669..c796619da 100644
--- a/src/index.md
+++ b/src/index.md
@@ -33,6 +33,9 @@ Utils.DateTime
: Template Haskell code-generatoren zum compile-time einbinden von Zeitzone
und `TimeLocale`
+Utils.Holidays
+ : Definition deutscher Feiertage
+
Handler.Utils, Handler.Utils.*
: Hilfsfunktionien, importieren `Import`
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index c793ec982..ed4c8c55e 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -12,7 +12,7 @@ import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.Map as Map
-import Data.Time.Calendar.OrdinalDate
+-- import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Control.Applicative (ZipList(..))
@@ -33,34 +33,11 @@ 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, doesDirectoryExist)
+import System.Directory (getModificationTime, doesDirectoryExist)
import System.FilePath.Glob (glob)
-import System.IO (hPutStrLn)
-
-import qualified Data.List.NonEmpty as NonEmpty
-
import Paths_uniworx (getDataFileName)
-
-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
-
-
testdataFile :: MonadIO m => FilePath -> m FilePath
testdataFile = liftIO . getDataFileName . ("testdata" )
@@ -81,48 +58,31 @@ fillDb = do
(currentYear, currentMonth, _) = toGregorian $ utctDay now
currentTerm
- | 4 <= currentMonth
- , currentMonth <= 9
- = TermIdentifier currentYear Summer
- | otherwise
- = TermIdentifier (pred currentYear) Winter
+ | 3 >= currentMonth = TermIdentifier currentYear Q1
+ | 6 >= currentMonth = TermIdentifier currentYear Q2
+ | 9 >= currentMonth = TermIdentifier currentYear Q3
+ | otherwise = TermIdentifier currentYear Q4
nextTerm = succ currentTerm
prevTerm = pred currentTerm
prevPrevTerm = pred prevTerm
- seasonTerm next wSeason
- | wSeason == season currentTerm
- , next = currentTerm
- | wSeason == season currentTerm
- = prevPrevTerm
- | next
- = nextTerm
- | otherwise
- = prevTerm
+ seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
+ where prog | next = succ
+ | otherwise = pred
termTime :: Bool -- ^ Next term?
-> Season
-> Rational
-> Bool -- ^ Relative to end of semester?
-> WeekDay
- -> (Day -> UTCTime)
+ -> (Day -> UTCTime) -- ^ Add time to day
-> UTCTime
termTime next gSeason weekOffset fromEnd d = ($ utctDay)
where
utctDay = fromWeekDate wYear wWeek $ fromEnum d
- (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian gYear rMonth rDay
- gYear = year $ seasonTerm next gSeason
- (rMonth, rDay)
- | Winter <- gSeason
- , True <- fromEnd
- = (03, 31)
- | Winter <- gSeason
- , False <- fromEnd
- = (10, 01)
- | True <- fromEnd
- = (09, 30)
- | otherwise
- = (04, 01)
+ (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay
+ gTid = seasonTerm next gSeason
+ (rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd
gkleen <- insert User
{ userIdent = "G.Kleen@campus.lmu.de"
@@ -196,7 +156,7 @@ fillDb = do
, userTitle = Just "Dr."
, userMaxFavourites = 14
, userMaxFavouriteTerms = 4
- , userTheme = ThemeMossGreen
+ , userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
@@ -393,42 +353,18 @@ fillDb = do
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
+
+ forM_ [(pred $ pred prevPrevTerm)..(succ $ succ $ succ $ succ nextTerm)] $ \tid -> do
+ let term = Term { termName = tid
+ , termStart = guessDay tid TermDayStart
+ , termEnd = guessDay tid TermDayEnd
+ , termHolidays = []
+ , termLectureStart = guessDay tid TermDayLectureStart
+ , termLectureEnd = guessDay tid TermDayLectureEnd
+ }
+ void $ repsert (TermKey tid) term
+ void . insert_ $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
- forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm] $ \term@TermIdentifier{..} -> case season of
- Summer -> do
- let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
- termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
- termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
- termStart = fromGregorian year 04 01
- termEnd = fromGregorian year 09 30
- void . repsert (TermKey term) $ Term
- { termName = term
- , termStart
- , termEnd
- , termHolidays = []
- , termLectureStart
- , termLectureEnd
- }
- void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
- Winter -> do
- let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
- termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
- (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
- termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
- longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
- (_, 53, _) -> True
- _other -> False
- termStart = fromGregorian year 10 01
- termEnd = fromGregorian (succ year) 03 31
- void . repsert (TermKey term) $ Term
- { termName = term
- , termStart
- , termEnd
- , termHolidays = []
- , termLectureStart
- , termLectureEnd
- }
- void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
ifiAuthorshipStatement <- insertAuthorshipStatement I18n
{ i18nFallback = htmlToStoredMarkup
[shamlet|
@@ -456,6 +392,8 @@ fillDb = do
}
ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
+ avn <- insert' $ School "Fahrschule" "AVN-A" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
+ void . insert' $ UserFunction jost avn SchoolAdmin
void . insert' $ UserFunction gkleen ifi SchoolAdmin
void . insert' $ UserFunction gkleen mi SchoolAdmin
void . insert' $ UserFunction fhamann ifi SchoolAdmin
@@ -470,10 +408,12 @@ fillDb = do
void . insert' $ UserFunction gkleen ifi SchoolAllocation
void . insert' $ UserFunction sbarth ifi SchoolLecturer
void . insert' $ UserFunction sbarth ifi SchoolExamOffice
- for_ [gkleen, fhamann, jost, maxMuster, svaupel] $ \uid ->
+ for_ [gkleen, fhamann, maxMuster, svaupel] $ \uid ->
void . insert' $ UserSchool uid ifi False
for_ [gkleen, tinaTester] $ \uid ->
void . insert' $ UserSchool uid mi False
+ for_ [jost] $ \uid ->
+ void . insert' $ UserSchool uid avn False
let
sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88
@@ -640,7 +580,132 @@ fillDb = do
now
True
Nothing
-
+
+
+ -- Fahrschule F
+ fdf <- insert' Course
+ { courseName = "F - Vorfeldführerschein"
+ , courseDescription = Just $ htmlToStoredMarkup [shamlet|
+
+ Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.
+
+ Benötigte Unterlagen
+
+ - Sehtest
+ (Bitte vorab hochladen!)
+
- Regulärer Führerschein
+ |]
+ , courseLinkExternal = Nothing
+ , courseShorthand = "F"
+ , courseTerm = TermKey currentTerm
+ , courseSchool = avn
+ , courseCapacity = Nothing
+ , courseVisibleFrom = Just now
+ , courseVisibleTo = Nothing
+ , courseRegisterFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
+ , courseRegisterTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
+ , courseDeregisterUntil = Nothing
+ , courseRegisterSecret = Nothing
+ , courseMaterialFree = True
+ , courseApplicationsRequired = False
+ , courseApplicationsInstructions = Nothing
+ , courseApplicationsText = False
+ , courseApplicationsFiles = NoUpload
+ , courseApplicationsRatingsVisible = False
+ , courseDeregisterNoShow = True
+ }
+ insert_ $ CourseEdit jost now fdf
+ void $ insert Sheet
+ { sheetCourse = fdf
+ , sheetName = "Sehtest"
+ , sheetDescription = Just $ htmlToStoredMarkup [shamlet|Bitte einen Scan ihres Sehtest hochladen!|]
+ , sheetType = NotGraded
+ , sheetGrouping = Arbitrary 3
+ , sheetMarkingText = Nothing
+ , sheetVisibleFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
+ , sheetActiveTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
+ , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
+ , sheetHintFrom = Nothing
+ , sheetSolutionFrom = Nothing
+ , sheetAutoDistribute = False
+ , sheetAnonymousCorrection = True
+ , sheetRequireExamRegistration = Nothing
+ , sheetAllowNonPersonalisedSubmission = True
+ , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam
+ , sheetAuthorshipStatementExam = Nothing
+ , sheetAuthorshipStatement = Nothing
+ }
+ forM_ [(Monday)..Thursday] $ \td -> do
+ forM_ [(1::Int)..(4*4)] $ \tw -> do
+ let firstTT = termTime True (season currentTerm) (toRational $ tw - 1) False td toMorning
+ secondTT = termTime True (season currentTerm) (toRational $ tw - 1) False (succ td) toMorning
+ regFrom = termTime True (season currentTerm) (toRational $ tw - 8) False td toMorning
+ regTo = termTime True (season currentTerm) (toRational $ tw - 2) False td toMorning
+ tut1 <- insert Tutorial
+ { tutorialName = CI.mk $ Text.pack $ "KW" ++ show (snd3 $ toWeekDate $ utctDay firstTT) ++ take 3 (show td)
+ , tutorialCourse = fdf
+ , tutorialType = "Schulung"
+ , tutorialCapacity = Just 16
+ , tutorialRoom = Just $ case tw `mod` 4 of
+ 1 -> "A380"
+ 2 -> "B747"
+ 3 -> "MD11"
+ _ -> "B777"
+ , tutorialRoomHidden = False
+ , tutorialTime = Occurrences
+ { occurrencesScheduled = Set.empty
+ , occurrencesExceptions = Set.fromList
+ [ ExceptOccur
+ { exceptDay = utctDay firstTT
+ , exceptStart = TimeOfDay 8 30 0
+ , exceptEnd = TimeOfDay 16 0 0
+ }
+ , ExceptOccur
+ { exceptDay = utctDay secondTT
+ , exceptStart = TimeOfDay 9 0 0
+ , exceptEnd = TimeOfDay 16 0 0
+ }
+ ]
+ }
+ , tutorialRegGroup = Just "schulung"
+ , tutorialRegisterFrom = Just regFrom
+ , tutorialRegisterTo = Just regTo
+ , tutorialDeregisterUntil = Nothing
+ , tutorialLastChanged = now
+ , tutorialTutorControlled = True
+ }
+ void . insert $ Tutor tut1 jost
+ void . insert' $ Exam
+ { examCourse = fdf
+ , examName = "Theorie"
+ , examGradingRule = Nothing
+ , examBonusRule = Nothing
+ , examOccurrenceRule = ExamRoomManual
+ , examExamOccurrenceMapping = Nothing
+ , examVisibleFrom = Just regFrom
+ , examRegisterFrom = Just firstTT
+ , examRegisterTo = Just $ toMidday $ utctDay secondTT
+ , examDeregisterUntil = Nothing
+ , examPublishOccurrenceAssignments = Nothing
+ , examStart = Just $ toTimeOfDay 15 30 0 $ utctDay secondTT
+ , examEnd = Just $ toTimeOfDay 16 30 0 $ utctDay secondTT
+ , examFinished = Nothing
+ , examPartsFrom = Nothing
+ , examClosed = Nothing
+ , examPublicStatistics = True
+ , examGradingMode = ExamGradingPass
+ , examDescription = Just $ htmlToStoredMarkup [shamlet|Theoretische Prüfung mit Fragebogen|]
+ , examExamMode = ExamMode
+ { examAids = Just $ ExamAidsPreset ExamClosedBook
+ , examOnline = Just $ ExamOnlinePreset ExamOffline
+ , examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous
+ , examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone
+ }
+ , examStaff = Just "Jost"
+ , examAuthorshipStatement = Nothing
+ }
+
-- FFP
let nbrs :: [Int]
nbrs = [1,2,3,27,7,1]
@@ -660,13 +725,13 @@ fillDb = do
|]
, courseLinkExternal = Nothing
, courseShorthand = "FFP"
- , courseTerm = TermKey $ seasonTerm True Summer
+ , courseTerm = TermKey $ seasonTerm True Q1
, courseSchool = ifi
, courseCapacity = Just 20
, courseVisibleFrom = Just now
, courseVisibleTo = Nothing
- , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight
- , courseRegisterTo = Just $ termTime True Summer 0 True Sunday beforeMidnight
+ , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight
+ , courseRegisterTo = Just $ termTime True Q1 0 True Sunday beforeMidnight
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
@@ -689,9 +754,9 @@ fillDb = do
, sheetType = NotGraded
, sheetGrouping = Arbitrary 3
, sheetMarkingText = Nothing
- , sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight
- , sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight
- , sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight
+ , sheetVisibleFrom = Just $ termTime True Q1 0 False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime True Q1 1 False Monday toMidnight
+ , sheetActiveTo = Just $ termTime True Q1 2 False Sunday beforeMidnight
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
@@ -711,9 +776,9 @@ fillDb = do
, sheetType = NotGraded
, sheetGrouping = RegisteredGroups
, sheetMarkingText = Nothing
- , sheetVisibleFrom = Just $ termTime True Summer 1 False Monday toMidnight
- , sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight
- , sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight
+ , sheetVisibleFrom = Just $ termTime True Q1 1 False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime True Q1 2 False Monday toMidnight
+ , sheetActiveTo = Just $ termTime True Q1 3 False Sunday beforeMidnight
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
@@ -733,9 +798,9 @@ fillDb = do
, sheetType = NotGraded
, sheetGrouping = NoGroups
, sheetMarkingText = Nothing
- , sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight
- , sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight
- , sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight
+ , sheetVisibleFrom = Just $ termTime True Q1 2 False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime True Q1 3 False Monday toMidnight
+ , sheetActiveTo = Just $ termTime True Q1 4 False Sunday beforeMidnight
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
@@ -761,15 +826,15 @@ fillDb = do
, examBonusRule = Nothing
, examOccurrenceRule = ExamRoomManual
, examExamOccurrenceMapping = Nothing
- , examVisibleFrom = Just $ termTime True Summer (-4) True Monday toMidnight
- , examRegisterFrom = Just $ termTime True Summer (-4) True Monday toMidnight
- , examRegisterTo = Just $ termTime True Summer 1 True Sunday beforeMidnight
- , examDeregisterUntil = Just $ termTime True Summer 2 True Wednesday beforeMidnight
- , examPublishOccurrenceAssignments = Just $ termTime True Summer 3 True Monday toMidnight
- , examStart = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 10 0 0)
- , examEnd = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 12 0 0)
- , examFinished = Just $ termTime True Summer 3 True Wednesday (toTimeOfDay 22 0 0)
- , examPartsFrom = Just $ termTime True Summer (-4) True Monday toMidnight
+ , examVisibleFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
+ , examRegisterFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
+ , examRegisterTo = Just $ termTime True Q1 1 True Sunday beforeMidnight
+ , examDeregisterUntil = Just $ termTime True Q1 2 True Wednesday beforeMidnight
+ , examPublishOccurrenceAssignments = Just $ termTime True Q1 3 True Monday toMidnight
+ , examStart = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 10 0 0)
+ , examEnd = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 12 0 0)
+ , examFinished = Just $ termTime True Q1 3 True Wednesday (toTimeOfDay 22 0 0)
+ , examPartsFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
, examClosed = Nothing
, examPublicStatistics = True
, examGradingMode = ExamGradingGrades
@@ -813,12 +878,12 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "EIP"
- , courseTerm = TermKey $ seasonTerm False Winter
+ , courseTerm = TermKey $ seasonTerm False Q4
, courseSchool = ifi
, courseCapacity = Just 20
, courseVisibleFrom = Just now
, courseVisibleTo = Nothing
- , courseRegisterFrom = Just $ termTime False Winter (-4) False Monday toMidnight
+ , courseRegisterFrom = Just $ termTime False Q4 (-4) False Monday toMidnight
, courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
@@ -839,13 +904,13 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "IXD"
- , courseTerm = TermKey $ seasonTerm True Summer
+ , courseTerm = TermKey $ seasonTerm True Q1
, courseSchool = ifi
, courseCapacity = Just 20
, courseVisibleFrom = Just now
, courseVisibleTo = Nothing
- , courseRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
- , courseRegisterTo = Just $ termTime True Summer (-2) True Sunday beforeMidnight
+ , courseRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
+ , courseRegisterTo = Just $ termTime True Q1 (-2) True Sunday beforeMidnight
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
@@ -865,7 +930,7 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "UX3"
- , courseTerm = TermKey $ seasonTerm True Winter
+ , courseTerm = TermKey $ seasonTerm True Q4
, courseSchool = ifi
, courseCapacity = Just 30
, courseVisibleFrom = Just now
@@ -891,12 +956,12 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "ProMo"
- , courseTerm = TermKey $ seasonTerm True Summer
+ , courseTerm = TermKey $ seasonTerm True Q1
, courseSchool = ifi
, courseCapacity = Just 50
, courseVisibleFrom = Just now
, courseVisibleTo = Nothing
- , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight
+ , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight
, courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
@@ -937,7 +1002,7 @@ fillDb = do
, let uploadEmptyOk = False
]
- sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes)
+ sheetCombinations = (,,) <$> shTypes <*> shGroupings <*> shSubModes
forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do
MsgRenderer mr <- getMsgRenderer
@@ -982,11 +1047,11 @@ fillDb = do
, sheetDescription = Nothing
, sheetType, sheetGrouping, sheetSubmissionMode
, sheetMarkingText = Nothing
- , sheetVisibleFrom = Just $ termTime True Summer prog False Monday toMidnight
- , sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight
- , sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
- , sheetHintFrom = Just $ termTime True Summer (prog + 1) False Sunday beforeMidnight
- , sheetSolutionFrom = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
+ , sheetVisibleFrom = Just $ termTime True Q1 prog False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime True Q1 (prog + 1) False Monday toMidnight
+ , sheetActiveTo = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight
+ , sheetHintFrom = Just $ termTime True Q1 (prog + 1) False Sunday beforeMidnight
+ , sheetSolutionFrom = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight
, sheetAutoDistribute = True
, sheetAnonymousCorrection = True
, sheetRequireExamRegistration = Nothing
@@ -1031,7 +1096,7 @@ fillDb = do
, occurrencesExceptions = Set.empty
}
, tutorialRegGroup = Just "tutorium"
- , tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
+ , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
, tutorialRegisterTo = Nothing
, tutorialDeregisterUntil = Nothing
, tutorialLastChanged = now
@@ -1051,7 +1116,7 @@ fillDb = do
, occurrencesExceptions = Set.empty
}
, tutorialRegGroup = Just "tutorium"
- , tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
+ , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
, tutorialRegisterTo = Nothing
, tutorialDeregisterUntil = Nothing
, tutorialLastChanged = now
@@ -1064,7 +1129,7 @@ fillDb = do
, courseDescription = Just "Datenbanken banken Daten damit die Daten nicht wanken. Die Datenschützer danken!"
, courseLinkExternal = Nothing
, courseShorthand = "DBS"
- , courseTerm = TermKey $ seasonTerm False Winter
+ , courseTerm = TermKey $ seasonTerm False Q4
, courseSchool = ifi
, courseCapacity = Just 50
, courseVisibleFrom = Just now
@@ -1086,7 +1151,7 @@ fillDb = do
void . insert' $ DegreeCourse dbs sdBsc sdMath
void . insert' $ Lecturer gkleen dbs CourseLecturer
void . insert' $ Lecturer jost dbs CourseAssistant
-
+
testMsg <- insert SystemMessage
{ systemMessageNewsOnly = False
, systemMessageFrom = Just now
@@ -1164,7 +1229,7 @@ fillDb = do
funAlloc <- insert' Allocation
{ allocationName = "Funktionale Zentralanmeldung"
, allocationShorthand = "fun"
- , allocationTerm = TermKey $ seasonTerm True Summer
+ , allocationTerm = TermKey currentTerm
, allocationSchool = ifi
, allocationLegacyShorthands = []
, allocationDescription = Nothing
@@ -1178,7 +1243,7 @@ fillDb = do
, allocationRegisterByStaffFrom = Nothing
, allocationRegisterByStaffTo = Nothing
, allocationRegisterByCourse = Nothing
- , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
+ , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight
, allocationMatchingSeed = aSeedFunc
}
insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing
@@ -1197,7 +1262,7 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = "BS"
- , courseTerm = TermKey $ seasonTerm False Winter
+ , courseTerm = TermKey $ seasonTerm False Q4
, courseSchool = ifi
, courseCapacity = Just 50
, courseVisibleFrom = Just now
@@ -1227,9 +1292,9 @@ fillDb = do
, sheetType = Normal $ PassPoints 12 6
, sheetGrouping = Arbitrary 3
, sheetMarkingText = Nothing
- , sheetVisibleFrom = Just $ termTime False Winter (fromInteger shNr) False Monday toMidnight
- , sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight
- , sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight
+ , sheetVisibleFrom = Just $ termTime False Q4 (fromInteger shNr) False Monday toMidnight
+ , sheetActiveFrom = Just $ termTime False Q4 (fromInteger $ succ shNr) False Monday toMidnight
+ , sheetActiveTo = Just $ termTime False Q4 (fromInteger $ succ shNr) False Sunday beforeMidnight
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
@@ -1273,7 +1338,7 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = CI.mk csh
- , courseTerm = TermKey $ seasonTerm False Winter
+ , courseTerm = TermKey $ seasonTerm False Q4
, courseSchool = ifi
, courseCapacity = Just 50
, courseVisibleFrom = Just now
@@ -1302,7 +1367,7 @@ fillDb = do
bigAlloc <- insert' Allocation
{ allocationName = "Große Zentralanmeldung"
, allocationShorthand = "big"
- , allocationTerm = TermKey $ seasonTerm True Summer
+ , allocationTerm = TermKey $ seasonTerm True Q1
, allocationSchool = ifi
, allocationLegacyShorthands = []
, allocationDescription = Nothing
@@ -1316,7 +1381,7 @@ fillDb = do
, allocationRegisterByStaffFrom = Nothing
, allocationRegisterByStaffTo = Nothing
, allocationRegisterByCourse = Nothing
- , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
+ , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight
, allocationMatchingSeed = aSeedBig
}
bigAllocShorthands <-
@@ -1335,7 +1400,7 @@ fillDb = do
, courseDescription = Nothing
, courseLinkExternal = Nothing
, courseShorthand = CI.mk csh
- , courseTerm = TermKey $ seasonTerm False Winter
+ , courseTerm = TermKey $ seasonTerm False Q4
, courseSchool = ifi
, courseCapacity = Just cap
, courseVisibleFrom = Just now
@@ -1415,42 +1480,6 @@ fillDb = do
LBS.writeFile (bool id ("testdata" ) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities
LBS.writeFile (bool id ("testdata" ) haveTestdata "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities
- whenM (liftIO . doesFileExist <=< testdataFile $ "workflows" "_index.yaml") $ do
- let displayLinterIssue :: MonadIO m => WorkflowGraphLinterIssue -> m ()
- displayLinterIssue = liftIO . hPutStrLn stderr . displayException
-
- wfIndex <- Yaml.decodeFileThrow @_ @(Map WorkflowDefinitionName WorkflowIndexItem) =<< testdataFile ("workflows" "_index.yaml")
-
- iforM_ wfIndex $ \wiName WorkflowIndexItem{..} -> handleSql displayLinterIssue $ do
- graph <- Yaml.decodeFileThrow =<< testdataFile ("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/test/FoundationSpec.hs b/test/FoundationSpec.hs
index f44875286..962c5dda5 100644
--- a/test/FoundationSpec.hs
+++ b/test/FoundationSpec.hs
@@ -81,30 +81,6 @@ instance Arbitrary CourseEventR where
arbitrary = genericArbitrary
shrink = genericShrink
-instance Arbitrary AdminWorkflowDefinitionR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary AdminWorkflowInstanceR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary GlobalWorkflowInstanceR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary GlobalWorkflowWorkflowR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary SchoolWorkflowInstanceR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary SchoolWorkflowWorkflowR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
instance Arbitrary AMatchingR where
arbitrary = genericArbitrary
shrink = genericShrink
diff --git a/test/Handler/Utils/Workflow/CanonicalRouteSpec.hs b/test/Handler/Utils/Workflow/CanonicalRouteSpec.hs
deleted file mode 100644
index de6e803dc..000000000
--- a/test/Handler/Utils/Workflow/CanonicalRouteSpec.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Handler.Utils.Workflow.CanonicalRouteSpec where
-
-import TestImport
-import Handler.Utils.Workflow.CanonicalRoute
-import ModelSpec ()
-import FoundationSpec ()
-
-
-instance Arbitrary WorkflowScopeRoute where
- arbitrary = genericArbitrary
- shrink = genericShrink
-instance CoArbitrary WorkflowScopeRoute
-instance Function WorkflowScopeRoute
-
-instance Arbitrary WorkflowInstanceR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-instance CoArbitrary WorkflowInstanceR
-instance Function WorkflowInstanceR
-
-instance Arbitrary WorkflowWorkflowR where
- arbitrary = genericArbitrary
- shrink = genericShrink
-instance CoArbitrary WorkflowWorkflowR
-instance Function WorkflowWorkflowR
-
-
-spec :: Spec
-spec = describe "_WorkflowSpecRoute" $
- before_ (pendingWith "Missing routes") . it "is a prism" . property $ isPrism _WorkflowScopeRoute
diff --git a/test/Model/Types/WorkflowSpec.hs b/test/Model/Types/WorkflowSpec.hs
deleted file mode 100644
index d43af9ae8..000000000
--- a/test/Model/Types/WorkflowSpec.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
-module Model.Types.WorkflowSpec where
-
-import TestImport hiding (NonEmpty)
-import TestInstances ()
-
-import Data.Scientific (Scientific)
-import Data.List.NonEmpty (NonEmpty)
-
-import Utils.I18nSpec ()
-import Model.Types.FileSpec ()
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import qualified Data.Aeson as Aeson
-
-import Utils.Lens
-
-import Utils.I18n
-
-import qualified Data.CaseInsensitive as CI
-
-import Data.Time.LocalTime (TimeOfDay)
-
-
-instance Arbitrary WorkflowPayloadLabel where
- arbitrary = WorkflowPayloadLabel . CI.mk . pack <$> (fmap getPrintableString arbitrary `suchThat` (not . null))
- shrink = genericShrink
-instance CoArbitrary WorkflowPayloadLabel
-instance Function WorkflowPayloadLabel
-
-instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadSpec fileid userid) where
- arbitrary = oneof
- [ WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Text)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Scientific)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Bool)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Day)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid (Set fileid))
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid userid)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadFieldReference)
- , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)))
- ]
-
-instance Arbitrary WorkflowPayloadTextPreset where
- arbitrary = genericArbitrary
- shrink = genericShrink
-instance Arbitrary (WorkflowPayloadField fileid userid Text) where
- arbitrary = WorkflowPayloadFieldText
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance Arbitrary (WorkflowPayloadField fileid userid Scientific) where
- arbitrary = WorkflowPayloadFieldNumber
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance Arbitrary (WorkflowPayloadField fileid userid Bool) where
- arbitrary = WorkflowPayloadFieldBool
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance Arbitrary (WorkflowPayloadField fileid userid Day) where
- arbitrary = WorkflowPayloadFieldDay
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance (Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadField fileid userid (Set fileid)) where
- arbitrary = WorkflowPayloadFieldFile
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance Arbitrary userid => Arbitrary (WorkflowPayloadField fileid userid userid) where
- arbitrary = oneof
- [ WorkflowPayloadFieldUser
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- , pure WorkflowPayloadFieldCaptureUser
- ]
-instance Arbitrary (WorkflowPayloadField fileid userid WorkflowPayloadFieldReference) where
- arbitrary = WorkflowPayloadFieldReference
- <$> scale (`div` 2) arbitrary
-instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))) where
- arbitrary = WorkflowPayloadFieldMultiple
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-instance Arbitrary (WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture) where
- arbitrary = WorkflowPayloadFieldCaptureDateTime
- <$> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
- <*> scale (`div` 2) arbitrary
-
-instance Arbitrary WorkflowPayloadTimeCapturePrecision where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance Arbitrary WorkflowGraphEdgeFormOrder where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Ord userid, Ord (FileField fileid), Arbitrary (FileField fileid)) => Arbitrary (WorkflowGraphEdgeForm fileid userid) where
- arbitrary = WorkflowGraphEdgeForm . Map.fromList . mapMaybe (\(l, s) -> (l, ) <$> fromNullable (Set.fromList . mapMaybe fromNullable $ map Map.fromList s)) <$> listOf ((,) <$> scale (`div` 2) arbitrary <*> scale (`div` 2) (listOf . scale (`div` 2) . listOf $ (,) <$> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary))
- shrink = genericShrink
-
-instance (Arbitrary fileid, Arbitrary userid, Ord fileid, Typeable userid, Typeable fileid) => Arbitrary (WorkflowFieldPayloadW fileid userid) where
- arbitrary = oneof
- [ WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Text)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Scientific)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Bool)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Day)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid TimeOfDay)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid UTCTime)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid fileid)
- , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid userid)
- ]
-
-instance (Arbitrary payload, IsWorkflowFieldPayload' fileid userid payload) => Arbitrary (WorkflowFieldPayload fileid userid payload) where
- arbitrary = review _WorkflowFieldPayload <$> arbitrary
-
-instance (Arbitrary termid, Arbitrary courseid) => Arbitrary (WorkflowScope termid SchoolShorthand courseid) where
- arbitrary = oneof
- [ pure WSGlobal
- , WSTerm <$> arbitrary
- , WSSchool <$> arbitrarySchoolShorthand
- , WSTermSchool <$> arbitrary <*> arbitrarySchoolShorthand
- , WSCourse <$> arbitrary
- ]
- where arbitrarySchoolShorthand = CI.mk . pack <$> (fmap getPrintableString arbitrary `suchThat` (not . null))
-instance (Arbitrary termid, Arbitrary courseid) => Arbitrary (WorkflowScope termid SchoolId courseid) where
- arbitrary = over _wisSchool SchoolKey <$> arbitrary
-instance (CoArbitrary termid, CoArbitrary schoolid, CoArbitrary courseid) => CoArbitrary (WorkflowScope termid schoolid courseid)
-instance (Function termid, Function schoolid, Function courseid) => Function (WorkflowScope termid schoolid courseid)
-
-instance Arbitrary WorkflowScope' where
- arbitrary = genericArbitrary
- shrink = genericShrink
-
-
-spec :: Spec
-spec = do
- describe "WorkflowPayloadSpec" $ do
- it "json-roundtrips some examples" $ do
- let roundtrip val = Aeson.eitherDecode (Aeson.encode val) `shouldBe` Right val
-
- -- Generated tests that failed previously
- roundtrip $ WorkflowPayloadSpec @FileReference @SqlBackendKey (WorkflowPayloadFieldNumber {wpfnLabel = I18n {i18nFallback = "\368366\901557\714616k", i18nFallbackLang = Nothing, i18nTranslations = Map.fromList [("",""),("Jak8","\125553E")]}, wpfnPlaceholder = Just (I18n {i18nFallback = "\303706\543092", i18nFallbackLang = Nothing, i18nTranslations = Map.fromList []}), wpfnTooltip = Nothing, wpfnDefault = Nothing, wpfnMin = Nothing, wpfnMax = Just 0.1, wpfnStep = Nothing, wpfnOptional = False})
-
- describe "WorkflowGraphEdgeForm" $ do
- it "json-decodes some examples" $ do
- let decodes bs = Aeson.decode bs `shouldSatisfy` is (_Just @(WorkflowGraphEdgeForm FileReference SqlBackendKey))
-
- decodes "{\"\": [{\"tag\": \"capture-user\"}]}"
- decodes "{\"\": [{\"_\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"1\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"-1\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"tag\": \"capture-user\"}, {\"_\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"tag\": \"capture-user\"}, {\"1\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"_\": {\"tag\": \"capture-user\"}}, {\"1\": {\"tag\": \"capture-user\"}}]}"
- decodes "{\"\": [{\"0.1\":{\"tag\": \"capture-user\"}}, {\"-0.1\":{\"tag\": \"capture-user\"}}]}"
-
- parallel $ do
- lawsCheckHspec (Proxy @WorkflowGraphEdgeFormOrder)
- [ eqLaws, ordLaws, semigroupLaws, monoidLaws, semigroupMonoidLaws, commutativeSemigroupLaws, idempotentSemigroupLaws, showLaws, showReadLaws, jsonLaws, jsonKeyLaws ]
- lawsCheckHspec (Proxy @(WorkflowPayloadSpec FileReference SqlBackendKey))
- [ eqLaws, ordLaws, jsonLaws ]
- modifyMaxSize (`div` 4) $ lawsCheckHspec (Proxy @(WorkflowGraphEdgeForm FileReference SqlBackendKey))
- [ eqLaws, ordLaws, jsonLaws ]
- lawsCheckHspec (Proxy @WorkflowScope')
- [ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
- lawsCheckHspec (Proxy @(WorkflowFieldPayloadW FileReference SqlBackendKey))
- [ eqLaws, ordLaws, showLaws, jsonLaws, binaryLaws ]
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index fad24d3f7..7f4e705ed 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -5,6 +5,7 @@ module Model.TypesSpec
) where
import TestImport
+import TestInstances ()
import Settings
import Data.Aeson (Value)
@@ -37,7 +38,7 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
-import Model.Types.WorkflowSpec as Model.TypesSpec ()
+import Model.Types.FileSpec ()
import Text.Blaze.TestInstances ()
@@ -450,8 +451,6 @@ spec = do
[ persistFieldLaws, jsonLaws, eqLaws, ordLaws ]
lawsCheckHspec (Proxy @RoomReference')
[ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
- lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey))
- [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
lawsCheckHspec (Proxy @UploadNonce)
[ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SchoolAuthorshipStatementMode)
@@ -463,9 +462,9 @@ spec = do
it "has compatible encoding/decoding to/from Text" . property $
\term -> termFromText (termToText term) == Right term
it "works for some examples" . mapM_ termExample $
- [ (TermIdentifier 2017 Summer, "S17")
- , (TermIdentifier 1995 Winter, "W95")
- , (TermIdentifier 3068 Winter, "W3068")
+ [ (TermIdentifier 2017 Q2, "17Q2")
+ , (TermIdentifier 1995 Q4, "95Q4")
+ , (TermIdentifier 3068 Q1, "3068Q1")
]
it "has compatbile encoding/decoding to/from Rational" . property $
\term -> termFromRational (termToRational term) == term
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