diff --git a/frontend/src/app.sass b/frontend/src/app.sass index adcfc456e..8092e58b7 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -720,7 +720,7 @@ section background-color: hsla($hue, 75%, 50%, $opacity) !important -.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label +.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text font-family: var(--font-monospace) .token diff --git a/frontend/src/utils/form/datepicker.js b/frontend/src/utils/form/datepicker.js index 655ffd1c8..9c66b0d1f 100644 --- a/frontend/src/utils/form/datepicker.js +++ b/frontend/src/utils/form/datepicker.js @@ -3,6 +3,8 @@ import './datepicker.css'; import { Utility } from '../../core/utility'; import moment from 'moment'; +import * as defer from 'lodash.defer'; + const KEYCODE_ESCAPE = 27; const Z_INDEX_MODAL = 9999; @@ -77,8 +79,11 @@ export class Datepicker { datepickerInstance; _element; elementType; + initialValue; _locale; + _unloadIsDueToSubmit = false; + constructor(element) { if (!element) { throw new Error('Datepicker utility needs to be passed an element!'); @@ -100,6 +105,9 @@ export class Datepicker { // store the previously set type to select the input format this.elementType = this._element.getAttribute('type'); + // store initial value prior to changing type + this.initialValue = this._element.value || this._element.getAttribute('value'); + // manually set the type attribute to text because datepicker handles displaying the date this._element.setAttribute('type', 'text'); @@ -120,7 +128,7 @@ export class Datepicker { // FIXME dirty hack below; fix tail.datetime instead // get date object from internal format before datetime does nasty things with it - let parsedMomentDate = moment(this._element.value, [ FORM_DATE_FORMAT[this.elementType], FORM_DATE_FORMAT_MOMENT[this.elementType] ], true); + let parsedMomentDate = moment(this.initialValue, [ FORM_DATE_FORMAT[this.elementType], FORM_DATE_FORMAT_MOMENT[this.elementType] ], true); if (parsedMomentDate && parsedMomentDate.isValid()) { parsedMomentDate = parsedMomentDate.toDate(); } else { @@ -222,7 +230,9 @@ export class Datepicker { }); // format the date value of the form input element of this datepicker before form submission - this._element.form.addEventListener('submit', () => this.formatElementValue()); + this._element.form.addEventListener('submit', this._submitHandler.bind(this)); + + window.addEventListener('beforeunload', this._beforeUnloadHandler.bind(this)); } destroy() { @@ -257,6 +267,33 @@ export class Datepicker { } } + _submitHandler() { + this._unloadIsDueToSubmit = true; + this.formatElementValue(false); + + defer(() => { // Restore state after event loop is settled + this._unloadIsDueToSubmit = false; + this.formatElementValue(true); + }); + } + /** + * Restore input element to it's original type and format it's new value for input-value persisting by the browser + */ + _beforeUnloadHandler() { + if (this._unloadIsDueToSubmit) + return; + + let oldValue = this._element.value; + let newValue = this.unformat(false); + this._element.type = this.elementType; + this._element.value = newValue; + + defer(() => { // Restore state after event loop is settled + this._element.setAttribute('type', 'text'); + this._element.value = oldValue; + }); + } + /** * Returns a datestring in internal format from the current state of the input element value. * @param {*} toFancy Format date from internal to fancy or vice versa. When omitted, toFancy is falsy and results in fancy -> internal diff --git a/frontend/src/utils/form/navigate-away-prompt.js b/frontend/src/utils/form/navigate-away-prompt.js index fdb92fa79..61627ddba 100644 --- a/frontend/src/utils/form/navigate-away-prompt.js +++ b/frontend/src/utils/form/navigate-away-prompt.js @@ -5,6 +5,8 @@ import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from './auto-submit-input'; import { InteractiveFieldset } from './interactive-fieldset'; import { Datepicker } from './datepicker'; +import * as defer from 'lodash.defer'; + /** * Key generator from an arbitrary number of FormData objects. * @param {...any} formDatas FormData objects @@ -67,6 +69,7 @@ export class NavigateAwayPrompt { this._element.addEventListener('submit', () => { this._unloadDueToSubmit = true; + defer(() => { this._unloadDueToSubmit = false; } ); // Restore state after event loop is settled }); } diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 2b084d944..3ffe51e6a 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -527,11 +527,12 @@ UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden -UnauthorizedWorkflowInitiate: Der Workflow darf nicht im angegebenen Zustand unter Verwendung der angegebenen Kante initiiert werden +UnauthorizedWorkflowInitiate: Sie dürfen keinen neuen laufenden Workflow initiieren UnauthorizedWorkflowWrite: Sie dürfen aktuell keinen Zustandsübergang im Workflow auslösen UnauthorizedWorkflowRead: Der Workflow enthält aktuell keine Zustände oder Daten die Sie einsehen dürfen UnauthorizedWorkflowInstancesNotEmpty: Es gibt Workflow Instanzen für die Sie einen neuen laufenden Workflow initiieren dürfen UnauthorizedWorkflowWorkflowsNotEmpty: Es gibt laufende Workflows, die Sie einsehen dürfen +UnauthorizedWorkflowFiles: Sie dürfen die angegebenen Workflow-Dateien nicht im angegebenen historischen Zustand herunterladen WorkflowRoleUserMismatch: Sie sind nicht einer der vom Workflow geforderten Benutzer WorkflowRoleAlreadyInitiated: Dieser Workflow wurde bereits initiiert @@ -1501,6 +1502,7 @@ BreadcrumbWorkflowInstanceInitiate: Workflow starten BreadcrumbWorkflowInstanceList: Workflows BreadcrumbWorkflowInstanceNew: Neuer Workflow BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow: #{toPathPiece workflow} +BreadcrumbWorkflowWorkflowFiles: Dateien BreadcrumbWorkflowWorkflowEdit: Editieren BreadcrumbWorkflowWorkflowDelete: Löschen BreadcrumbGlobalWorkflowInstanceList: Workflows @@ -2951,6 +2953,8 @@ WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit d WorkflowDefinitionNewTitle: Workflow-Definition anlegen WorkflowDefinitionEditTitle: Workflow-Definition Bearbeiten WorkflowDefinitionInstanceCategory: Kategorie +WorkflowDefinitionWarningLinterIssuesMessage: Es sind Linter issues aufgetreten +WorkflowDefinitionWarningLinterIssues: Es sind folgende Linter issues aufgetreten: WorkflowDefinitionListTitle: Workflow-Definitionen WorkflowDefinitionInstanceCount: Instanzen @@ -2995,6 +2999,27 @@ WorkflowEdgeFormFieldNumberTooSmall minSci@Scientific: Zahl muss mindestens #{fo WorkflowEdgeFormFieldNumberTooLarge maxSci@Scientific: Zahl muss höchstens #{formatScientific Scientific.Generic Nothing maxSci} sein WorkflowEdgeFormFieldUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden WorkflowEdgeFormFieldMultipleNoneAdded: (Noch) keine Einträge +WorkflowEdgeFormFieldCaptureUserLabel: Aktueller Benutzer + +WorkflowWorkflowWorkflowHistoryHeading: Verlauf +WorkflowWorkflowWorkflowEdgeFormHeading: Aktion im Workflow auslösen +WorkflowWorkflowWorkflowEdgeSuccess: Aktion erfolgreich ausgelöst +WorkflowWorkflowWorkflowHistoryUserSelf: Sie selbst +WorkflowWorkflowWorkflowHistoryUserNotLoggedIn: Nicht eingeloggter Benutzer +WorkflowWorkflowWorkflowHistoryUserGone: Gelöschter Benutzer +WorkflowWorkflowWorkflowHistoryUserHidden: Versteckter Benutzer +WorkflowWorkflowWorkflowHistoryUserAutomatic: Automatisch +WorkflowWorkflowWorkflowHistoryActionAutomatic: Automatisch +WorkflowWorkflowWorkflowHistoryStateHidden: Versteckter Zustand +WorkflowWorkflowFilesArchiveName wwCID@CryptoFileNameWorkflowWorkflow wpl@WorkflowPayloadLabel stCID@CryptoUUIDWorkflowStateIndex: #{foldCase (toPathPiece wwCID)}-#{foldCase (toPathPiece stCID)}-#{foldCase (foldMap unidecode (toPathPiece wpl))}.zip + +WorkflowPayloadFiles: Datei(en) +WorkflowPayloadBoolTrue: Ja +WorkflowPayloadBoolFalse: Nein +WorkflowPayloadUserGone: Gelöschter Benutzer + +GlobalWorkflowWorkflowWorkflowHeading workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId} +GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId} ChangelogItemFeature: Feature ChangelogItemBugfix: Bugfix diff --git a/routes b/routes index 360417892..f3bc11243 100644 --- a/routes +++ b/routes @@ -79,6 +79,7 @@ /workflows GlobalWorkflowWorkflowListR GET !¬empty /workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR: / GWWWorkflowR GET POST !workflow + /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow /edit GWWEditR GET POST /delete GWWDeleteR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index f6b080d25..4183bf75d 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -77,6 +77,9 @@ decCryptoIDs [ ''SubmissionId , ''WorkflowWorkflowId ] +type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex" +type CryptoUUIDWorkflowStateIndex = CryptoUUID WorkflowStateIndex + decCryptoIDKeySize -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 5a9456e3d..ed45b494c 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1224,6 +1224,8 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do return Authorized case route of + _ | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute -> wInstances rScope + _ | Just (rScope, WorkflowWorkflowListR) <- route ^? _WorkflowScopeRoute -> wWorkflows rScope EExamListR -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do @@ -1243,8 +1245,6 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return Authorized - GlobalWorkflowInstanceListR -> wInstances WSGlobal - GlobalWorkflowWorkflowListR -> wWorkflows WSGlobal r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do @@ -1364,7 +1364,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do orAR' = shortCircuitM (is _Authorized) (orAR mr) _andAR' = shortCircuitM (is _Unauthorized) (andAR mr) - wInitiate win scope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do + wInitiate win rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do + scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope let wiGraph :: WorkflowGraph FileReference UserId @@ -1376,11 +1377,12 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do let evalRole role = lift $ evalWorkflowRoleFor mAuthId Nothing role route isWrite checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) - ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + return Authorized wWorkflow isWrite' cID | isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do - wwId <- decrypt cID + wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId let @@ -1397,9 +1399,10 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) - ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + return Authorized | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do - wwId <- decrypt cID + wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId let @@ -1410,18 +1413,36 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do WorkflowAction{..} <- otoList workflowWorkflowState (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph guard $ node == wpTo - return wgnViewers + WorkflowNodeView{..} <- hoistMaybe wgnViewers + return $ toNullable wnvViewers payloadViewers = do WorkflowAction{..} <- otoList workflowWorkflowState payload <- Map.keys wpPayload fmap (toNullable . wpvViewers) . hoistMaybe $ wgPayloadView wwGraph Map.!? payload evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite - ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers) + guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers) + return Authorized + wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do + wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID + WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId + stIx <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decryptWorkflowStateIndex wwId stCID + let + wwGraph :: WorkflowGraph FileReference UserId + wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId) + + payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> wgPayloadView wwGraph + evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite + guardM . anyM (otoList payloadViewers) $ fmap (is _Authorized) . evalRole + WorkflowAction{wpTo} <- workflowStateIndex stIx workflowWorkflowState + WorkflowNodeView{wnvViewers} <- hoistMaybe $ wgnViewers =<< wgNodes wwGraph Map.!? wpTo + guardM . anyM (otoList wnvViewers) $ fmap (is _Authorized) . evalRole + return Authorized case route of - GlobalWorkflowInstanceR win GWIInitiateR -> wInitiate win WSGlobal - GlobalWorkflowWorkflowR cID GWWWorkflowR -> wWorkflow isWrite cID + _ | Just (rScope, WorkflowInstanceR win WIInitiateR) <- route ^? _WorkflowScopeRoute -> wInitiate win rScope + _ | Just (_, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute -> wWorkflow isWrite cID + _ | Just (_, WorkflowWorkflowR wwCID (WWFilesR wpl stCID)) <- route ^? _WorkflowScopeRoute -> wFiles wwCID wpl stCID r -> $unsupportedAuthPredicate AuthWorkflow r tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do MsgRenderer mr <- ask @@ -1625,7 +1646,7 @@ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBi uid <- maybeExceptT AuthenticationRequired $ return mAuthId wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId - let uids = maybe Set.empty getLast . foldMap (fmap Last . assertM' (not . Set.null)) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState + let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState unless (uid `Set.member` uids) $ throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch return Authorized diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index cde035bb4..42a820930 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -15,6 +15,7 @@ module Foundation.I18n , ShortStudyFieldType(..) , StudyDegreeTermType(..) , ErrorResponseTitle(..) + , WorkflowPayloadBool(..) , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient @@ -348,6 +349,10 @@ instance HasResolution a => ToMessage (Fixed a) where newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) +newtype WorkflowPayloadBool = WorkflowPayloadBool { unWorkflowPayloadBool :: Bool } +embedRenderMessageVariant ''UniWorX ''WorkflowPayloadBool ("WorkflowPayloadBool" <>) + + newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX] deriving stock (Generic, Typeable) deriving newtype (Semigroup, Monoid) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index ee0841954..0a9c24d57 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -359,6 +359,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbGlobalWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowInstanceListR + GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3574f5181..bacf86058 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -23,6 +23,8 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild)) +import qualified Data.Map as Map + yesodMiddleware :: ( BearerAuthSite UniWorX , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) @@ -160,6 +162,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . , ncExternalExam , ncAdminWorkflowDefinition , ncWorkflowInstance + , ncWorkflowPayloadLabel , verifySubmission , verifyCourseApplication , verifyCourseNews @@ -250,6 +253,14 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . caseChanged win workflowInstanceName return $ route & typesUsing @RouteChildren @WorkflowInstanceName . filtered (== win) .~ workflowInstanceName + ncWorkflowPayloadLabel = maybeOrig $ \route -> do + (_, WorkflowWorkflowR cID (WWFilesR wpl _)) <- hoistMaybe $ route ^? _WorkflowScopeRoute + wwId <- decrypt cID + WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId . lift $ get wwId + [wpl'] <- return . filter (== wpl) . Map.keys $ wgPayloadView workflowWorkflowGraph + (caseChanged `on` unWorkflowPayloadLabel) wpl wpl' + return $ route + & typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl' verifySubmission = maybeOrig $ \route -> do CSubmissionR _tid _ssh _csh _shn cID sr <- return route sId <- $cachedHereBinary cID $ decrypt cID diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index 608450a11..f188416c5 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -18,7 +18,7 @@ data WorkflowInstanceR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowWorkflowR - = WWWorkflowR | WWEditR | WWDeleteR + = WWWorkflowR | WWFilesR WorkflowPayloadLabel CryptoUUIDWorkflowStateIndex | WWEditR | WWDeleteR deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -31,30 +31,32 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute where toRoute = \case WSGlobal -> \case - WorkflowInstanceListR -> GlobalWorkflowInstanceListR - WorkflowInstanceNewR -> GlobalWorkflowInstanceNewR - WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of + WorkflowInstanceListR -> GlobalWorkflowInstanceListR + WorkflowInstanceNewR -> GlobalWorkflowInstanceNewR + WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of WIEditR -> GWIEditR WIDeleteR -> GWIDeleteR WIWorkflowsR -> GWIWorkflowsR WIInitiateR -> GWIInitiateR - WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR - WorkflowWorkflowR cID subRoute -> GlobalWorkflowWorkflowR cID $ case subRoute of - WWWorkflowR -> GWWWorkflowR - WWEditR -> GWWEditR - WWDeleteR -> GWWDeleteR + WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR + WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of + WWWorkflowR -> GWWWorkflowR + WWFilesR wpl stCID -> GWWFilesR wpl stCID + WWEditR -> GWWEditR + WWDeleteR -> GWWDeleteR other -> error $ "not implemented _WorkflowScopeRoute for: " <> show other toWorkflowScopeRoute = \case - GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR ) - GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR ) - GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of + GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR ) + GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR ) + GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of GWIEditR -> WIEditR GWIDeleteR -> WIDeleteR GWIWorkflowsR -> WIWorkflowsR GWIInitiateR -> WIInitiateR - GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR ) - GlobalWorkflowWorkflowR cID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR cID $ case subRoute of - GWWWorkflowR -> WWWorkflowR - GWWEditR -> WWEditR - GWWDeleteR -> WWDeleteR + GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR ) + GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of + GWWWorkflowR -> WWWorkflowR + GWWFilesR wpl stCID -> WWFilesR wpl stCID + GWWEditR -> WWEditR + GWWDeleteR -> WWDeleteR _other -> Nothing diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index a41aa4c55..ad03a18a4 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -10,6 +10,7 @@ import Utils.Form import Utils.Workflow import Handler.Utils.Form import Handler.Utils.Workflow.CanonicalRoute +import Handler.Utils.Widgets import qualified ListT @@ -36,6 +37,7 @@ import Control.Monad.Trans.RWS.Strict (RWST, evalRWST) import Data.Bitraversable import Data.List (findIndex) +import qualified Data.List as List (delete) import qualified Data.Aeson as Aeson import qualified Data.Scientific as Scientific @@ -107,6 +109,8 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do return (wgeDisplayLabel, wgeForm) _other -> mzero + guard . not $ null edges + -- edgesOptList :: OptionList (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) edgesOptList <- do sBoxKey <- secretBoxKey @@ -124,7 +128,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do let olOptions = concat $ do let optSort = (compareUnicode `on` (Text.toLower . optionDisplay)) <> comparing (fallbackSortKey . optionInternalValue) - where fallbackSortKey = toDigest . kmaclazy ("workflow-edge-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode + where fallbackSortKey = toDigest . kmaclazy ("workflow-edge-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (mwwId, ) where toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString toDigest = BA.convert opts <- sortBy optSort olOptions' @@ -156,7 +160,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do payloadSpec' <- traverseOf (typesCustom @WorkflowChildren @(WorkflowPayloadSpec FileReference UserId) @(WorkflowPayloadSpec FileReference CryptoUUIDUser) @UserId @CryptoUUIDUser) encrypt payloadSpec let toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString toDigest = BA.convert - fallbackSortKey = toDigest . kmaclazy ("workflow-edge-form-payload-field-sorting" :: ByteString) (Saltine.encode sBoxKey) $ Aeson.encode payloadSpec' + fallbackSortKey = toDigest . kmaclazy ("workflow-edge-form-payload-field-sorting" :: ByteString) (Saltine.encode sBoxKey) $ Aeson.encode (mwwId, payloadSpec') return (Right fallbackSortKey, payloadSpec) orderedFields' <- flip evalStateT 1 . for orderedFields $ \x@(payloadLabel, _) -> do @@ -187,9 +191,9 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do fields' <- let payloadReferenceAdjacency = fieldsMap <&> setOf (_2 . _1 . folded . _Left) - fieldsMap :: Map WorkflowPayloadLabel ((Text, Bool), ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)))], [FieldView UniWorX])) + fieldsMap :: Map WorkflowPayloadLabel ((Text, Bool), ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX])) fieldsMap = Map.fromList fields - resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)))], [FieldView UniWorX])))] + resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX])))] resolveReferences Topograph.G{gVertices, gFromVertex} = resort . Map.toList . flip execState Map.empty . for topoOrder $ \payloadLabel -> whenIsJust (Map.lookup payloadLabel fieldsMap) $ \(payloadDisplay, (payloadRes, payloadFieldViews)) -> State.modify' $ \oldState -> let payloadRes' = flip concatMap payloadRes $ \case Right res -> pure res @@ -202,7 +206,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do fmap Map.fromList . for fields' $ \(payloadLabel, ((payloadDisplayLabel, isOptional), (payloadRes, payloadFieldViews))) -> (payloadLabel, ) <$> do $logWarnS "WorkflowEdgeForm" $ toPathPiece payloadLabel <> ": " <> tshow payloadRes - let payloadRes' = let res = foldMap (views _2 . fmap $ maybe Set.empty Set.singleton) payloadRes + let payloadRes' = let res = foldMap (views _2 . fmap $ maybe Set.empty (Set.fromList . otoList)) payloadRes in if | doErrMsg -> FormFailure $ view _FormFailure res ++ pure (mr $ MsgWorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel) | otherwise -> res doErrMsg = flip none payloadRes $ \res -> view _1 res || hasn't (_2 . _FormSuccess) res @@ -235,25 +239,52 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do workflowEdgePayloadFields :: [WorkflowPayloadSpec FileReference UserId] -> Maybe [WorkflowFieldPayloadW FileReference UserId] - -> WForm Handler ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)))], All) -- ^ @isFilled@, @foldMap ala All . map isOptional@ + -> WForm Handler ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], All) -- ^ @isFilled@, @foldMap ala All . map isOptional@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpecField) Nothing . fromMaybe [] where renderSpecField :: WorkflowPayloadSpec FileReference UserId - -> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))) + -> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))) renderSpecField (WorkflowPayloadSpec (specField :: WorkflowPayloadField FileReference UserId payload)) = do - let f isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped . mapped) (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx) + let f' :: forall payload' payload''. + _ + => (payload' -> Maybe (NonEmpty payload'')) + -> Bool -- ^ @isOpt@ + -> Field Handler payload' + -> FieldSettings UniWorX + -> Maybe payload' + -> _ ((Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))) + f' toNonEmpty' isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped) (fmap (fmap . review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . toNonEmpty' =<<) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx) + f :: forall payload'. + _ + => Bool -- ^ @isOpt@ + -> Field Handler payload' + -> FieldSettings UniWorX + -> Maybe payload' + -> _ ((Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))) + f = f' (nonEmpty . pure) + extractPrevs :: forall payload' m xs. + ( IsWorkflowFieldPayload' FileReference UserId payload' + , State.MonadState [WorkflowFieldPayloadW FileReference UserId] m + ) + => (payload' -> Maybe xs -> Maybe xs) + -> m (Maybe xs) + extractPrevs accum = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload) + where go (mPrev', xs) (Left x) = (mPrev', xs ++ [x]) + go (acc, xs) (Right p) = case accum p acc of + acc'@(Just _) -> (acc', xs) + Nothing -> (acc, xs ++ [_WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload # p]) extractPrev :: forall payload' m. - ( IsWorkflowFieldPayload FileReference UserId payload' + ( IsWorkflowFieldPayload' FileReference UserId payload' , State.MonadState [WorkflowFieldPayloadW FileReference UserId] m ) => m (Maybe payload') - extractPrev = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) - where go (mPrev' , xs) (Left x ) = (mPrev', xs ++ [x]) - go (Nothing, xs) (Right p ) = (Just p, xs) - go (Just p , xs) (Right p') = (Just p, xs ++ [_WorkflowFieldPayloadW . _WorkflowFieldPayload # p']) + extractPrev = extractPrevs $ \p -> \case + Nothing -> Just p + Just _ -> Nothing wSetTooltip' :: _ => Maybe Html -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a wSetTooltip' tip = hoist (hoist (wSetTooltip tip)) + MsgRenderer mr <- getMsgRenderer LanguageSelectI18n{..} <- getLanguageSelectI18n mNudge <- ask @@ -262,7 +293,7 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec prev <- extractPrev @Text wSetTooltip' (fmap slI18n wpftTooltip) $ f wpftOptional - (textField & cfStrip) + (bool (textField & cfStrip) (textareaField & isoField _Wrapped & cfStrip) wpftLarge) ( fsl (slI18n wpftLabel) & maybe id (addPlaceholder . slI18n) wpftPlaceholder & maybe id (addName . ($ "text")) mNudge @@ -294,10 +325,23 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec & maybe id (addName . ($ "bool")) mNudge ) (prev <|> wpfbDefault) + WorkflowPayloadFieldDay{..} -> do + prev <- extractPrev @Day + wSetTooltip' (fmap slI18n wpfdTooltip) $ + f wpfdOptional + dayField + ( fsl (slI18n wpfdLabel) + & maybe id (addName . ($ "day")) mNudge + ) + (prev <|> wpfdDefault) WorkflowPayloadFieldFile{..} -> do - fRefs <- extractPrev @(Set FileReference) + fRefs <- extractPrevs @FileReference $ \p -> if + | fieldMultiple wpffConfig -> Just . maybe (Set.singleton p) (Set.insert p) + | otherwise -> \case + Nothing -> Just $ Set.singleton p + Just _ -> Nothing wSetTooltip' (fmap slI18n wpffTooltip) $ - f wpffOptional + f' (nonEmpty . Set.toList) wpffOptional (convertFieldM (\p -> runConduit $ transPipe liftHandler p .| C.foldMap Set.singleton) yieldMany . genericFileField $ return wpffConfig) ( fsl (slI18n wpffLabel) & maybe id (addName . ($ "file")) mNudge @@ -316,29 +360,44 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec ) (fRefs <|> wpfuDefault) WorkflowPayloadFieldCaptureUser -> do - mAuthId <- liftHandler maybeAuthId + mAuthId <- liftHandler maybeAuth case mAuthId of - Just uid -> (True, FormSuccess $ _Just . _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True) + Just (Entity uid User{userDisplayName, userSurname}) -> do + fvId <- newIdent + State.modify . List.delete $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid + lift . lift . lift . tell $ pure FieldView + { fvLabel = [shamlet|#{mr MsgWorkflowEdgeFormFieldCaptureUserLabel}|] + , fvTooltip = Nothing + , fvId + , fvInput = [whamlet| + $newline never + + ^{nameWidget userDisplayName userSurname} + |] + , fvErrors = Nothing + , fvRequired = False + } + (True, FormSuccess . Just . (:| []) $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True) Nothing -> (False, FormMissing) <$ tell (All False) WorkflowPayloadFieldReference{..} -> throwE wpfrTarget WorkflowPayloadFieldMultiple{..} -> do - fRefs <- extractPrev @(NonEmpty (WorkflowFieldPayloadW FileReference UserId)) + fRefs <- nonEmpty <$> State.state (maybe (, []) (splitAt . fromIntegral) $ (+ wpfmMin) <$> wpfmRange) miIdent <- newIdent wSetTooltip' (fmap slI18n wpfmTooltip) $ let mPrev' :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)) mPrev' = fRefs <|> wpfmDefault - mPrev :: Maybe (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId), Maybe (WorkflowFieldPayloadW FileReference UserId))) - mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just x)) $ maybe [] otoList mPrev' + mPrev :: Maybe (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId), Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))) + mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just $ x :| [])) $ mPrev' ^.. _Just . folded where - ensureLength :: forall a. [(Maybe a, Maybe a)] -> [(Maybe a, Maybe a)] + ensureLength :: forall a b. [(Maybe a, Maybe b)] -> [(Maybe a, Maybe b)] ensureLength = (\l -> (l ++) $ replicate (fromIntegral wpfmMin - length l) (Nothing, Nothing)) . maybe id (take . fromIntegral) ((+ wpfmMin) <$> wpfmRange) mangleResult :: forall a. - FormResult (Map ListPosition (a, Maybe (WorkflowFieldPayloadW FileReference UserId))) - -> (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))) + FormResult (Map ListPosition (a, Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))) + -> (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))) -- FieldMultiple are always filled since `massInput` ensures cardinality constraints (iff @mPrev'@ correctly initializes `massInput` with a list of fields of the appropriate length) mangleResult res = case matching _FormSuccess res of Right ress - -> (True, FormSuccess . fmap (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . nonEmpty $ ress ^.. folded . _2 . _Just) + -> (True, FormSuccess . nonEmpty $ ress ^.. folded . _2 . _Just . folded) Left res' -> (False, res') runMI :: forall a. @@ -361,31 +420,30 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec -> FieldView UniWorX -> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget)) miAdd _pos _dim nudge submitView = Just $ \csrf -> over (_1 . _FormSuccess) tweakRes <$> miForm nudge (Left submitView) csrf - where tweakRes :: Maybe (WorkflowFieldPayloadW FileReference UserId) + where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)) -> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))) - tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (pure newDat) + tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (map Just $ newDat ^.. _Just . folded) where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData miCell :: ListPosition -> Maybe (WorkflowFieldPayloadW FileReference UserId) - -> Maybe (Maybe (WorkflowFieldPayloadW FileReference UserId)) + -> Maybe (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))) -> (Text -> Text) - -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget)) - miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe dat mPrev'' + -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget)) + miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe (fmap (:| []) dat) mPrev'' miForm :: (Text -> Text) - -> Either (FieldView UniWorX) (Maybe (WorkflowFieldPayloadW FileReference UserId)) - -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget)) + -> Either (FieldView UniWorX) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))) + -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget)) miForm nudge mode csrf = do - let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))), Ints, Enctype) - -> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))), [FieldView UniWorX]), Ints, Enctype) + let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), Ints, Enctype) + -> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), [FieldView UniWorX]), Ints, Enctype) runSpecRender mSR = do ((eRes, s, w), fvs) <- lift $ runWriterT mSR ExceptT . return $ (, s, w) . (, fvs) <$> eRes - ((fFilled, fmRes), fvs') <- mapRWST runSpecRender . fmap (view _1) $ evalRWST (runExceptT $ renderSpecField wpfmSub) (Just $ fromMaybe id mNudge . nudge) (mode ^.. _Right . _Just) + ((fFilled, fmRes), fvs') <- mapRWST runSpecRender . fmap (view _1) $ evalRWST (runExceptT $ renderSpecField wpfmSub) (Just $ fromMaybe id mNudge . nudge) (mode ^.. _Right . _Just . folded) - MsgRenderer mr <- getMsgRenderer let fFilled' = fFilled || isn't _FormSuccess fmRes fmRes' | not fFilled' = FormFailure . pure . maybe (mr MsgValueRequired) (mr . valueRequired) $ fvs ^? _head . to fvLabel' | otherwise = fmRes @@ -435,7 +493,7 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec p -> Maybe (SomeRoute UniWorX) miButtonAction _ = Nothing - miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (WorkflowFieldPayloadW FileReference UserId)) + miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))) miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflow-payload-field-multiple/layout") in runMI . fmap mangleResult $ massInputW MassInput{..} (fslI $ slI18n wpfmLabel) False mPrev diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs index 9085a34c8..e09abd263 100644 --- a/src/Handler/Utils/Workflow/Form.hs +++ b/src/Handler/Utils/Workflow/Form.hs @@ -28,6 +28,8 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Aeson as JSON +import Utils.Workflow.Lint + newtype FileIdent = FileIdent (CI Text) deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -125,6 +127,18 @@ validateWorkflowGraphForm = do fIdentsAvailable <- uses _wgfFiles Map.keysSet forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowFileIdentDoesNotExist . views _Wrapped CI.original + graph <- use _wgfGraph + for_ (lintWorkflowGraph graph) $ \lintIssues -> do + addMessageModal Warning (i18n MsgWorkflowDefinitionWarningLinterIssuesMessage) $ Right + [whamlet| + $newline never + _{MsgWorkflowDefinitionWarningLinterIssues} +