feat(workflows): list & edit definitions
This commit is contained in:
Gregor Kleen
parent
4d63d30634
commit
ff370c68c7
@ -1383,3 +1383,6 @@ a.breadcrumbs__home
|
||||
|
||||
.multi-user-invitation-field__wrapper
|
||||
max-width: 25rem
|
||||
|
||||
.json
|
||||
white-space: pre-wrap
|
||||
|
||||
@ -2794,5 +2794,11 @@ WorkflowDefinitionFileIdentExists: Eine Datei mit dieser ID existiert bereits
|
||||
WorkflowDefinitionFileIdent: Dateireferenz
|
||||
WorkflowDefinitionFile: Datei
|
||||
WorkflowDefinitionCreated: Workflow-Definition angelegt
|
||||
WorkflowDefinitionEdited: Workflow-Definition ersetzt
|
||||
WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit diesem Namen
|
||||
WorkflowDefinitionNewTitle: Workflow-Definition anlegen
|
||||
WorkflowDefinitionNewTitle: Workflow-Definition anlegen
|
||||
WorkflowDefinitionEditTitle: Workflow-Definition Bearbeiten
|
||||
|
||||
WorkflowDefinitionListTitle: Workflow-Definitionen
|
||||
WorkflowDefinitionInstanceCount: Instanzen
|
||||
WorkflowDefinitionWorkflowCount: Workflows
|
||||
@ -152,6 +152,7 @@ dependencies:
|
||||
- network-ip
|
||||
- data-textual
|
||||
- fastcdc
|
||||
- bimap
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -15,8 +15,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
|
||||
@ -26,8 +26,6 @@ import Jobs.Queue
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
@ -12,8 +12,6 @@ import Import
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Exam
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
@ -10,7 +10,6 @@ import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
@ -10,7 +10,6 @@ import Import
|
||||
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
@ -11,7 +11,6 @@ import Import
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
@ -11,7 +11,6 @@ import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
@ -28,7 +28,6 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Handler.Users.Add as Handler.Users
|
||||
|
||||
@ -1,9 +1,116 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Handler.Workflow.Definition.Edit
|
||||
( getAWDEditR, postAWDEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Workflow.Definition.Form
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map.Strict ((!))
|
||||
|
||||
import Data.Bimap (Bimap)
|
||||
import qualified Data.Bimap as Bimap
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
getAWDEditR, postAWDEditR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html
|
||||
getAWDEditR = postAWDEditR
|
||||
postAWDEditR = error "not implemented"
|
||||
postAWDEditR wds' wdn = do
|
||||
(((_, editForm), editEncoding), act) <- runDB $ do
|
||||
Entity wdId WorkflowDefinition{..} <- getBy404 $ UniqueWorkflowDefinition wdn wds'
|
||||
template <- do
|
||||
descs <- selectList [WorkflowDefinitionDescriptionDefinition ==. wdId] []
|
||||
let wdfDescriptions = Map.fromList
|
||||
[ (workflowDefinitionDescriptionLanguage, (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription))
|
||||
| Entity _ WorkflowDefinitionDescription{..} <- descs
|
||||
]
|
||||
|
||||
let recordFile :: FileId -> StateT (Bimap FileIdent FileId) DB FileIdent
|
||||
recordFile fId = do
|
||||
prev <- State.gets $ Bimap.lookupR fId
|
||||
case prev of
|
||||
Just fIdent -> return fIdent
|
||||
Nothing -> do
|
||||
mTitle <- lift . E.selectMaybe . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val fId
|
||||
return $ file E.^. FileTitle
|
||||
cMap <- State.get
|
||||
let candidateIdents = map (review _Wrapped . CI.mk) $ case mTitle of
|
||||
Just (E.Value fTitle)
|
||||
-> map pack $ fTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fTitle ]
|
||||
Nothing
|
||||
-> [ [st|file_#{n}|] | n <- [1..] :: [Natural]]
|
||||
fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
|
||||
fIdent' : _ -> fIdent'
|
||||
[] -> error "candidateIdents should be infinite; cMap should be finite"
|
||||
State.modify $ Bimap.insert fIdent fId
|
||||
return fIdent
|
||||
|
||||
(wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
|
||||
$ (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey SqlBackendKey) (WorkflowGraph FileIdent SqlBackendKey) SqlBackendKey FileIdent) (recordFile . review _SqlKey)
|
||||
>=> (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent SqlBackendKey) (WorkflowGraph FileIdent CryptoUUIDUser) SqlBackendKey CryptoUUIDUser) (encrypt . review (_SqlKey @User))
|
||||
|
||||
return WorkflowDefinitionForm
|
||||
{ wdfScope = workflowDefinitionScope
|
||||
, wdfName = workflowDefinitionName
|
||||
, wdfDescriptions
|
||||
, wdfGraph
|
||||
, wdfFiles
|
||||
}
|
||||
|
||||
form@((editRes, _), _) <- runFormPost . workflowDefinitionForm $ Just template
|
||||
|
||||
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
|
||||
wdfGraph' <- wdfGraph
|
||||
& over (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent CryptoUUIDUser) (WorkflowGraph SqlBackendKey CryptoUUIDUser) FileIdent SqlBackendKey) (view _SqlKey . (wdfFiles !))
|
||||
& (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt)
|
||||
|
||||
insConflict <- replaceUnique wdId WorkflowDefinition
|
||||
{ workflowDefinitionGraph = wdfGraph'
|
||||
, workflowDefinitionScope = wdfScope
|
||||
, workflowDefinitionName = wdfName
|
||||
}
|
||||
|
||||
when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do
|
||||
deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId]
|
||||
insert WorkflowDefinitionDescription
|
||||
{ workflowDefinitionDescriptionDefinition = wdId
|
||||
, workflowDefinitionDescriptionLanguage = wddLang
|
||||
, workflowDefinitionDescriptionTitle = wddTitle
|
||||
, workflowDefinitionDescriptionDescription = wddDesc
|
||||
}
|
||||
|
||||
case insConflict of
|
||||
Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
|
||||
addMessage' =<< messageIHamlet Error
|
||||
[ihamlet|
|
||||
$newline never
|
||||
<a href=@{AdminWorkflowDefinitionR wds'' wdn' AWDEditR}>
|
||||
_{MsgWorkflowDefinitionCollision}
|
||||
|]
|
||||
Nothing -> return . Just $ do
|
||||
addMessageI Success MsgWorkflowDefinitionEdited
|
||||
redirect AdminWorkflowDefinitionListR
|
||||
|
||||
return (form, act)
|
||||
|
||||
forM_ act id
|
||||
|
||||
let editWidget = wrapForm editForm def
|
||||
{ formAction = Just . SomeRoute $ AdminWorkflowDefinitionR wds' wdn AWDEditR
|
||||
, formEncoding = editEncoding
|
||||
}
|
||||
|
||||
siteLayoutMsg MsgWorkflowDefinitionEditTitle $ do
|
||||
setTitleI MsgWorkflowDefinitionEditTitle
|
||||
|
||||
editWidget
|
||||
|
||||
@ -1,9 +1,128 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Workflow.Definition.List
|
||||
( getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
type WorkflowDefinitionTableExpr = E.SqlExpr (Entity WorkflowDefinition)
|
||||
|
||||
queryWorkflowDefinition :: Iso' WorkflowDefinitionTableExpr (E.SqlExpr (Entity WorkflowDefinition))
|
||||
queryWorkflowDefinition = id
|
||||
|
||||
queryWorkflowInstanceCount, queryWorkflowCount :: Getter WorkflowDefinitionTableExpr (E.SqlExpr (E.Value Int64))
|
||||
queryWorkflowInstanceCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
||||
E.subSelectCount . E.from $ \workflowInstance ->
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
queryWorkflowCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
||||
E.subSelectCount . E.from $ \(workflowInstance `E.InnerJoin` workflow) -> do
|
||||
E.on $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
|
||||
|
||||
|
||||
type WorkflowDefinitionData = DBRow
|
||||
( Entity WorkflowDefinition
|
||||
, Maybe (Entity WorkflowDefinitionDescription)
|
||||
, Int64, Int64
|
||||
)
|
||||
|
||||
resultDefinition :: Lens' WorkflowDefinitionData (Entity WorkflowDefinition)
|
||||
resultDefinition = _dbrOutput . _1
|
||||
|
||||
resultDescription :: Traversal' WorkflowDefinitionData (Entity WorkflowDefinitionDescription)
|
||||
resultDescription = _dbrOutput . _2 . _Just
|
||||
|
||||
resultWorkflowInstanceCount, resultWorkflowCount :: Lens' WorkflowDefinitionData Int64
|
||||
resultWorkflowInstanceCount = _dbrOutput . _3
|
||||
resultWorkflowCount = _dbrOutput . _4
|
||||
|
||||
|
||||
getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR :: Handler Html
|
||||
getAdminWorkflowDefinitionListR = postAdminWorkflowDefinitionListR
|
||||
postAdminWorkflowDefinitionListR = error "not implemented"
|
||||
postAdminWorkflowDefinitionListR = do
|
||||
definitionsTable <- runDB $
|
||||
let
|
||||
workflowDefinitionsDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
workflowDefinition <- view queryWorkflowDefinition
|
||||
workflowInstanceCount <- view queryWorkflowInstanceCount
|
||||
workflowCount <- view queryWorkflowCount
|
||||
|
||||
return (workflowDefinition, workflowInstanceCount, workflowCount)
|
||||
dbtRowKey = (E.^. WorkflowDefinitionId)
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
||||
wd@(Entity wdId _) <- view _1
|
||||
descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
|
||||
E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
|
||||
return $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionLanguage
|
||||
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
||||
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowDefinitionDescription wdId descLang'
|
||||
(wd, desc,,)
|
||||
<$> view (_2 . _Value)
|
||||
<*> view (_3 . _Value)
|
||||
dbtColonnade :: Colonnade Sortable WorkflowDefinitionData _
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "name") (i18nCell MsgWorkflowDefinitionName) . anchorEdit $ views (resultDefinition . _entityVal . _workflowDefinitionName) i18n
|
||||
, sortable (Just "scope") (i18nCell MsgWorkflowDefinitionScope) $ views (resultDefinition . _entityVal . _workflowDefinitionScope) i18nCell
|
||||
, sortable (Just "title") (i18nCell MsgWorkflowDefinitionDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultDescription . _entityVal . _workflowDefinitionDescriptionTitle)
|
||||
, sortable (Just "instances") (i18nCell MsgWorkflowDefinitionInstanceCount) $ maybe mempty i18nCell . views resultWorkflowInstanceCount (assertM' (> 0))
|
||||
, sortable (Just "workflows") (i18nCell MsgWorkflowDefinitionWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
|
||||
, sortable (Just "description") (i18nCell MsgWorkflowDefinitionDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowDefinitionDescriptionDescription . _Just)
|
||||
, sortable Nothing (i18nCell MsgWorkflowDefinitionGraph) $ views (resultDefinition . _entityVal . _workflowDefinitionGraph) (modalCell . displayGraph)
|
||||
]
|
||||
where
|
||||
anchorEdit :: (WorkflowDefinitionData -> Widget) -> _
|
||||
anchorEdit = anchorCell' (\(view $ resultDefinition . _entityVal -> WorkflowDefinition{..}) -> AdminWorkflowDefinitionR workflowDefinitionScope workflowDefinitionName AWDEditR)
|
||||
displayGraph graph
|
||||
= [shamlet|
|
||||
$newline never
|
||||
<code .json>
|
||||
#{graph'}
|
||||
|]
|
||||
where graph' = encodePrettyToTextBuilder 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 "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" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> 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 MsgNoFilter) optionsFinite :: Field _ WorkflowInstanceScope') (fslI MsgWorkflowDefinitionScope)
|
||||
, prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowDefinitionDescriptionTitle)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "workflow-definitions"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
workflowDefinitionsDBTableValidator = def
|
||||
& defaultPagesize PagesizeAll
|
||||
& defaultSorting [SortAscBy "scope", SortAscBy "name"]
|
||||
in dbTableWidget' workflowDefinitionsDBTableValidator workflowDefinitionsDBTable
|
||||
|
||||
siteLayoutMsg MsgWorkflowDefinitionListTitle $ do
|
||||
setTitleI MsgWorkflowDefinitionListTitle
|
||||
|
||||
definitionsTable
|
||||
|
||||
@ -50,6 +50,7 @@ import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
|
||||
import Text.Lucius as Import
|
||||
import Text.Julius as Import
|
||||
import Text.Shakespeare.Text as Import hiding (text, stext)
|
||||
import Text.Hamlet as Import (ihamlet)
|
||||
|
||||
import Data.Universe as Import
|
||||
import Data.Universe.TH as Import
|
||||
@ -175,6 +176,7 @@ import Data.Word.Word24.Instances as Import ()
|
||||
import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
|
||||
import Database.Persist.Sql.Types.Instances as Import ()
|
||||
import Control.Monad.Catch.Instances as Import ()
|
||||
import Text.Shakespeare.Text.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
|
||||
@ -129,7 +129,7 @@ getSessionActiveAuthTags = fromMaybe def <$> lookupSessionJson SessionActiveAuth
|
||||
|
||||
|
||||
data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
|
||||
deriving anyclass (Hashable, Binary)
|
||||
|
||||
makeLenses_ ''PredLiteral
|
||||
|
||||
16
src/Text/Shakespeare/Text/Instances.hs
Normal file
16
src/Text/Shakespeare/Text/Instances.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Text.Shakespeare.Text.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Text.Shakespeare.Text
|
||||
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
import Numeric.Natural (Natural)
|
||||
|
||||
|
||||
instance ToText Natural where
|
||||
toText = Builder.fromText . tshow
|
||||
@ -245,6 +245,10 @@ makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makeLenses_ ''WorkflowDefinition
|
||||
makeLenses_ ''WorkflowDefinitionDescription
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
--------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user