diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 8092e58b7..fda5a0551 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1426,3 +1426,69 @@ pre, tt, code .workflow-instance--actions margin: 0 0 0.5rem 11px + +.workflow-history + @extend .list--iconless + + display: flex + flex-direction: column + position: relative + + .workflow-history--item + border: 1px solid var(--color-grey) + align-self: flex-start + padding: 7px + margin: 12px 0 + min-width: 45% + display: grid + grid-template-areas: 'user time' 'action-states action-states' 'payload payload' + + &.workflow-history-item__self + align-self: flex-end + + &:last-child + margin-bottom: 0 + &:first-child + margin-bottom: 0 + + .workflow-history--item-user + grid-area: user + .workflow-history--item-time + grid-area: time + text-align: right + .workflow-history--item-action-states + grid-area: action-states + + margin-top: 7px + + .deflist__dt, .deflist__dd + padding-top: 0 + padding-bottom: 0 + .workflow-history--item-payload-changes + grid-area: payload + + margin-top: 12px + border-top: 1px solid var(--color-grey) + padding-top: 12px + + .workflow-history--item-payload-changes-label + font-size: 20px + font-weight: 600 + + + .workflow-history--item-user-special, .workflow-history--item-action-special, .workflow-history--item-state-special + @extend .explanation + +.workflow-state + margin-top: 7px + + .deflist__dt, .deflist__dd + padding-top: 0 + padding-bottom: 0 + +.workflow-payload + margin-top: 12px + + .workflow-payload--label + font-size: 20px + font-weight: 600 diff --git a/frontend/src/utils/form/datepicker.js b/frontend/src/utils/form/datepicker.js index 9c66b0d1f..21b09eb19 100644 --- a/frontend/src/utils/form/datepicker.js +++ b/frontend/src/utils/form/datepicker.js @@ -231,8 +231,6 @@ export class Datepicker { // format the date value of the form input element of this datepicker before form submission this._element.form.addEventListener('submit', this._submitHandler.bind(this)); - - window.addEventListener('beforeunload', this._beforeUnloadHandler.bind(this)); } destroy() { @@ -276,23 +274,6 @@ export class Datepicker { 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. diff --git a/frontend/src/utils/form/navigate-away-prompt.js b/frontend/src/utils/form/navigate-away-prompt.js index 61627ddba..8890e198e 100644 --- a/frontend/src/utils/form/navigate-away-prompt.js +++ b/frontend/src/utils/form/navigate-away-prompt.js @@ -98,9 +98,8 @@ export class NavigateAwayPrompt { // allow the event to happen if the form was not touched by the // user (i.e. if the current FormData is equal to the initial FormData) // or the unload event was initiated by a form submit - if (!formDataHasChanged || this._unloadDueToSubmit) { - return false; - } + if (!formDataHasChanged || this._unloadDueToSubmit) + return; // cancel the unload event. This is the standard to force the prompt to appear. event.preventDefault(); diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d511560ae..b6afc568c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -3017,7 +3017,15 @@ WorkflowWorkflowWorkflowHistoryUserHidden: Versteckter Benutzer WorkflowWorkflowWorkflowHistoryUserAutomatic: Automatisch WorkflowWorkflowWorkflowHistoryActionAutomatic: Automatisch WorkflowWorkflowWorkflowHistoryStateHidden: Versteckter Zustand +WorkflowWorkflowWorkflowHistoryActionLabel: Aktion +WorkflowWorkflowWorkflowHistoryFromLabel: Vorheriger Zustand +WorkflowWorkflowWorkflowHistoryToLabel: Neuer Zustand +WorkflowWorkflowWorkflowHistoryPayloadLabel: Datensatz-Änderungen WorkflowWorkflowFilesArchiveName wwCID@CryptoFileNameWorkflowWorkflow wpl@WorkflowPayloadLabel stCID@CryptoUUIDWorkflowStateIndex: #{foldCase (toPathPiece wwCID)}-#{foldCase (toPathPiece stCID)}-#{foldCase (foldMap unidecode (toPathPiece wpl))}.zip +WorkflowWorkflowWorkflowStateHeading: Zustand/Daten +WorkflowWorkflowWorkflowPayloadHeading: Aktueller Datensatz +WorkflowWorkflowWorkflowStateStateLabel: Aktueller Zustand +WorkflowWorkflowWorkflowStateStateHidden: Versteckter Zustand WorkflowPayloadFiles: Datei(en) WorkflowPayloadBoolTrue: Ja diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index ed45b494c..265fd9cea 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -16,6 +16,7 @@ module Foundation.Authorization , orAR, andAR, notAR, trueAR, falseAR , evalWorkflowRoleFor, evalWorkflowRoleFor' , hasWorkflowRole + , mayViewWorkflowAction ) where import Import.NoFoundation hiding (Last(..)) @@ -38,7 +39,7 @@ import qualified Data.HashSet as HashSet import qualified Data.Map as Map import Data.Map ((!?)) import qualified Data.Text as Text -import Data.List (findIndex) +import Data.List (findIndex, inits) import Data.Semigroup (Last(..)) import qualified Database.Esqueleto as E @@ -1416,9 +1417,11 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do WorkflowNodeView{..} <- hoistMaybe wgnViewers return $ toNullable wnvViewers payloadViewers = do - WorkflowAction{..} <- otoList workflowWorkflowState - payload <- Map.keys wpPayload - fmap (toNullable . wpvViewers) . hoistMaybe $ wgPayloadView wwGraph Map.!? payload + (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState + prevAct <- hoistMaybe $ prevActs ^? _last + payload <- Map.keys $ wpPayload act + guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act) + fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph) evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers) @@ -1430,13 +1433,13 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do let wwGraph :: WorkflowGraph FileReference UserId wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId) - - payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> wgPayloadView wwGraph + act <- workflowStateIndex stIx $ _DBWorkflowState # workflowWorkflowState + let + cState = wpTo act + payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> Map.findWithDefault Map.empty cState (wgnPayloadView <$> wgNodes 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 + guardM . lift $ mayViewWorkflowAction mAuthId wwId act return Authorized case route of @@ -1686,3 +1689,32 @@ hasWorkflowRole :: ( MonadHandler m hasWorkflowRole mwwId wRole route isWrite = do mAuthId <- maybeAuthId evalWorkflowRoleFor mAuthId mwwId wRole route isWrite + +mayViewWorkflowAction :: forall backend m fileid. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + , BackendCompatible SqlReadBackend backend + , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey + , MonadCatch m + ) + => Maybe UserId + -> WorkflowWorkflowId + -> WorkflowAction fileid UserId + -> ReaderT backend m Bool +mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do + WorkflowWorkflow{..} <- MaybeT $ get wwId + rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope + cID <- catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId + let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph + canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + evalWorkflowRole' role = lift $ is _Authorized <$> evalWorkflowRoleFor mAuthId (Just wwId) role canonRoute False + WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers + guardM $ orM + [ return $ is _Just mAuthId && wpUser == Just mAuthId + , anyM wnvViewers evalWorkflowRole' + , anyM (Map.keys wpPayload) $ \payloadLbl -> maybeT (return False) $ do + WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes) + lift $ anyM wpvViewers evalWorkflowRole' + ] + return True diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index bacf86058..088886e8b 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -257,7 +257,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . (_, 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 + [wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes workflowWorkflowGraph (caseChanged `on` unWorkflowPayloadLabel) wpl wpl' return $ route & typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl' diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index ad03a18a4..a5bdaa33e 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -68,7 +68,7 @@ workflowEdgeForm :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadHandler m' , HandlerSite m' ~ UniWorX - , MonadThrow m' + , MonadCatch m' ) => Either WorkflowInstanceId WorkflowWorkflowId -> Maybe WorkflowEdgeForm @@ -84,8 +84,12 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope , _DBWorkflowGraph # workflowWorkflowGraph ) - wPayload = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState . to workflowStateCurrentPayloads wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo + wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState + mAuthId <- maybeAuthId + wPayload <- case mwwId of + Right wwId -> workflowStateCurrentPayloads <$> filterM (lift . hoist liftHandler . mayViewWorkflowAction mAuthId wwId) (maybe [] otoList wPayload') + Left _ -> return Map.empty rScope <- toRouteWorkflowScope scope @@ -146,7 +150,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do let edges' = flip sortOn edges $ \(edgeIdent, _) -> flip findIndex (olOptions edgesOptList) $ (== edgeIdent) . optionInternalValue let edgeForms :: Map (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (AForm Handler WorkflowEdgeForm) - edgeForms = Map.fromList . flip map edges' $ \(edgeIdent, (_, WorkflowGraphEdgeForm{..})) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do + edgeForms = Map.fromList . flip map edges' $ \(edgeIdent@(tState, _), (_, WorkflowGraphEdgeForm{..})) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do let fieldSort :: [(WorkflowPayloadLabel, [[(Either WorkflowGraphEdgeFormOrder ByteString, WorkflowPayloadSpec FileReference UserId)]])] -> _ fieldSort @@ -166,7 +170,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do orderedFields' <- flip evalStateT 1 . for orderedFields $ \x@(payloadLabel, _) -> do let generateDisplayLabel = State.state $ \n -> (mr $ MsgWorkflowEdgeFormHiddenPayload n, succ n) (mayView, payloadDisplayLabel) <- hoist (lift . lift . runDB) . maybeT ((False, ) <$> generateDisplayLabel) $ do - WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ wgPayloadView graph + WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ Map.findWithDefault Map.empty (fromMaybe tState wState) (wgnPayloadView <$> wgNodes graph) wRoute <- case (mwwId, ctx) of (Right wwId, Right _) -> do cID <- encrypt wwId @@ -184,7 +188,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do payloadFields = workflowEdgePayloadFields payloadSpecs' $ fmap otoList . Map.lookup payloadLabel =<< prevSrc where prevSrc = asum [ wefPayload <$> assertM ((== edgeIdent) . wefEdge) mPrev - , guardOnM mayView wPayload + , guardOn mayView wPayload ] ((payloadRes, isOptional), payloadFieldViews) <- wFormFields payloadFields return ((payloadDisplayLabel, getAll isOptional), (payloadRes, payloadFieldViews)) diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 63e70a541..09ec59873 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -46,7 +46,7 @@ followAutomaticEdges :: forall m. -> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId) followAutomaticEdges WorkflowGraph{..} = go [] where - go :: [(Set WorkflowPayloadLabel, (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed + go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed -> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId) go automaticEdgesTaken history @@ -68,14 +68,16 @@ followAutomaticEdges WorkflowGraph{..} = go [] (nodeLbl, WGN{..}) <- Map.toList wgNodes (edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges guard $ wgeSource == cState - whenIsJust wgePayloadRestriction $ guard . checkPayloadRestriction + whenIsJust wgeRestriction $ guard . checkRestriction return (edgeLbl, nodeLbl) - checkPayloadRestriction :: PredDNF WorkflowPayloadLabel -> Bool - checkPayloadRestriction dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf' + checkRestriction :: PredDNF WorkflowGraphEdgeAutomaticRestriction -> Bool + checkRestriction dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf' where evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred - evalPred PLVariable{..} = plVar `Set.member` filledPayloads - evalPred PLNegated{..} = plVar `Set.notMember` filledPayloads + evalPred PLVariable{ plVar = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled{..} } = wgearPayloadFilled `Set.member` filledPayloads + evalPred PLNegated{ plVar = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled{..} } = wgearPayloadFilled `Set.notMember` filledPayloads + evalPred PLVariable{ plVar = WorkflowGraphEdgeAutomaticRestrictionPreviousNode{..} } = wgearPreviousNode == cState + evalPred PLNegated{ plVar = WorkflowGraphEdgeAutomaticRestrictionPreviousNode{..} } = wgearPreviousNode /= cState dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history - edgeDecisionInput = filledPayloads + edgeDecisionInput = (cState, filledPayloads) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index a44512d14..c30e0475b 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -4,11 +4,13 @@ module Handler.Workflow.Workflow.Workflow , workflowR ) where -import Import +import Import hiding (Last(..)) import Utils.Form import Utils.Workflow +import Data.Semigroup (Last(..)) + import Handler.Utils import Handler.Utils.Workflow.EdgeForm import Handler.Utils.Workflow.CanonicalRoute @@ -16,7 +18,6 @@ import Handler.Utils.Workflow.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, execRWST) @@ -29,12 +30,12 @@ import Crypto.Hash.Algorithms (SHAKE256) import qualified Data.Text as Text import Data.RFC5051 (compareUnicode) -import Data.List (inits) - import qualified Data.Scientific as Scientific import Text.Blaze (toMarkup) import Data.Void (absurd) +import Data.List (inits) + data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHIAHidden | WHIAGone deriving (Generic, Typeable) @@ -45,9 +46,14 @@ data WorkflowHistoryItem = WorkflowHistoryItem , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))] , whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view , whiVia :: Maybe Text - , whiTo :: Text + , whiTo :: Maybe Text } deriving (Generic, Typeable) +data WorkflowCurrentState = WorkflowCurrentState + { wcsState :: Maybe Text + , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))] + } + makePrisms ''WorkflowHistoryItemActor @@ -62,7 +68,7 @@ workflowR :: WorkflowWorkflowId -> Handler Html workflowR wwId = do cID <- encrypt wwId - (mEdge, rScope, workflowHistory) <- runDB $ do + (mEdge, rScope, (workflowState, workflowHistory)) <- runDB $ do WorkflowWorkflow{..} <- get404 wwId rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope mEdgeForm <- workflowEdgeForm (Right wwId) Nothing @@ -81,18 +87,21 @@ workflowR wwId = do redirect canonRoute return ((edgeAct, edgeView), edgeEnc) - workflowHistory <- + (fmap getLast -> workflowState, workflowHistory) <- let go :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadThrow m + , MonadCatch m ) => WorkflowStateIndex -> Maybe WorkflowGraphNodeLabel -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId)) -> WorkflowAction FileReference UserId - -> RWST () [WorkflowHistoryItem] (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) () - go stIx wpFrom currentPayload WorkflowAction{..} = maybeT (return ()) $ do + -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) () + go stIx wpFrom currentPayload act@WorkflowAction{..} = maybeT (return ()) $ do + mAuthId <- maybeAuthId + guardM . lift . lift . hoist liftHandler $ mayViewWorkflowAction mAuthId wwId act + stCID <- encrypt stIx let nodeView nodeLbl = do WorkflowNodeView{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes >>= wgnViewers @@ -102,62 +111,9 @@ workflowR wwId = do 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 <- nodeView wpTo - whiVia <- traverse selectLanguageI18n $ preview _wgeDisplayLabel =<< mVia - - payloadChanges <- State.state $ \oldPayload -> - ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload - , currentPayload - ) - 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) - whiPayloadChanges' <- fmap (map (view _2) . sortBy payloadLabelSort) . forMaybeM (Map.toList payloadChanges) $ \(payloadLbl, newPayload) -> do - WorkflowPayloadView{..} <- hoistMaybe $ Map.lookup payloadLbl wgPayloadView - guardM . 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 (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 - (WFPFile a', _ ) -> absurd a' - (WFPUser a', WFPUser 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 - (WFPUser{}, _ ) -> GT - whiPayloadChanges <- flip mapM whiPayloadChanges' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort) . over _2 (bool Nothing (Just fRoute). getAny)) . execWriterT . flip mapM_ 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 (WFPFile _ ) -> tell (mempty, Any True) - WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid) + whiTo <- lift . runMaybeT $ nodeView wpTo + let wcsState = whiTo - whiFrom <- for wpFrom $ lift . runMaybeT . nodeView - - mAuthId <- maybeAuthId whiUser <- for wpUser $ \wpUser' -> if | is _Just mAuthId , wpUser' == mAuthId -> return WHIASelf @@ -169,17 +125,77 @@ workflowR wwId = do Nothing -> WHIAOther Nothing Just Nothing -> WHIAGone Just (Just uEnt) -> WHIAOther $ Just uEnt - tell $ pure WorkflowHistoryItem{..} + + 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 (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 + (WFPFile a', _ ) -> absurd a' + (WFPUser a', WFPUser 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 + (WFPUser{}, _ ) -> GT + flip mapM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort) . over _2 (bool Nothing (Just fRoute). getAny)) . execWriterT . flip mapM_ 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 (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 + + tell ( Just $ Last WorkflowCurrentState{..} + , pure WorkflowHistoryItem{..} + ) WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph wState = otoList $ review _DBWorkflowState workflowWorkflowState - in fmap (view _2) . (\act -> execRWST act () Map.empty) $ sequence_ + in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . (\act -> execRWST act () Map.empty) $ sequence_ [ go stIx fromSt payload act | fromSt <- Nothing : map (Just . wpTo) wState | act <- wState - | payload <- map (maybe Map.empty workflowStateCurrentPayloads . fromNullable . Seq.fromList) . tailEx $ inits wState | stIx <- [minBound..] + | payload <- map workflowStateCurrentPayloads . tailEx $ inits wState ] - return (mEdge, rScope, workflowHistory) + return (mEdge, rScope, (workflowState, workflowHistory)) sequenceOf_ (_Just . _1 . _1 . _Just) mEdge @@ -223,7 +239,8 @@ getGWWFilesR wwCID wpl stCID = do WorkflowWorkflow{..} <- get404 wwId stIx <- decrypt stCID payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState - payloads' <- maybe notFound return . Map.lookup wpl $ workflowStateCurrentPayloads payloads + mAuthId <- maybeAuthId + payloads' <- fmap (Map.findWithDefault Set.empty wpl . workflowStateCurrentPayloads) . filterM (mayViewWorkflowAction mAuthId wwId) $ otoList payloads let payloads'' :: [FileReference] payloads'' = payloads' ^.. folded . _WorkflowFieldPayloadW . _WorkflowFieldPayload diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index f662e6395..a0d5aecf8 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -7,6 +7,7 @@ module Model.Types.Workflow , WorkflowNodeView(..) , WorkflowGraphEdgeLabel , WorkflowGraphEdge(..) + , WorkflowGraphEdgeAutomaticRestriction(..) , WorkflowGraphEdgeFormOrder , WorkflowGraphEdgeForm(..) , WorkflowRole(..) @@ -61,7 +62,6 @@ import Utils.Lens.TH data WorkflowGraph fileid userid = WorkflowGraph { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) - , wgPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView userid) } deriving (Generic, Typeable) @@ -79,6 +79,7 @@ data WorkflowGraphNode fileid userid = WGN { wgnFinal :: Bool , wgnViewers :: Maybe (WorkflowNodeView userid) , wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid) + , wgnPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView userid) } deriving (Generic, Typeable) @@ -97,6 +98,11 @@ newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLab deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) +data WorkflowGraphEdgeAutomaticRestriction + = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled { wgearPayloadFilled :: WorkflowPayloadLabel } + | WorkflowGraphEdgeAutomaticRestrictionPreviousNode { wgearPreviousNode :: WorkflowGraphNodeLabel } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data WorkflowGraphEdge fileid userid = WorkflowGraphEdgeManual { wgeSource :: WorkflowGraphNodeLabel @@ -106,8 +112,8 @@ data WorkflowGraphEdge fileid userid , wgeViewActor :: Set (WorkflowRole userid) } | WorkflowGraphEdgeAutomatic - { wgeSource :: WorkflowGraphNodeLabel - , wgePayloadRestriction :: Maybe (PredDNF WorkflowPayloadLabel) + { wgeSource :: WorkflowGraphNodeLabel + , wgeRestriction :: Maybe (PredDNF WorkflowGraphEdgeAutomaticRestriction) } | WorkflowGraphEdgeInitial { wgeActors :: Set (WorkflowRole userid) @@ -430,8 +436,11 @@ instance Typeable userid => IsWorkflowFieldPayload fileid fileid userid userid' -- | otherwise -- -> traceShow ("none", fieldPayload) mempty -workflowStateCurrentPayloads :: forall fileid userid. - WorkflowState fileid userid +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 @@ -596,6 +605,11 @@ deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView pathPieceJSON ''WorkflowFieldPayload' pathPieceJSON ''WorkflowPayloadField' +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 5 + } ''WorkflowGraphEdgeAutomaticRestriction + instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where parseJSON = genericParseJSON workflowNodeViewAesonOptions instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where diff --git a/templates/workflows/workflow.hamlet b/templates/workflows/workflow.hamlet index 23e018c32..8cad7b654 100644 --- a/templates/workflows/workflow.hamlet +++ b/templates/workflows/workflow.hamlet @@ -1,4 +1,46 @@ $newline never +$maybe WorkflowCurrentState{..} <- workflowState +
+

+ _{MsgWorkflowWorkflowWorkflowStateHeading} + +
+
+
+ _{MsgWorkflowWorkflowWorkflowStateStateLabel} +
+ $maybe stLbl <- wcsState + #{stLbl} + $nothing + + _{MsgWorkflowWorkflowWorkflowStateStateHidden} + $if not (onull wcsPayload) +
+
+ _{MsgWorkflowWorkflowWorkflowPayloadHeading} +
+ $forall (payloadLbl, (newPayload, mFileRoute)) <- wcsPayload +
+ #{payloadLbl} +
+ $if is _Nothing mFileRoute && null newPayload + — + $else +