From ff370c68c735c492e8e588a8bb8e4055aa8cc0f4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 15 Jun 2020 14:13:26 +0200 Subject: [PATCH] feat(workflows): list & edit definitions --- frontend/src/app.sass | 3 + messages/uniworx/de-de-formal.msg | 8 +- package.yaml | 1 + src/Handler/Course/LecturerInvite.hs | 2 - src/Handler/Course/ParticipantInvite.hs | 2 - src/Handler/Exam/CorrectorInvite.hs | 2 - src/Handler/ExamOffice/Users.hs | 1 - src/Handler/ExternalExam/StaffInvite.hs | 1 - .../Submission/SubmissionUserInvite.hs | 1 - src/Handler/Tutorial/TutorInvite.hs | 1 - src/Handler/Users.hs | 1 - src/Handler/Workflow/Definition/Edit.hs | 109 +++++++++++++++- src/Handler/Workflow/Definition/List.hs | 121 +++++++++++++++++- src/Import/NoModel.hs | 2 + src/Model/Types/Security.hs | 2 +- src/Text/Shakespeare/Text/Instances.hs | 16 +++ src/Utils/Lens.hs | 4 + 17 files changed, 262 insertions(+), 15 deletions(-) create mode 100644 src/Text/Shakespeare/Text/Instances.hs diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 56f4d7028..af6dd77a6 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1383,3 +1383,6 @@ a.breadcrumbs__home .multi-user-invitation-field__wrapper max-width: 25rem + +.json + white-space: pre-wrap diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b21e7400c..0a5b633b2 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 \ No newline at end of file +WorkflowDefinitionNewTitle: Workflow-Definition anlegen +WorkflowDefinitionEditTitle: Workflow-Definition Bearbeiten + +WorkflowDefinitionListTitle: Workflow-Definitionen +WorkflowDefinitionInstanceCount: Instanzen +WorkflowDefinitionWorkflowCount: Workflows \ No newline at end of file diff --git a/package.yaml b/package.yaml index cdc6fdba0..9c82c06b3 100644 --- a/package.yaml +++ b/package.yaml @@ -152,6 +152,7 @@ dependencies: - network-ip - data-textual - fastcdc + - bimap other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 53d7156ac..58530d651 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index f7c9ea350..21566bb55 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -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) diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 871fb8d12..5441a3409 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -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 diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 1592298db..d3ca9e274 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -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 diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs index c594b613a..8d8c69afa 100644 --- a/src/Handler/ExternalExam/StaffInvite.hs +++ b/src/Handler/ExternalExam/StaffInvite.hs @@ -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 diff --git a/src/Handler/Submission/SubmissionUserInvite.hs b/src/Handler/Submission/SubmissionUserInvite.hs index 1fd36903e..b2c7b9e41 100644 --- a/src/Handler/Submission/SubmissionUserInvite.hs +++ b/src/Handler/Submission/SubmissionUserInvite.hs @@ -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 diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs index 725cc6e83..541a3e793 100644 --- a/src/Handler/Tutorial/TutorInvite.hs +++ b/src/Handler/Tutorial/TutorInvite.hs @@ -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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 96a285ce0..2a2400919 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs index 264d8b033..78990b1c0 100644 --- a/src/Handler/Workflow/Definition/Edit.hs +++ b/src/Handler/Workflow/Definition/Edit.hs @@ -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 + + _{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 diff --git a/src/Handler/Workflow/Definition/List.hs b/src/Handler/Workflow/Definition/List.hs index 9a1bc8956..8b5ef994b 100644 --- a/src/Handler/Workflow/Definition/List.hs +++ b/src/Handler/Workflow/Definition/List.hs @@ -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 + + #{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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 4ae319b29..ce53e0bad 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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) diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index da48fbf8c..118bebc1d 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -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 diff --git a/src/Text/Shakespeare/Text/Instances.hs b/src/Text/Shakespeare/Text/Instances.hs new file mode 100644 index 000000000..26fd80713 --- /dev/null +++ b/src/Text/Shakespeare/Text/Instances.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index d75fcb68b..1641da3fc 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -245,6 +245,10 @@ makeLenses_ ''Rating' makeLenses_ ''FallbackPersonalisedSheetFilesKey +makeLenses_ ''WorkflowDefinition +makeLenses_ ''WorkflowDefinitionDescription + + -- makeClassy_ ''Load --------------------------