diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 599f8c001..adcfc456e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -273,7 +273,7 @@ button:not(.btn-link), .buttongroup display: grid - grid: min-content / auto-flow 1fr + grid: min-content / auto-flow max-content input[type="submit"][disabled]:not(.btn-link), input[type="button"][disabled]:not(.btn-link), @@ -962,12 +962,15 @@ th, td dd, .dd margin-left: 12px -.explanation - font-style: italic +.note font-size: 0.9rem font-weight: 600 color: var(--color-fontsec) +.explanation + font-style: italic + @extend .note + // SORTABLE TABLE-HEADERS .table__th.sortable position: relative @@ -1401,3 +1404,25 @@ a.breadcrumbs__home pre, tt, code font-family: var(--font-monospace) + +.workflow-instances + margin: 0 + list-style: none + + & > li + margin: 0 0 0.5rem + padding: 0 10px 12px 7px + border-left: 1px solid var(--color-grey) + + &:nth-child(2n) + background-color: rgba(0, 0, 0, 0.015) + + .workflow-instance--name, .workflow-instance--title + font-size: 1.2rem + font-weight: 600 + + .workflow-instance--name + font-family: var(--font-monospace) + + .workflow-instance--actions + margin: 0 0 0.5rem 11px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 7d09a54fa..2b084d944 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -527,6 +527,16 @@ 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 +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 + +WorkflowRoleUserMismatch: Sie sind nicht einer der vom Workflow geforderten Benutzer +WorkflowRoleAlreadyInitiated: Dieser Workflow wurde bereits initiiert +WorkflowRoleNoSuchWorkflowWorkflow: Der angegebene Workflow konnte nicht gefunden werden +WorkflowRoleNoPayload: Dieser Workflow enthält keine Daten EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -1394,6 +1404,7 @@ MenuAdminWorkflowDefinitionInstantiate: Instanziieren MenuWorkflowInstanceDelete: Löschen MenuWorkflowInstanceWorkflows: Laufende Workflows MenuWorkflowInstanceInitiate: Workflow starten +MenuWorkflowInstanceEdit: Bearbeiten MenuWorkflowWorkflowEdit: Editieren MenuWorkflowWorkflowDelete: Löschen MenuGlobalWorkflowInstanceList: Workflows @@ -2963,10 +2974,28 @@ WorkflowInstanceCreated: Instanz angelegt WorkflowInstanceDescriptionTitle: Instanz-Titel WorkflowInstanceWorkflowCount: Workflows +WorkflowInstanceInitiateSuccess: Workflow erfolgreich initiiert + WorkflowDescriptionLanguage: Sprach-Code (RFC1766) WorkflowDescriptionTitle: Titel WorkflowDescription: Beschreibung +GlobalWorkflowInstancesHeading: Workflows (Systemweit) +GlobalWorkflowInstancesTitle: Workflows (Systemweit) + +GlobalWorkflowInstanceInitiateHeading workflowInstanceTitle@Text: Worklow initiieren: #{workflowInstanceTitle} +GlobalWorkflowInstanceInitiateTitle: Worklow initiieren + +WorkflowEdgeNumberedVariant edgeLabel@Text i@Natural: #{edgeLabel} (Variante #{i}) +WorkflowEdgeFormEdge: Aktion +WorkflowEdgeFormHiddenPayload i@Natural: Versteckter Datensatz #{i} +WorkflowEdgeFormPayloadOneFieldRequired: Es muss mindestens ein Feld pro Datensatz ausgefüllt werden +WorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel@Text: Es muss mindestens ein Feld für “#{payloadDisplayLabel}” ausgefüllt werden +WorkflowEdgeFormFieldNumberTooSmall minSci@Scientific: Zahl muss mindestens #{formatScientific Scientific.Generic Nothing minSci} sein +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 + ChangelogItemFeature: Feature ChangelogItemBugfix: Bugfix @@ -2980,4 +3009,4 @@ InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden -InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt \ No newline at end of file +InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt diff --git a/package.yaml b/package.yaml index b072736eb..916b96640 100644 --- a/package.yaml +++ b/package.yaml @@ -154,6 +154,9 @@ dependencies: - data-textual - fastcdc - bimap + - list-t + - insert-ordered-containers + - topograph other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 515cceeff..5a9456e3d 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -14,9 +14,11 @@ module Foundation.Authorization , BearerAuthSite , routeAuthTags , orAR, andAR, notAR, trueAR, falseAR + , evalWorkflowRoleFor, evalWorkflowRoleFor' + , hasWorkflowRole ) where -import Import.NoFoundation +import Import.NoFoundation hiding (Last(..)) import Foundation.Type import Foundation.Routes @@ -26,7 +28,9 @@ import Foundation.DB import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam +import Handler.Utils.Workflow.CanonicalRoute import Utils.Course (courseIsVisible) +import Utils.Workflow import qualified Data.Set as Set import qualified Data.Aeson as JSON @@ -35,6 +39,7 @@ import qualified Data.Map as Map import Data.Map ((!?)) import qualified Data.Text as Text import Data.List (findIndex) +import Data.Semigroup (Last(..)) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -45,6 +50,8 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4) import Data.Aeson.Lens hiding (_Value, key) +import qualified Data.Conduit.Combinators as C + type BearerAuthSite site = ( MonadCrypto (HandlerFor site) @@ -1190,27 +1197,55 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of - EExamListR -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam - E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId - E.||. E.exists (E.from $ \externalExamResult -> - E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId - E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId - ) - guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do - -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return Authorized - r -> $unsupportedAuthPredicate AuthEmpty r +tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do + let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do + scope <- fromRouteWorkflowScope rScope + + let checkAccess (Entity _ WorkflowInstance{..}) + = fmap (is _Authorized) . flip (evalAccessFor mAuthId) True $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) + getInstances = E.selectSource . E.from $ \workflowInstance -> do + E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope) + return workflowInstance + + guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getInstances .| C.mapM checkAccess .| C.or + return Authorized + + wWorkflows rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do + scope <- fromRouteWorkflowScope rScope + + let checkAccess (E.Value wwId) = do + cID <- encrypt wwId + fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do + E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope) + return $ workflowWorkflow E.^. WorkflowWorkflowId + + guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getWorkflows .| C.mapM checkAccess .| C.or + return Authorized + + case route of + EExamListR -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam + E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId + E.||. E.exists (E.from $ \externalExamResult -> + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId + E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId + ) + guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do + -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> 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 Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -1323,7 +1358,71 @@ tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthWorkflow = APHandler $ \_ route _ -> $unsupportedAuthPredicate AuthWorkflow route +tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do + mr <- getMsgRenderer + let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + _andAR' = shortCircuitM (is _Unauthorized) (andAR mr) + + wInitiate win scope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do + Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope + let + wiGraph :: WorkflowGraph FileReference UserId + wiGraph = workflowInstanceGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId) + edges = do + WGN{..} <- wiGraph ^.. _wgNodes . folded + WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded + hoistMaybe . fromNullable $ wgeActors ^.. folded + let + evalRole role = lift $ evalWorkflowRoleFor mAuthId Nothing role route isWrite + checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) + ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + + wWorkflow isWrite' cID + | isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do + wwId <- decrypt cID + WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId + + let + wwGraph :: WorkflowGraph FileReference UserId + wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId) + + wwNode = wpTo $ last workflowWorkflowState + + edges = do + WGN{..} <- wwGraph ^.. _wgNodes . folded + WorkflowGraphEdgeManual{..} <- wgnEdges ^.. folded + guard $ wgeSource == wwNode + hoistMaybe . fromNullable $ wgeActors ^.. folded + + evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite + checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) + ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do + wwId <- decrypt cID + WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId + + let + wwGraph :: WorkflowGraph FileReference UserId + wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId) + + nodeViewers = do + WorkflowAction{..} <- otoList workflowWorkflowState + (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph + guard $ node == wpTo + return wgnViewers + 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) + + case route of + GlobalWorkflowInstanceR win GWIInitiateR -> wInitiate win WSGlobal + GlobalWorkflowWorkflowR cID GWWWorkflowR -> wWorkflow isWrite cID + r -> $unsupportedAuthPredicate AuthWorkflow r tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do MsgRenderer mr <- ask return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite @@ -1417,10 +1516,24 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf return result -evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult -evalAccessFor mAuthId route isWrite = do +evalAccessWithFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessWithFor assumptions mAuthId route isWrite = do + isSelf <- (== mAuthId) <$> liftHandler maybeAuthId + tagActive <- if + | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + | otherwise -> return . AuthTagActive $ const True dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite + let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf + case dnf' of + Nothing -> return Authorized + Just dnf'' -> do + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite + when isSelf $ + tellSessionJson SessionInactiveAuthTags deactivated + return result + +evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor = evalAccessWithFor [] evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB = evalAccessFor @@ -1428,14 +1541,7 @@ evalAccessForDB = evalAccessFor evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId - tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - dnf <- either throwM return $ routeAuthTags route - let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf - case dnf' of - Nothing -> return Authorized - Just dnf'' -> do - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated + evalAccessWithFor assumptions mAuthId route isWrite evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB = evalAccessWith @@ -1483,3 +1589,79 @@ wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff -> m Bool wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route + + +evalWorkflowRoleFor' :: forall m backend. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + , BackendCompatible SqlReadBackend backend + ) + => AuthTagActive + -> Maybe UserId + -> Maybe WorkflowWorkflowId + -> WorkflowRole UserId + -> Route UniWorX + -> Bool + -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult +evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBinary (tagActive, mAuthId, mwwId, wRole, route, isWrite) $ case wRole of + WorkflowRoleUser{..} -> lift . exceptT return return $ do + uid <- maybeExceptT AuthenticationRequired $ return mAuthId + unless (uid == workflowRoleUser) $ + throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch + return Authorized + -- `WorkflowRoleInitiator` now means "during initiation". + -- The old meaning can be emulated via `WorkflowRolePayloadReference`. + WorkflowRoleInitiator{} -> if + | is _Nothing mwwId -> return Authorized + | otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated + -- WorkflowRoleInitiator{} -> exceptT return return $ do + -- wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId + -- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId + -- let WorkflowAction{..} = head workflowWorkflowState + -- wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser + -- lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite + WorkflowRolePayloadReference{..} -> exceptT return return $ do + 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 + unless (uid `Set.member` uids) $ + throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch + return Authorized + WorkflowRoleAuthorized{..} -> evalAuthTags tagActive workflowRoleAuthorized mAuthId route isWrite + +evalWorkflowRoleFor :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + , BackendCompatible SqlReadBackend backend + ) + => Maybe UserId + -> Maybe WorkflowWorkflowId + -> WorkflowRole UserId + -> Route UniWorX + -> Bool + -> ReaderT backend m AuthResult +evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do + isSelf <- (== mAuthId) <$> liftHandler maybeAuthId + tagActive <- if + | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + | otherwise -> return . AuthTagActive $ const True + (result, deactivated) <- runWriterT $ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite + when isSelf $ + tellSessionJson SessionInactiveAuthTags deactivated + return result + +hasWorkflowRole :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + , BackendCompatible SqlReadBackend backend + ) + => Maybe WorkflowWorkflowId + -> WorkflowRole UserId + -> Route UniWorX + -> Bool + -> ReaderT backend m AuthResult +hasWorkflowRole mwwId wRole route isWrite = do + mAuthId <- maybeAuthId + evalWorkflowRoleFor mAuthId mwwId wRole route isWrite diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 02a5d6394..cde035bb4 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -46,6 +46,8 @@ import Data.Text.Lens (packed) import Data.List ((!!)) +import qualified Data.Scientific as Scientific + pluralDE :: (Eq a, Num a) => a -- ^ Count diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 90c2d3888..3574f5181 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -10,6 +10,9 @@ import Foundation.Routes import Foundation.Authorization import Utils.Metrics +import Utils.Workflow + +import Handler.Utils.Workflow.CanonicalRoute import qualified Network.Wai as W import qualified Data.Aeson as JSON @@ -156,10 +159,11 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . , ncExam , ncExternalExam , ncAdminWorkflowDefinition - , ncGlobalWorkflowInstance + , ncWorkflowInstance , verifySubmission , verifyCourseApplication , verifyCourseNews + , verifyWorkflowWorkflow ] where normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX) @@ -239,12 +243,13 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . caseChanged wdn workflowDefinitionName return $ route & typesUsing @RouteChildren @WorkflowDefinitionName . filtered (== wdn) .~ workflowDefinitionName - ncGlobalWorkflowInstance = maybeOrig $ \route -> do - GlobalWorkflowInstanceR wdn _ <- return route - Entity _ WorkflowInstance{..} <- MaybeT . $cachedHereBinary wdn . lift . getBy $ UniqueWorkflowInstance wdn WSGlobal - caseChanged wdn workflowInstanceName + ncWorkflowInstance = maybeOrig $ \route -> do + (rScope, WorkflowInstanceR win _) <- hoistMaybe $ route ^? _WorkflowScopeRoute + dbScope <- fmap (view _DBWorkflowScope) . hoist lift $ fromRouteWorkflowScope rScope + Entity _ WorkflowInstance{..} <- lift . lift . getBy404 $ UniqueWorkflowInstance win dbScope + caseChanged win workflowInstanceName return $ route - & typesUsing @RouteChildren @WorkflowInstanceName . filtered (== wdn) .~ workflowInstanceName + & typesUsing @RouteChildren @WorkflowInstanceName . filtered (== win) .~ workflowInstanceName verifySubmission = maybeOrig $ \route -> do CSubmissionR _tid _ssh _csh _shn cID sr <- return route sId <- $cachedHereBinary cID $ decrypt cID @@ -270,5 +275,11 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr tell . Any $ route /= newRoute return newRoute - - -- TODO: verify*WorkflowWorkflow + verifyWorkflowWorkflow = maybeOrig $ \route -> do + (_, WorkflowWorkflowR cID wwR) <- hoistMaybe $ route ^? _WorkflowScopeRoute + wwId <- decrypt cID + WorkflowWorkflow{..} <- lift . lift $ get404 wwId + rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope + let newRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID wwR) + tell . Any $ route /= newRoute + return newRoute diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index c4ddd7db3..9ed13b7ad 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -177,3 +177,19 @@ redirectAccessWith status url = liftHandler $ do case access of Authorized -> redirectWith status url _ -> permissionDeniedI MsgUnauthorizedRedirect + +redirectAlternatives :: (MonadHandler m, HandlerSite m ~ UniWorX) => NonEmpty (Route (HandlerSite m)) -> m a +redirectAlternatives = go + where + go (nunsnoc -> ([], r)) = redirectAccess r + go (nunsnoc -> (r' : rs, r)) = liftHandler $ do + access <- isAuthorized r' False + case access of + Authorized -> redirect r' + _ -> redirectAlternatives (nsnoc rs r) + + nunsnoc (x :| xs) = case nonEmpty xs of + Nothing -> ([], x) + Just xs' -> over _1 (x :) $ nunsnoc xs' + nsnoc [] x = x :| [] + nsnoc (x' : xs) x = x' :| (xs ++ [x]) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 8523ce973..72130ccdc 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -161,25 +161,22 @@ instance Button UniWorX ButtonSubmitDelete where nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" --- -- Looks like a button, but is just a link (e.g. for create course, etc.) --- data LinkButton = LinkButton (Route UniWorX) --- deriving (Enum, Eq, Ord, Bounded, Read, Show) --- --- instance PathPiece LinkButton where --- LinkButton route = ??? - -linkButton :: Widget -> Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink +-- | Looks like a button, but is just a link (e.g. for create course, etc.) +linkButton :: Widget -- ^ Widget to display if unauthorized + -> Widget -- ^ Button label + -> [ButtonClass UniWorX] + -> SomeRoute UniWorX + -> Widget -- Alternative: Handler.Utils.simpleLink linkButton defWdgt lbl cls url = do - access <- evalAccess (urlRoute url) False - case access of - Unauthorized _ -> defWdgt - _other -> do - url' <- toTextUrl url - [whamlet| - $newline never - - ^{lbl} - |] + access <- hasReadAccessTo $ urlRoute url + if | not access -> defWdgt + | otherwise -> do + url' <- toTextUrl url + [whamlet| + $newline never + + ^{lbl} + |] -------------------------- -- Interactive fieldset -- @@ -847,37 +844,23 @@ uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybeM file File{fileContent = Just fc} <- return f liftHandler . runDB . runConduit $ fc .| C.fold -data FileFieldUserOption a = FileFieldUserOption - { fieldOptionForce :: Bool - , fieldOptionDefault :: a - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -data FileField = FileField - { fieldIdent :: Maybe Text - , fieldUnpackZips :: FileFieldUserOption Bool - , fieldMultiple :: Bool - , fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) - , fieldAdditionalFiles :: Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool) - , fieldMaxFileSize :: Maybe Natural - } deriving (Generic, Typeable) - genericFileField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) - => Handler FileField -> Field m FileUploads + => Handler (FileField FileReference) -> Field m FileUploads genericFileField mkOpts = Field{..} where - permittedExtension :: FileField -> FileName -> Bool + permittedExtension :: FileField FileReference -> FileName -> Bool permittedExtension FileField{..} fTitle - | unpack fTitle `Map.member` fieldAdditionalFiles + | unpack fTitle `Map.member` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles = True | Just exts <- fieldRestrictExtensions = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts | otherwise = True - getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField -> m' (Maybe Text) + getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField FileReference -> m' (Maybe Text) getIdent FileField{..} = do ident <- case fieldIdent of Just ident -> return $ Just ident @@ -891,7 +874,7 @@ genericFileField mkOpts = Field{..} $logDebugS "genericFileField.getIdent" $ tshow ident return ident - getPermittedFiles :: Maybe Text -> FileField -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)) + getPermittedFiles :: Maybe Text -> FileField FileReference -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)) getPermittedFiles mIdent opts@FileField{..} = do sessionFiles <- for mIdent $ \fieldIdent' -> foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles @@ -902,12 +885,12 @@ genericFileField mkOpts = Field{..} $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' return $ mconcat - [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) fieldAdditionalFiles + [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap , sessionFiles' - , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) fieldAdditionalFiles + , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap ] - handleUpload :: FileField -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) () + handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) () handleUpload FileField{fieldMaxFileSize} mIdent = C.map (transFile liftHandler) .| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do @@ -1029,10 +1012,10 @@ genericFileField mkOpts = Field{..} fuiChecked | Right sentVals' <- sentVals = fuiTitle `Set.member` sentVals' - | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle fieldAdditionalFiles + | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap = fieldOptionDefault | otherwise = False - fuiSession = fuiTitle `Map.notMember` fieldAdditionalFiles + fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles fuiForced | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles = fieldOptionForce @@ -1066,7 +1049,7 @@ fileFieldMultiple = genericFileField $ return FileField , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = True , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = Map.empty + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldMaxFileSize = Nothing } @@ -1082,7 +1065,7 @@ singleFileField prev = genericFileField $ do , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = False , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = Map.fromList + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] @@ -1095,7 +1078,7 @@ specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = False , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName - , fieldAdditionalFiles = Map.empty + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldMaxFileSize = specificFileMaxSize } where @@ -1109,7 +1092,7 @@ zipFileField doUnpack permittedExtensions = genericFileField $ return FileField , fieldUnpackZips = FileFieldUserOption True doUnpack , fieldMultiple = doUnpack , fieldRestrictExtensions = permittedExtensions - , fieldAdditionalFiles = Map.empty + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldMaxFileSize = Nothing } @@ -1145,7 +1128,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted , fieldUnpackZips = FileFieldUserOption False False , fieldMultiple = True , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = Map.fromList + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs new file mode 100644 index 000000000..608450a11 --- /dev/null +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -0,0 +1,60 @@ +module Handler.Utils.Workflow.CanonicalRoute where + +import Import.NoFoundation +import Foundation.Type +import Foundation.Routes + + +data WorkflowScopeRoute + = WorkflowInstanceListR + | WorkflowInstanceNewR + | WorkflowInstanceR WorkflowInstanceName WorkflowInstanceR + | WorkflowWorkflowListR + | WorkflowWorkflowR CryptoFileNameWorkflowWorkflow WorkflowWorkflowR + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data WorkflowInstanceR + = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data WorkflowWorkflowR + = WWWorkflowR | WWEditR | WWDeleteR + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +_WorkflowScopeRoute :: Prism' + ( Route UniWorX ) + ( WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) + , WorkflowScopeRoute + ) +_WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute + where + toRoute = \case + WSGlobal -> \case + 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 + 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 + 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 + _other -> Nothing diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs new file mode 100644 index 000000000..a41aa4c55 --- /dev/null +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -0,0 +1,454 @@ +module Handler.Utils.Workflow.EdgeForm + ( WorkflowEdgeForm(..) + , workflowEdgeForm, WorkflowEdgeFormException(..) + , workflowEdgeFormToAction + ) where + +import Import hiding (StateT) + +import Utils.Form +import Utils.Workflow +import Handler.Utils.Form +import Handler.Utils.Workflow.CanonicalRoute + +import qualified ListT + +import Data.RFC5051 (compareUnicode) +import qualified Data.Text as Text +import Text.Unidecode (unidecode) + +import qualified Data.Map as Map +import Data.Map ((!), (!?)) +import qualified Data.Set as Set +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap + +import qualified Crypto.MAC.KMAC as Crypto +import qualified Crypto.Saltine.Class as Saltine +import qualified Data.Binary as Binary +import qualified Data.ByteArray as BA +import Crypto.Hash.Algorithms (SHAKE256) + +import qualified Control.Monad.State.Class as State +import Control.Monad.Trans.RWS.Lazy (runRWST, mapRWST) +import Control.Monad.Trans.State.Strict (execState, evalStateT) +import Control.Monad.Trans.RWS.Strict (RWST, evalRWST) + +import Data.Bitraversable + +import Data.List (findIndex) + +import qualified Data.Aeson as Aeson +import qualified Data.Scientific as Scientific + +import Numeric.Lens (subtracting) + +import qualified Data.Conduit.Combinators as C + +import qualified Database.Esqueleto as E + +import qualified Topograph + +import qualified Text.Blaze as Blaze +import qualified Text.Blaze.Renderer.Text as Blaze + + +data WorkflowEdgeForm = WorkflowEdgeForm + { wefEdge :: (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) + , wefPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId)) + } + +data WorkflowEdgeFormException + = WorkflowEdgeFormPayloadFieldReferenceCycle [WorkflowPayloadLabel] + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + +workflowEdgeForm :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadHandler m' + , HandlerSite m' ~ UniWorX + , MonadThrow m' + ) + => Either WorkflowInstanceId WorkflowWorkflowId + -> Maybe WorkflowEdgeForm + -> SqlPersistT m' (Maybe (AForm m WorkflowEdgeForm)) +workflowEdgeForm mwwId mPrev = runMaybeT $ do + MsgRenderer mr <- getMsgRenderer + + ctx <- bitraverse (MaybeT . get) (MaybeT . get) mwwId + let (scope, graph) = case ctx of + Left WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope + , _DBWorkflowGraph # workflowInstanceGraph + ) + Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope + , _DBWorkflowGraph # workflowWorkflowGraph + ) + wPayload = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState . to workflowStateCurrentPayloads + wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo + + rScope <- toRouteWorkflowScope scope + + -- edges :: [((WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel), (I18nText, Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec FileReference UserId)))))] + edges <- ListT.toList $ do + (nodeLabel, WGN{..}) <- ListT.fromFoldable . Map.toList $ wgNodes graph + (edgeLabel, edge) <- ListT.fromFoldable $ Map.toList wgnEdges + ((nodeLabel, edgeLabel), ) <$> case edge of + WorkflowGraphEdgeManual{..} -> do + guard $ Just wgeSource == wState + wwId <- hoistMaybe $ mwwId ^? _Right + cID <- lift $ encrypt wwId + guardM . anyM (Set.toList wgeActors) $ \role -> + lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True + return (wgeDisplayLabel, wgeForm) + WorkflowGraphEdgeInitial{..} -> do + guard $ is _Nothing wState + win <- hoistMaybe $ ctx ^? _Left . _workflowInstanceName + guardM . anyM (Set.toList wgeActors) $ \role -> + lift . lift $ is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)) True + return (wgeDisplayLabel, wgeForm) + _other -> mzero + + -- edgesOptList :: OptionList (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) + edgesOptList <- do + sBoxKey <- secretBoxKey + + let olReadExternal ciphertext = do + edgeIdent <- fromMaybeT . exceptTMaybe $ encodedSecretBoxOpen' sBoxKey ciphertext + guard $ any (\(edgeIdent', _) -> edgeIdent == edgeIdent') edges + return edgeIdent + olOptions' <- ListT.toList $ do + (edgeIdent, (edgeLabel, _)) <- ListT.fromFoldable edges + optionDisplay <- lift $ selectLanguageI18n edgeLabel + let optionInternalValue = edgeIdent + optionExternalValue <- encodedSecretBox' sBoxKey SecretBoxShort edgeIdent + return Option{..} + 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 toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString + toDigest = BA.convert + opts <- sortBy optSort olOptions' + & map (\opt@Option{..} -> (Text.concatMap (pack . unidecode) optionDisplay, opt)) + & foldr (\(k, v) -> InsOrdHashMap.insertWith (<>) k [v]) InsOrdHashMap.empty + & InsOrdHashMap.elems + + if + | [_] <- opts + -> return opts + | otherwise -> do + return $ zipWith (\Option{..} i -> Option{ optionDisplay = mr $ MsgWorkflowEdgeNumberedVariant optionDisplay i, ..}) opts [1..] + return OptionList{..} + + 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 + let fieldSort :: [(WorkflowPayloadLabel, [[(Either WorkflowGraphEdgeFormOrder ByteString, WorkflowPayloadSpec FileReference UserId)]])] + -> _ + fieldSort + = sortOn ((,) <$> foldOf (_2 . folded . folded . _1 . _Left) <*> foldMapOf (_2 . folded . folded . _1 . _Right) (Just . Min)) + . over (traverse . _2) (sortOn $ (,) <$> foldOf (folded . _1 . _Left) <*> foldMapOf (folded . _1 . _Right) (Just . Min)) + . over (traverse . _2 . traverse) (sortOn $ (,) <$> preview (_1 . _Left) <*> preview (_1 . _Right)) + orderedFields <- lift . lift . fmap fieldSort . for (Map.toList wgefFields) $ \(payloadLabel, Set.toList . toNullable -> payloadSpecs) -> fmap (payloadLabel, ) . for payloadSpecs $ \(Map.toList . toNullable -> payloadSpecs') -> for payloadSpecs' $ \(payloadOrder, payloadSpec) -> if + | payloadOrder /= mempty -> return (Left payloadOrder, payloadSpec) + | otherwise -> do + sBoxKey <- secretBoxKey + 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' + return (Right fallbackSortKey, payloadSpec) + + 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 + wRoute <- case (mwwId, ctx) of + (Right wwId, Right _) -> do + cID <- encrypt wwId + return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + (Left _, Left WorkflowInstance{..}) + -> return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) + _other -> error "mwwId and ctx do not agree" + guardM . anyM (Set.toList $ toNullable wpvViewers) $ \role -> + lift . lift $ is _Authorized <$> hasWorkflowRole (mwwId ^? _Right) role wRoute False + (True, ) <$> selectLanguageI18n wpvDisplayLabel + return ((mayView, payloadDisplayLabel), x) + + fields <- for orderedFields' $ \((mayView, payloadDisplayLabel), (payloadLabel, payloadSpecs)) -> (payloadLabel, ) <$> do + let payloadSpecs' = payloadSpecs ^.. folded . folded . _2 + payloadFields = workflowEdgePayloadFields payloadSpecs' $ fmap otoList . Map.lookup payloadLabel =<< prevSrc + where prevSrc = asum + [ wefPayload <$> assertM ((== edgeIdent) . wefEdge) mPrev + , guardOnM mayView wPayload + ] + ((payloadRes, isOptional), payloadFieldViews) <- wFormFields payloadFields + return ((payloadDisplayLabel, getAll isOptional), (payloadRes, payloadFieldViews)) + + 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.fromList fields + resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (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 + Left ref -> Map.lookup ref oldState ^. _Just . _2 . _1 + in Map.insert payloadLabel (payloadDisplay, (payloadRes', payloadFieldViews)) oldState + where + topoOrder = map gFromVertex gVertices + resort = sortOn $ \(payloadLabel, _) -> findIndex (views _1 (== payloadLabel)) fields + in either (throwM . WorkflowEdgeFormPayloadFieldReferenceCycle) return $ Topograph.runG payloadReferenceAdjacency resolveReferences + + 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 + 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 + addErrMsg pErrs = Just + [shamlet| + $newline never + $maybe errs <- pErrs + #{errs} +
+ #{mr MsgWorkflowEdgeFormPayloadOneFieldRequired} + |] + case payloadFieldViews of + [] -> return () + [fv] -> lift . tell . pure $ fv + & _fvRequired .~ not isOptional + & _fvErrors %~ bool id addErrMsg doErrMsg + _other -> do + fvId <- newIdent + let fvLabel = toHtml payloadDisplayLabel + fvTooltip = Nothing + fvInput = renderFieldViews FormStandard payloadFieldViews + fvErrors = bool id addErrMsg doErrMsg Nothing + fvRequired = not isOptional + in lift . tell $ pure FieldView{..} + return payloadRes' + + return . hoistAForm liftHandler . multiActionAOpts edgeForms (return edgesOptList) actFS $ wefEdge <$> mPrev + where + actFS = fslI MsgWorkflowEdgeFormEdge + +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@ +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))) + 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) + extractPrev :: forall payload' m. + ( 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']) + 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)) + + LanguageSelectI18n{..} <- getLanguageSelectI18n + mNudge <- ask + + case specField of + WorkflowPayloadFieldText{..} -> do + prev <- extractPrev @Text + wSetTooltip' (fmap slI18n wpftTooltip) $ + f wpftOptional + (textField & cfStrip) + ( fsl (slI18n wpftLabel) + & maybe id (addPlaceholder . slI18n) wpftPlaceholder + & maybe id (addName . ($ "text")) mNudge + ) + (prev <|> wpftDefault) + WorkflowPayloadFieldNumber{..} -> do + prev <- extractPrev @Scientific + wSetTooltip' (fmap slI18n wpfnTooltip) $ + f wpfnOptional + ( fractionalField + & maybe id (\wpfnMin' -> checkBool (>= wpfnMin') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMin') wpfnMin + & maybe id (\wpfnMax' -> checkBool (>= wpfnMax') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMax') wpfnMax + & maybe id (\wpfnStep' -> flip convertField id . over (maybe id subtracting wpfnMin) $ \n -> fromInteger (round $ n / wpfnStep') * wpfnStep') wpfnStep + ) + ( fsl (slI18n wpfnLabel) + & maybe id (addPlaceholder . slI18n) wpfnPlaceholder + & maybe id (\wpfnMin' -> addAttr "min" . tshow $ formatScientific Scientific.Fixed Nothing wpfnMin') wpfnMin + & maybe id (\wpfnMax' -> addAttr "max" . tshow $ formatScientific Scientific.Fixed Nothing wpfnMax') wpfnMax + & maybe (addAttr "step" "any") (\wpfnStep' -> addAttr "step" . tshow $ formatScientific Scientific.Fixed Nothing wpfnStep') wpfnStep + & maybe id (addName . ($ "number")) mNudge + ) + (prev <|> wpfnDefault) + WorkflowPayloadFieldBool{..} -> do + prev <- extractPrev @Bool + wSetTooltip' (fmap slI18n wpfbTooltip) $ + f (is _Just wpfbOptional) + (maybe checkBoxField (boolField . Just . SomeMessage . slI18n) wpfbOptional) + ( fsl (slI18n wpfbLabel) + & maybe id (addName . ($ "bool")) mNudge + ) + (prev <|> wpfbDefault) + WorkflowPayloadFieldFile{..} -> do + fRefs <- extractPrev @(Set FileReference) + wSetTooltip' (fmap slI18n wpffTooltip) $ + f wpffOptional + (convertFieldM (\p -> runConduit $ transPipe liftHandler p .| C.foldMap Set.singleton) yieldMany . genericFileField $ return wpffConfig) + ( fsl (slI18n wpffLabel) + & maybe id (addName . ($ "file")) mNudge + ) + fRefs + WorkflowPayloadFieldUser{..} -> do + fRefs <- extractPrev @UserId + let suggestions uid = E.from $ \user -> do + E.where_ $ user E.^. UserId E.==. E.val uid + return user + wSetTooltip' (fmap slI18n wpfuTooltip) $ + f wpfuOptional + (checkMap (first $ const MsgWorkflowEdgeFormFieldUserNotFound) Right . userField False $ suggestions <$> fRefs) + ( fslI (slI18n wpfuLabel) + & maybe id (addName . ($ "user")) mNudge + ) + (fRefs <|> wpfuDefault) + WorkflowPayloadFieldCaptureUser -> do + mAuthId <- liftHandler maybeAuthId + case mAuthId of + Just uid -> (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)) + 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' + where + ensureLength :: forall a. [(Maybe a, Maybe a)] -> [(Maybe a, Maybe a)] + 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))) + -- 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) + Left res' + -> (False, res') + runMI :: forall a. + WForm (ExceptT WorkflowPayloadLabel Handler) a + -> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) a + runMI mx = do + r <- lift $ lift ask + s <- lift $ lift State.get + ((a, s', w), w') <- ExceptT . lift . lift . lift . runExceptT . runWriterT $ runRWST mx r s + lift . lift $ do + State.put s' + tell w + lift $ tell w' + lift . tell . All $ wpfmMin <= 0 + return a + + miAdd :: ListPosition + -> Natural + -> (Text -> Text) + -> 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) + -> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) + -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))) + tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (pure newDat) + where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData + + miCell :: ListPosition + -> Maybe (WorkflowFieldPayloadW FileReference UserId) + -> Maybe (Maybe (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'' + + miForm :: (Text -> Text) + -> Either (FieldView UniWorX) (Maybe (WorkflowFieldPayloadW FileReference UserId)) + -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (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) + 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) + + 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 + fvLabel' = toStrict . Blaze.renderMarkup . Blaze.contents . fvLabel -- Dirty, but probably good enough; if not: `censor` writer with actual `Text` in `renderSpecField` and discard that information in `workflowEdgePayloadFields` + fvs | not fFilled' = fvs' <&> \fv -> fv { fvErrors = Just + [shamlet| + $newline never + $maybe errs <- fvErrors fv + #{errs} +
+ #{mr (valueRequired (fvLabel' fv))} + |] + } + | otherwise = fvs' + valueRequired :: forall msg. _ => msg -> ValueRequired UniWorX + valueRequired = ValueRequired + + return ( fmRes' + , case mode of + Left btn -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/add") + Right _ -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/cell") + ) + + miDelete :: forall m. + Monad m + => Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) + -> ListPosition + -> MaybeT m (Map ListPosition ListPosition) + miDelete dat pos = do + ListLength l <- hoistMaybe . preview liveCoords $ Map.keysSet dat + guard $ l > wpfmMin + miDeleteList dat pos + + miAllowAdd :: ListPosition + -> Natural + -> ListLength + -> Bool + miAllowAdd _ _ (ListLength l) = maybe True (l <) $ (+ wpfmMin) <$> wpfmRange + + miAddEmpty :: ListPosition + -> Natural + -> ListLength + -> Set ListPosition + miAddEmpty _ _ _ = Set.empty + + miButtonAction :: forall p. + p -> Maybe (SomeRoute UniWorX) + miButtonAction _ = Nothing + + miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (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 + + +workflowEdgeFormToAction :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => WorkflowEdgeForm + -> m (WorkflowAction FileReference UserId) +workflowEdgeFormToAction WorkflowEdgeForm{..} = do + wpUser <- Just <$> maybeAuthId + wpTime <- liftIO getCurrentTime + return WorkflowAction{..} + where + (wpTo, wpVia) = wefEdge + wpPayload = wefPayload diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs index 637b5a865..9085a34c8 100644 --- a/src/Handler/Utils/Workflow/Form.hs +++ b/src/Handler/Utils/Workflow/Form.hs @@ -26,12 +26,62 @@ import qualified Control.Monad.State.Class as State import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Aeson as JSON + newtype FileIdent = FileIdent (CI Text) deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (ToMessage, ToJSON, FromJSON) makeWrapped ''FileIdent + +newtype instance FileReferenceTitleMap FileIdent add = FileIdentFileReferenceTitleMap + { unFileIdentFileReferenceTitleMap :: Map FilePath (FileIdentFileReferenceTitleMapElem add) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) +data FileIdentFileReferenceTitleMapElem add = FileIdentFileReferenceTitleMapElem + { fIdentTitleMapIdent :: FileIdent + , fIdentTitleMapAdditional :: add + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +makePrisms ''FileIdentFileReferenceTitleMapElem + +instance FileReferenceTitleMapConvertible add FileIdent FileIdent where + _FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileIdentFileReferenceTitleMap . traverse . _FileIdentFileReferenceTitleMapElem + +instance FileReferenceTitleMapConvertible add FileIdent FileReference where + _FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso Map.toList Map.fromList . traverse . iso (view $ _2 . _FileIdentFileReferenceTitleMapElem) (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional)) + +instance FileReferenceTitleMapConvertible add FileReference FileIdent where + _FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileIdentFileReferenceTitleMap . itraverse . (\f fileReferenceTitle FileReferenceFileReferenceTitleMapElem{ fRefTitleMapContent = fileReferenceContent, fRefTitleMapModified = fileReferenceModified, fRefTitleMapAdditional } -> review _FileIdentFileReferenceTitleMapElem <$> f (FileReference{..}, fRefTitleMapAdditional)) + +instance ToJSON (FileField FileIdent) where + toJSON FileField{..} = JSON.object $ catMaybes + [ ("ident" JSON..=) <$> fieldIdent + , pure $ "unpack-zips" JSON..= fieldUnpackZips + , pure $ "multiple" JSON..= fieldMultiple + , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions + , pure $ "max-file-size" JSON..= fieldMaxFileSize + , pure $ "additional-files" JSON..= addFiles' + ] + where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object + [ "ident" JSON..= fIdentTitleMapIdent + , "include" JSON..= fIdentTitleMapAdditional + ] +instance FromJSON (FileField FileIdent) where + parseJSON = JSON.withObject "FileField" $ \o -> do + fieldIdent <- o JSON..:? "ident" + fieldUnpackZips <- o JSON..: "unpack-zips" + fieldMultiple <- o JSON..: "multiple" + fieldRestrictExtensions <- o JSON..:? "restrict-extensions" + fieldMaxFileSize <- o JSON..:? "max-file-size" + addFiles' <- o JSON..:? "additional-files" JSON..!= mempty + fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do + fIdentTitleMapIdent <- o' JSON..: "Ident" + fIdentTitleMapAdditional <- o' JSON..: "include" + return FileIdentFileReferenceTitleMapElem{..} + return FileField{..} + + data WorkflowGraphForm = WorkflowGraphForm { wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index 18257e210..86c5d9270 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -5,6 +5,16 @@ module Handler.Workflow.Instance.Initiate import Import +import Utils.Form +import Utils.Workflow + +import Handler.Utils +import Handler.Utils.Workflow.EdgeForm +import Handler.Utils.Workflow.CanonicalRoute + +import qualified Data.CaseInsensitive as CI +import qualified Data.List.NonEmpty as NonEmpty + getGWIInitiateR, postGWIInitiateR :: WorkflowInstanceName -> Handler Html getGWIInitiateR = postGWIInitiateR @@ -12,4 +22,52 @@ postGWIInitiateR win = workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html -workflowInstanceInitiateR = error "not implemented" +workflowInstanceInitiateR wiId = do + (WorkflowInstance{..}, edgeForm, rScope, mDesc) <- runDB $ do + wi@WorkflowInstance{..} <- get404 wiId + edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing + rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope + + descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] [] + mDesc <- runMaybeT $ do + langs <- hoistMaybe . nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs + lang <- selectLanguage langs + hoistMaybe . preview _head $ do + Entity _ desc@WorkflowInstanceDescription{..} <- descs + guard $ workflowInstanceDescriptionLanguage == lang + return desc + + return (wi, edgeForm, rScope, mDesc) + + ((edgeRes, edgeView'), edgeEnc) <- runFormPost $ renderAForm FormStandard edgeForm + + formResult edgeRes $ \edgeRes' -> do + wwId <- runDB $ do + act <- workflowEdgeFormToAction edgeRes' + + insert WorkflowWorkflow + { workflowWorkflowInstance = Just wiId + , workflowWorkflowScope = workflowInstanceScope + , workflowWorkflowGraph = workflowInstanceGraph + , workflowWorkflowState = view _DBWorkflowState $ act `ncons` mempty + } + + addMessageI Success MsgWorkflowInstanceInitiateSuccess + + cID <- encrypt wwId + redirectAlternatives $ NonEmpty.fromList + [ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR ) + , _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR ) + , _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR ) + ] + + (heading, title) <- case rScope of + WSGlobal -> return (MsgGlobalWorkflowInstanceInitiateHeading $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgGlobalWorkflowInstanceInitiateTitle) + _other -> error "not implemented" + + siteLayoutMsg heading $ do + setTitleI title + let edgeView = wrapForm edgeView' def + { formEncoding = edgeEnc + } + $(widgetFile "workflows/instance-initiate") diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index ad7a61af5..f134ff9ac 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -9,12 +9,16 @@ module Handler.Workflow.Instance.List import Import import Handler.Utils +import Utils.Workflow +import Handler.Utils.Workflow.CanonicalRoute import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI +import qualified Data.List.NonEmpty as NonEmpty + type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance) @@ -121,5 +125,41 @@ getAdminWorkflowInstanceListR = do getGlobalWorkflowInstanceListR :: Handler Html getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal -workflowInstanceListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html -workflowInstanceListR = error "not implemented" +workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html +workflowInstanceListR rScope = do + instances <- runDB $ do + dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope + + wis <- selectList [ WorkflowInstanceScope ==. dbScope ] [] + wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do + descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] [] + desc <- lift . runMaybeT $ do + langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs + lang <- selectLanguage langs + hoistMaybe . preview _head $ do + Entity _ desc@WorkflowInstanceDescription{..} <- descs + guard $ workflowInstanceDescriptionLanguage == lang + return desc + mayInitiate <- hasWriteAccessTo $ toInitiateRoute workflowInstanceName + mayEdit <- hasReadAccessTo $ toEditRoute workflowInstanceName + mayList <- hasReadAccessTo $ toListRoute workflowInstanceName + guard $ mayInitiate || mayEdit || mayList + return (wi, desc) + + return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc) + -> ( NTop workflowInstanceCategory + , workflowInstanceDescriptionTitle <$> mDesc + , workflowInstanceName + ) + + (heading, title) <- case rScope of + WSGlobal -> return (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle) + _other -> error "not implemented" + + siteLayoutMsg heading $ do + setTitleI title + $(widgetFile "workflows/instances") + where + toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) + toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR) + toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index f409abc86..44cac8f2d 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -202,6 +202,8 @@ import Data.Word.Word24 as Import import Data.Kind as Import (Type, Constraint) +import Data.Scientific as Import (Scientific, formatScientific) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 994807a2a..c966ef167 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -76,7 +76,7 @@ workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (S workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. WorkflowDefinitionGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) , E.selectSource (E.from $ pure . (E.^. WorkflowInstanceGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) - , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) + , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . folded @Set . _fileReferenceContent . _Just) yield . E.unValue) ] diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 53f9df9c5..b90739726 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Model.Types.File ( FileContentChunkReference(..), FileContentReference(..) , File(..), _fileTitle, _fileContent, _fileModified @@ -6,6 +8,13 @@ module Model.Types.File , minioFileReference , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual) + , FileReferenceTitleMap(..) + , FileReferenceFileReferenceTitleMapElem(..), _fRefTitleMapContent, _fRefTitleMapModified, _fRefTitleMapAdditional + , _FileReferenceFileReferenceTitleMap + , FileReferenceTitleMapConvertible(..) + , FileFieldUserOption(..), FileField(..) + , _fieldOptionForce, _fieldOptionDefault + , _fieldIdent, _fieldUnpackZips, _fieldMultiple, _fieldRestrictExtensions, _fieldAdditionalFiles, _fieldMaxFileSize ) where import Import.NoModel @@ -26,6 +35,9 @@ import qualified Data.Conduit.Combinators as C import Text.Show +import qualified Data.Aeson as JSON +import qualified Data.Map as Map + newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512) @@ -144,13 +156,27 @@ class HasFileReference record where _FileReference :: Iso' record (FileReference, FileReferenceResidual record) + instance HasFileReference FileReference where data FileReferenceResidual FileReference = FileReferenceResidual + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + -- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) } + -- deriving (Eq, Ord, Read, Show, Generic, Typeable) + -- deriving newtype (Semigroup, Monoid) + -- data FileReferenceTitleMapElem FileReference add = FileReferenceFileReferenceTitleMapElem + -- { fRefTitleMapContent :: FileContentReference + -- , fRefTitleMapModified :: UTCTime + -- , fRefTitleMapAdditional :: add + -- } deriving (Eq, Ord, Read, Show, Generic, Typeable) + _FileReference = iso (, FileReferenceResidual) $ view _1 + -- _FileReferenceTitleMapElem = iso (\FileReferenceFileReferenceTitleMapElem{..} -> (fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional)) (\(fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional) -> FileReferenceFileReferenceTitleMapElem{..}) instance HasFileReference PureFile where newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) _FileReference = iso toFileReference fromFileReference where @@ -168,6 +194,7 @@ instance HasFileReference PureFile where instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } + _FileReference = iso doSplit doJoin where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference doSplit (Left r) = over _2 (FileReferenceResidualEither . Left ) $ r ^. _FileReference @@ -179,6 +206,7 @@ instance HasFileReference record => HasFileReference (Entity record) where { fileReferenceResidualEntityKey :: Key record , fileReferenceResidualEntityResidual :: FileReferenceResidual record } + _FileReference = iso doSplit doJoin where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) where (fRef, res) = entityVal ^. _FileReference @@ -188,3 +216,84 @@ class (PersistEntity record, HasFileReference record) => IsFileReference record fileReferenceTitleField :: EntityField record FilePath fileReferenceContentField :: EntityField record (Maybe FileContentReference) fileReferenceModifiedField :: EntityField record UTCTime + + +data family FileReferenceTitleMap :: Type -> Type -> Type +newtype instance FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap + { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceFileReferenceTitleMapElem add) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) +data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem + { fRefTitleMapContent :: Maybe FileContentReference + , fRefTitleMapModified :: UTCTime + , fRefTitleMapAdditional :: add + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makePrisms ''FileReferenceFileReferenceTitleMapElem + +_FileReferenceFileReferenceTitleMap :: forall add. + Iso' (FileReferenceTitleMap FileReference add) (Map FilePath (Maybe FileContentReference, UTCTime, add)) +_FileReferenceFileReferenceTitleMap = coerced . iso (fmap $ view _FileReferenceFileReferenceTitleMapElem) (fmap $ review _FileReferenceFileReferenceTitleMapElem) + +class FileReferenceTitleMapConvertible add f1 f2 where + _FileReferenceTitleMap :: Traversal (FileReferenceTitleMap f1 add) (FileReferenceTitleMap f2 add) (f1, add) (f2, add) + +instance FileReferenceTitleMapConvertible add FileReference FileReference where + _FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso (map (\(fileReferenceTitle, (FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional)) -> (FileReference{..}, additional)) . Map.toList) (Map.fromList . map (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional))) . traverse + + +data FileFieldUserOption a = FileFieldUserOption + { fieldOptionForce :: Bool + , fieldOptionDefault :: a + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''FileFieldUserOption + +data FileField fileid = FileField + { fieldIdent :: Maybe Text + , fieldUnpackZips :: FileFieldUserOption Bool + , fieldMultiple :: Bool + , fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) + , fieldMaxFileSize :: Maybe Natural + , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) + } deriving (Generic, Typeable) +deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid) +deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid) +deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid) +deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid) + +instance ToJSON (FileField FileReference) where + toJSON FileField{..} = JSON.object $ catMaybes + [ ("ident" JSON..=) <$> fieldIdent + , pure $ "unpack-zips" JSON..= fieldUnpackZips + , pure $ "multiple" JSON..= fieldMultiple + , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions + , pure $ "max-file-size" JSON..= fieldMaxFileSize + , pure $ "additional-files" JSON..= addFiles' + ] + where addFiles' = unFileReferenceFileReferenceTitleMap fieldAdditionalFiles <&> \FileReferenceFileReferenceTitleMapElem{..} -> JSON.object + [ "content" JSON..= fRefTitleMapContent + , "modified" JSON..= fRefTitleMapModified + , "include" JSON..= fRefTitleMapAdditional + ] +instance FromJSON (FileField FileReference) where + parseJSON = JSON.withObject "FileField" $ \o -> do + fieldIdent <- o JSON..:? "ident" + fieldUnpackZips <- o JSON..: "unpack-zips" + fieldMultiple <- o JSON..: "multiple" + fieldRestrictExtensions <- o JSON..:? "restrict-extensions" + fieldMaxFileSize <- o JSON..:? "max-file-size" + addFiles' <- o JSON..:? "additional-files" JSON..!= mempty + fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do + fRefTitleMapContent <- o' JSON..: "content" + fRefTitleMapModified <- o' JSON..: "modified" + fRefTitleMapAdditional <- o' JSON..: "include" + return FileReferenceFileReferenceTitleMapElem{..} + return FileField{..} + +makeLenses_ ''FileFieldUserOption +makeLenses_ ''FileField +makeLenses_ ''FileReferenceFileReferenceTitleMapElem diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 91cfba970..7fc3e256c 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -162,6 +162,7 @@ makePrisms ''PredLiteral deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "val" "var" } ''PredLiteral diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index 1a13635d6..6d77e7e85 100644 --- a/src/Model/Types/TH/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -63,9 +63,8 @@ predNFAesonOptions :: Options -- -- Moved to this module due to stage restriction predNFAesonOptions = defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = ObjectWithSingleField - , tagSingleConstructors = True + { fieldLabelModifier = camelToPathPiece + , tagSingleConstructors = False } diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index f17d3a398..ef137541e 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -3,36 +3,57 @@ module Model.Types.Workflow ( WorkflowGraph(..) , WorkflowGraphNodeLabel + , WorkflowGraphNode(..) + , WorkflowGraphEdgeLabel + , WorkflowGraphEdge(..) + , WorkflowGraphEdgeFormOrder + , WorkflowGraphEdgeForm(..) + , WorkflowRole(..) + , WorkflowPayloadView(..) + , WorkflowPayloadSpec(..), _WorkflowPayloadSpec + , WorkflowPayloadFieldReference + , WorkflowPayloadField(..) , WorkflowScope(..) , WorkflowScope'(..), classifyWorkflowScope + , WorkflowPayloadLabel , WorkflowState - , WorkflowAction(..) + , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime + , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload + , WorkflowFieldPayload(..), _WorkflowFieldPayload + , workflowStatePayload, workflowStateCurrentPayloads , WorkflowChildren ) where import Import.NoModel import Model.Types.Security (AuthDNF) -import Model.Types.File (FileContentReference) +import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..)) import Database.Persist.Sql (PersistFieldSql(..)) -import Data.Scientific import Data.Maybe (fromJust) import Data.Aeson (genericToJSON, genericParseJSON) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON +import qualified Data.Aeson.Encoding as JSON import Data.Aeson.Lens (_Null) import Data.Aeson.Types (Parser) import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Sequence as Seq import qualified Data.CaseInsensitive as CI import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..)) +import Data.Typeable (cast) import Data.Generics.Product.Types +import Unsafe.Coerce + +import Utils.Lens.TH + ----- WORKFLOW GRAPH ----- @@ -40,14 +61,17 @@ data WorkflowGraph fileid userid = WorkflowGraph { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) , wgPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView userid) } - deriving (Eq, Ord, Show, Generic, Typeable) + deriving (Generic, Typeable) +deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid) +deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid) ----- WORKFLOW GRAPH: NODES ----- newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) data WorkflowGraphNode fileid userid = WGN { wgnDisplayLabel :: Maybe I18nText @@ -55,20 +79,51 @@ data WorkflowGraphNode fileid userid = WGN , wgnViewers :: Set (WorkflowRole userid) , wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid) } - deriving (Eq, Ord, Show, Generic, Typeable) + deriving (Generic, Typeable) + +deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid) +deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid) ----- WORKFLOW GRAPH: EDGES ----- newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) data WorkflowGraphEdge fileid userid = WorkflowGraphEdgeManual - { wgeSource :: WorkflowGraphNodeLabel - , wgeActors :: Set (WorkflowRole userid) - , wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid userid))) + { wgeSource :: WorkflowGraphNodeLabel + , wgeActors :: Set (WorkflowRole userid) + , wgeForm :: WorkflowGraphEdgeForm fileid userid + , wgeDisplayLabel :: I18nText + } + | WorkflowGraphEdgeAutomatic + { wgeSource :: WorkflowGraphNodeLabel + } + | WorkflowGraphEdgeInitial + { wgeActors :: Set (WorkflowRole userid) + , wgeForm :: WorkflowGraphEdgeForm fileid userid + , wgeDisplayLabel :: I18nText + } + deriving (Generic, Typeable) + +deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid) +deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid) + +-- | A wrapped `Scientific` +-- +-- Due to arbitrary precision this allows inserting new fields anywhere +newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGraphEdgeFormOrder :: Maybe Scientific } + deriving (Read, Show, Generic, Typeable) + deriving (Eq, Ord) via (NTop (Maybe Scientific)) + deriving (Semigroup, Monoid) via (Maybe (Min Scientific)) + +newtype WorkflowGraphEdgeForm fileid userid + = WorkflowGraphEdgeForm + { wgefFields :: Map WorkflowPayloadLabel (NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid))))) -- ^ field requirement forms a cnf: -- -- - all labels must be filled @@ -76,22 +131,18 @@ data WorkflowGraphEdge fileid userid -- - optional fields are always considered to be filled -- -- since fields can reference other labels this allows arbitrary requirements to be encoded. - } - | WorkflowGraphEdgeAutomatic - { wgeSource :: WorkflowGraphNodeLabel - } - | WorkflowGraphEdgeInitial - { wgeActors :: Set (WorkflowRole userid) - , wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid userid))) - } - deriving (Eq, Ord, Show, Generic, Typeable) + } deriving (Generic, Typeable) +deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid) +deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid) ----- WORKFLOW GRAPH: ROLES / ACTORS ----- data WorkflowRole userid - = WorkflowRoleUser { workflowRoleUser :: userid } - | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF } + = WorkflowRoleUser { workflowRoleUser :: userid } + | WorkflowRolePayloadReference { workflowRolePayloadLabel :: WorkflowPayloadLabel } + | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF } | WorkflowRoleInitiator deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) @@ -106,7 +157,10 @@ data WorkflowPayloadView userid = WorkflowPayloadView data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) deriving (Typeable) -deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid) + +data WorkflowPayloadFieldReference + deriving (Typeable) data WorkflowPayloadField fileid userid (payload :: Type) where WorkflowPayloadFieldText :: { wpftLabel :: I18nText @@ -131,29 +185,37 @@ data WorkflowPayloadField fileid userid (payload :: Type) where } -> WorkflowPayloadField fileid userid Bool WorkflowPayloadFieldFile :: { wpffLabel :: I18nText , wpffTooltip :: Maybe I18nHtml - , wpffDefault :: Maybe fileid + , wpffConfig :: FileField fileid , wpffOptional :: Bool - } -> WorkflowPayloadField fileid userid FileInfo + } -> WorkflowPayloadField fileid userid (Set fileid) WorkflowPayloadFieldUser :: { wpfuLabel :: I18nText , wpfuTooltip :: Maybe I18nHtml , wpfuDefault :: Maybe userid , wpfuOptional :: Bool } -> WorkflowPayloadField fileid userid userid + WorkflowPayloadFieldCaptureUser :: WorkflowPayloadField fileid userid userid WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel - } -> WorkflowPayloadField fileid userid (NonNull (Set (WorkflowFieldPayloadW fileid userid))) + } -> WorkflowPayloadField fileid userid WorkflowPayloadFieldReference + WorkflowPayloadFieldMultiple :: { wpfmLabel :: I18nText + , wpfmTooltip :: Maybe I18nHtml + , wpfmDefault :: Maybe (NonEmpty (WorkflowFieldPayloadW fileid userid)) + , wpfmSub :: WorkflowPayloadSpec fileid userid + , wpfmMin :: Natural + , wpfmRange :: Maybe Natural -- ^ `wpfmMax = (+ wpfmMin) <$> wpfmRange + } -> WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)) deriving (Typeable) -deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadField fileid userid payload) -deriving instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadField fileid userid payload) -deriving instance (Ord fileid, Ord userid) => Ord (WorkflowPayloadField fileid userid payload) +deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadField fileid userid payload) +deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid, Eq (FileField fileid)) => Eq (WorkflowPayloadField fileid userid payload) +deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid, Ord (FileField fileid)) => Ord (WorkflowPayloadField fileid userid payload) -instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowPayloadSpec fileid userid) where +instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowPayloadSpec fileid userid) where (WorkflowPayloadSpec a) == (WorkflowPayloadSpec b) = case typeOf a `eqTypeRep` typeOf b of Just HRefl -> a == b Nothing -> False -instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (WorkflowPayloadSpec fileid userid) where +instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowPayloadSpec fileid userid) where (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b) = case typeOf a `eqTypeRep` typeOf b of Just HRefl -> a `compare` b @@ -173,7 +235,29 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT (WorkflowPayloadFieldUser{}, _) -> LT - (WorkflowPayloadFieldReference{}, _) -> GT + (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldBool{}) -> GT + (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldFile{}) -> GT + (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldUser{}) -> GT + (WorkflowPayloadFieldCaptureUser{}, _) -> LT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldBool{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldFile{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldUser{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureUser{}) -> GT + (WorkflowPayloadFieldReference{}, _) -> LT + (WorkflowPayloadFieldMultiple{}, _) -> GT + +_WorkflowPayloadSpec :: forall payload fileid userid. + ( Typeable payload, Typeable fileid, Typeable userid ) + => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload) +_WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> cast pF + +data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple' + deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) + deriving anyclass (Universe, Finite) ----- WORKFLOW INSTANCE ----- @@ -203,20 +287,20 @@ classifyWorkflowScope = \case newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid)) data WorkflowAction fileid userid = WorkflowAction { wpTo :: WorkflowGraphNodeLabel , wpVia :: WorkflowGraphEdgeLabel - , wpPayload :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowFieldPayloadW fileid userid))) + , wpPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid)) , wpUser :: Maybe (Maybe userid) -- ^ Outer `Maybe` encodes automatic/manual, inner `Maybe` encodes whether user was authenticated , wpTime :: UTCTime } deriving (Eq, Ord, Show, Generic, Typeable) -data WorkflowFieldPayloadW fileid userid = forall payload. Typeable payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) +data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) deriving (Typeable) instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where @@ -236,38 +320,81 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work (WFPBool{}, WFPText{}) -> GT (WFPBool{}, WFPNumber{}) -> GT (WFPBool{}, _) -> LT - (WFPFile{}, WFPText{}) -> GT - (WFPFile{}, WFPNumber{}) -> GT - (WFPFile{}, WFPBool{}) -> GT - (WFPFile{}, _) -> LT - (WFPUser{}, _) -> GT + (WFPFiles{}, WFPText{}) -> GT + (WFPFiles{}, WFPNumber{}) -> GT + (WFPFiles{}, WFPBool{}) -> GT + (WFPFiles{}, _) -> LT + (WFPUser{}, WFPText{}) -> GT + (WFPUser{}, WFPNumber{}) -> GT + (WFPUser{}, WFPBool{}) -> GT + (WFPUser{}, WFPFiles{}) -> GT + (WFPUser{}, _) -> LT + (WFPMultiple{}, _) -> GT instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where show (WorkflowFieldPayloadW payload) = show payload data WorkflowFieldPayload fileid userid (payload :: Type) where - WFPText :: Text -> WorkflowFieldPayload fileid userid Text - WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific - WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool - WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid - WFPUser :: userid -> WorkflowFieldPayload fileid userid userid + WFPText :: Text -> WorkflowFieldPayload fileid userid Text + WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific + WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool + WFPFiles :: Set fileid -> WorkflowFieldPayload fileid userid (Set fileid) + WFPUser :: userid -> WorkflowFieldPayload fileid userid userid + WFPMultiple :: NonEmpty (WorkflowFieldPayloadW fileid userid) -> WorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)) deriving (Typeable) deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload) -deriving instance (Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) -deriving instance (Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) +deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) +deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) -data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPUser' +_WorkflowFieldPayloadW :: forall payload fileid userid. + ( IsWorkflowFieldPayload fileid userid payload, Typeable fileid, Typeable userid ) + => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload) +_WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW fp) -> cast fp + +data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPFiles' | WFPUser' | WFPMultiple' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) deriving anyclass (Universe, Finite) +class Typeable payload => IsWorkflowFieldPayload fileid userid payload where + _WorkflowFieldPayload :: Prism' (WorkflowFieldPayload fileid userid payload) payload ------ PathPiece instances ----- +instance IsWorkflowFieldPayload fileid userid Text where + _WorkflowFieldPayload = prism' WFPText $ \case { WFPText x -> Just x; _other -> Nothing } +instance IsWorkflowFieldPayload fileid userid Scientific where + _WorkflowFieldPayload = prism' WFPNumber $ \case { WFPNumber x -> Just x; _other -> Nothing } +instance IsWorkflowFieldPayload fileid userid Bool where + _WorkflowFieldPayload = prism' WFPBool $ \case { WFPBool x -> Just x; _other -> Nothing } +instance {-# OVERLAPPING #-} Typeable fileid => IsWorkflowFieldPayload fileid userid (Set fileid) where + _WorkflowFieldPayload = prism' WFPFiles $ \case { WFPFiles x -> Just x; _other -> Nothing } +instance {-# OVERLAPPING #-} Typeable userid => IsWorkflowFieldPayload fileid userid userid where + _WorkflowFieldPayload = prism' WFPUser $ \case { WFPUser x -> Just x; _other -> Nothing } +instance (Typeable fileid, Typeable userid) => IsWorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)) where + _WorkflowFieldPayload = iso (\(WFPMultiple x) -> x) WFPMultiple -nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" -nullaryPathPiece ''WorkflowFieldPayload'' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" +workflowStatePayload :: forall fileid userid payload. + ( IsWorkflowFieldPayload fileid userid payload + , Ord fileid, Ord userid, Ord payload + , Typeable fileid, Typeable userid + ) + => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Set payload) +workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.findWithDefault Set.empty label $ fmap (Set.fromList . concatMap extractPayload . otoList) wpPayload + where extractPayload (WorkflowFieldPayloadW fieldPayload) + | Just HRefl <- typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) + = fieldPayload ^.. _WorkflowFieldPayload + | Just HRefl <- typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))) + = concatMap extractPayload . maybe mempty otoList $ fieldPayload ^? _WorkflowFieldPayload + | otherwise + = mempty -derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--" +workflowStateCurrentPayloads :: forall fileid userid. + WorkflowState fileid userid + -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid)) +workflowStateCurrentPayloads = Map.unionsWith (\_ v -> v) . map wpPayload . otoList + +----- Lenses needed here ----- + +makeLenses_ ''WorkflowAction ----- Generic traversal ----- @@ -282,6 +409,8 @@ type family ChildrenWorkflowChildren a where ChildrenWorkflowChildren (Map k v) = '[v] ChildrenWorkflowChildren (Set a) = '[a] ChildrenWorkflowChildren (Seq a) = '[a] + ChildrenWorkflowChildren [a] = '[a] + ChildrenWorkflowChildren (NonEmpty a) = '[a] ChildrenWorkflowChildren (NonNull mono) = '[Element mono] ChildrenWorkflowChildren (CI a) = '[a] ChildrenWorkflowChildren UUID = '[] @@ -315,6 +444,9 @@ type family ChildrenWorkflowChildren a where instance HasTypesCustom WorkflowChildren a a a a where typesCustom = id +instance HasTypesCustom WorkflowChildren a' b' a b => HasTypesCustom WorkflowChildren (NonEmpty a') (NonEmpty b') a b where + typesCustom = traverse . typesCustom @WorkflowChildren + instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where typesCustom = traverse . typesCustom @WorkflowChildren @@ -330,35 +462,66 @@ instance (HasTypesCustom WorkflowChildren mono mono' a a', MonoFoldable mono') = instance (HasTypesCustom WorkflowChildren a' b' a b, FoldCase b') => HasTypesCustom WorkflowChildren (CI a') (CI b') a b where typesCustom = iso CI.original CI.mk . typesCustom @WorkflowChildren -instance (Typeable userid, Typeable fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') fileid fileid' where - typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid', .. } - typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, .. }) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, ..} +instance (Typeable userid, Typeable fileid, Typeable fileid', Ord fileid', userid ~ userid', FileReferenceTitleMapConvertible (FileFieldUserOption Bool) fileid fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') fileid fileid' where + typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = traverseOf (_fieldAdditionalFiles . _FileReferenceTitleMap . _1) f wpffConfig <&> \wpffConfig' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffConfig = wpffConfig', .. } + typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> traverseOf (typesCustom @WorkflowChildren) f sub <*> traverseOf (traverse . traverse . typesCustom @WorkflowChildren) f def' + where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} -instance (Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where +instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid', .. } typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..} + typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> typesCustom @WorkflowChildren f sub <*> (traverse . typesCustom @WorkflowChildren) f def' + where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} -instance (Typeable payload, Typeable fileid, Typeable userid, fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload where +instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) of - Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid userid payload) @payload @payload f p + Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid' userid' payload') @payload @payload' f p Nothing -> pure pw + +instance {-# OVERLAPPING #-} (Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid userid, IsWorkflowFieldPayload fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') userid userid' where + typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid userid) of + Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid userid) @(WorkflowFieldPayload fileid' userid' userid') @userid @userid' f p + Nothing -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid') pw -- We have proof that @p@ does not contain a value of type @userid@, therefor coercion is safe -instance (fileid ~ fileid', userid ~ userid', payload ~ payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where - typesCustom f (WFPText x) = WFPText <$> f x - typesCustom f (WFPNumber x) = WFPNumber <$> f x - typesCustom f (WFPBool x) = WFPBool <$> f x - typesCustom f (WFPFile x) = WFPFile <$> f x - typesCustom f (WFPUser x) = WFPUser <$> f x +instance {-# OVERLAPPING #-} (Typeable userid, Typeable fileid, Ord fileid', IsWorkflowFieldPayload fileid userid (Set fileid), IsWorkflowFieldPayload fileid' userid' (Set fileid'), userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') fileid fileid' where + typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid (Set fileid)) of + Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid (Set fileid)) @(WorkflowFieldPayload fileid' userid' (Set fileid')) @(Set fileid) @(Set fileid') (traverseOf (iso Set.toList Set.fromList . traverse) f) p + Nothing -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid' userid) pw -- We have proof that @p@ does not contain a value of type @fileid@, therefor coercion is safe + +instance (IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where + typesCustom f x = case x ^? _WorkflowFieldPayload of + Just x' -> review _WorkflowFieldPayload <$> f x' + Nothing -> error "@WorkflowFieldPayload fileid userid payload@ does not contain value of type @payload@; this means `IsWorkflowFieldPayload` is invalid" + +instance (Ord userid, Ord fileid, Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') payload payload' where + typesCustom = _wpPayload . typesCustom @WorkflowChildren + +instance {-# OVERLAPPING #-} (Ord userid', Ord fileid, Typeable fileid, IsWorkflowFieldPayload fileid userid userid, IsWorkflowFieldPayload fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') userid userid' where + typesCustom f WorkflowAction{..} = WorkflowAction wpTo wpVia + <$> traverseOf (typesCustom @WorkflowChildren @_ @_ @userid @userid') f wpPayload + <*> traverseOf (_Just . _Just) f wpUser + <*> pure wpTime + +----- PathPiece instances ----- + +nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" +nullaryPathPiece ''WorkflowFieldPayload' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" + +nullaryPathPiece ''WorkflowPayloadField' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" + +derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--" ----- ToJSON / FromJSON instances ----- @@ -371,38 +534,84 @@ deriveJSON defaultOptions } ''WorkflowRole deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView -pathPieceJSON ''WorkflowFieldPayload'' +pathPieceJSON ''WorkflowFieldPayload' +pathPieceJSON ''WorkflowPayloadField' instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where parseJSON = genericParseJSON workflowPayloadViewAesonOptions -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraph fileid userid) where toJSON = genericToJSON workflowGraphAesonOptions instance ( FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , FromJSON (FileField fileid) + , Ord (FileField fileid) ) => FromJSON (WorkflowGraph fileid userid) where parseJSON = genericParseJSON workflowGraphAesonOptions -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphEdge fileid userid) where +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdge fileid userid) where toJSON = genericToJSON workflowGraphEdgeAesonOptions instance ( FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , FromJSON (FileField fileid) + , Ord (FileField fileid) ) => FromJSON (WorkflowGraphEdge fileid userid) where parseJSON = genericParseJSON workflowGraphEdgeAesonOptions -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid userid) where - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = JSON.object $ omitNothing - [ "tag" JSON..= ("text" :: Text) +instance ToJSON WorkflowGraphEdgeFormOrder where + toJSON WorkflowGraphEdgeFormOrder{..} = case unWorkflowGraphEdgeFormOrder of + Nothing -> JSON.String "_" + Just sci -> JSON.Number sci +instance FromJSON WorkflowGraphEdgeFormOrder where + parseJSON v = fmap WorkflowGraphEdgeFormOrder $ asum + [ Just <$> parseJSON v + , JSON.withText "WorkflowGraphEdgeFormOrder" (bool (fail "WorkflowGraphEdgeFormOrder: unexpected String, expecting either number or \"_\"") (pure Nothing) . (== "_")) v + ] + +instance ToJSONKey WorkflowGraphEdgeFormOrder where + toJSONKey = JSON.ToJSONKeyText (maybe "_" toText' . unWorkflowGraphEdgeFormOrder) (maybe (JSON.text "_") toEncoding' . unWorkflowGraphEdgeFormOrder) + where toText' = decodeUtf8 . toStrict . JSON.encodingToLazyByteString . JSON.scientific + toEncoding' = JSON.scientificText +instance FromJSONKey WorkflowGraphEdgeFormOrder where + fromJSONKey = JSON.FromJSONKeyTextParser $ \t -> if + | t == "_" -> pure $ WorkflowGraphEdgeFormOrder Nothing + | otherwise -> WorkflowGraphEdgeFormOrder . Just <$> parseJSON (JSON.String t) + +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdgeForm fileid userid) where + toJSON WorkflowGraphEdgeForm{..} = toJSON . flip map wgefFields $ \(toNullable -> disj) -> flip Set.map disj $ \(toNullable -> orderedFields) -> if + | [(WorkflowGraphEdgeFormOrder Nothing, field)] <- Map.toList orderedFields + -> toJSON field + | otherwise + -> toJSON orderedFields + +instance ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid + , FromJSON (FileField fileid), Ord (FileField fileid) + ) => FromJSON (WorkflowGraphEdgeForm fileid userid) where + parseJSON = JSON.withObject "WorkflowGraphEdgeForm" $ \o -> do + o' <- parseJSON $ JSON.Object o :: JSON.Parser (Map WorkflowPayloadLabel (NonNull (Set (JSON.Value)))) + fmap WorkflowGraphEdgeForm . for o' $ \(Set.toList . toNullable -> o'') -> fmap (impureNonNull . Set.fromList) . for o'' $ \o''' -> asum + [ parseJSON o''' + , impureNonNull . Map.singleton (WorkflowGraphEdgeFormOrder Nothing) <$> parseJSON o''' + ] + +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadSpec fileid userid) where + toJSON (WorkflowPayloadSpec f) = toJSON f + +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadField fileid userid payload) where + toJSON (WorkflowPayloadFieldText{..}) = JSON.object $ omitNothing + [ "tag" JSON..= WPFText' , "label" JSON..= wpftLabel , "placeholder" JSON..= wpftPlaceholder , "tooltip" JSON..= wpftTooltip , "default" JSON..= wpftDefault , "optional" JSON..= wpftOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing - [ "tag" JSON..= ("number" :: Text) + toJSON (WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing + [ "tag" JSON..= WPFNumber' , "label" JSON..= wpfnLabel , "placeholder" JSON..= wpfnPlaceholder , "tooltip" JSON..= wpfnTooltip @@ -412,46 +621,60 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us , "step" JSON..= wpfnStep , "optional" JSON..= wpfnOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing - [ "tag" JSON..= ("bool" :: Text) + toJSON (WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing + [ "tag" JSON..= WPFBool' , "label" JSON..= wpfbLabel , "tooltip" JSON..= wpfbTooltip , "default" JSON..= wpfbDefault , "optional" JSON..= wpfbOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing - [ "tag" JSON..= ("file" :: Text) + toJSON (WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing + [ "tag" JSON..= WPFFile' , "label" JSON..= wpffLabel , "tooltip" JSON..= wpffTooltip - , "default" JSON..= wpffDefault + , "config" JSON..= wpffConfig , "optional" JSON..= wpffOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing - [ "tag" JSON..= ("user" :: Text) + toJSON (WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing + [ "tag" JSON..= WPFUser' , "label" JSON..= wpfuLabel , "tooltip" JSON..= wpfuTooltip , "default" JSON..= wpfuDefault , "optional" JSON..= wpfuOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = JSON.object - [ "tag" JSON..= ("reference" :: Text) + toJSON (WorkflowPayloadFieldCaptureUser{}) = JSON.object + [ "tag" JSON..= WPFCaptureUser' + ] + toJSON (WorkflowPayloadFieldReference{..}) = JSON.object + [ "tag" JSON..= WPFReference' , "target" JSON..= wpfrTarget ] + toJSON (WorkflowPayloadFieldMultiple{..}) = JSON.object + [ "tag" JSON..= WPFMultiple' + , "label" JSON..= wpfmLabel + , "tooltip" JSON..= wpfmTooltip + , "default" JSON..= wpfmDefault + , "sub" JSON..= wpfmSub + , "min" JSON..= wpfmMin + , "range" JSON..= wpfmRange + ] + instance ( FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , FromJSON (FileField fileid) ) => FromJSON (WorkflowPayloadSpec fileid userid) where parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do - fieldTag <- (o JSON..: "tag" :: Parser Text) + fieldTag <- o JSON..: "tag" case fieldTag of - "text" -> do + WPFText' -> do wpftLabel <- o JSON..: "label" wpftPlaceholder <- o JSON..:? "placeholder" wpftTooltip <- o JSON..:? "tooltip" wpftDefault <- o JSON..:? "default" wpftOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} - "number" -> do + WPFNumber' -> do wpfnLabel <- o JSON..: "label" wpfnPlaceholder <- o JSON..:? "placeholder" wpfnTooltip <- o JSON..:? "tooltip" @@ -461,34 +684,44 @@ instance ( FromJSON fileid, FromJSON userid wpfnStep <- o JSON..: "step" wpfnOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} - "bool" -> do + WPFBool' -> do wpfbLabel <- o JSON..: "label" wpfbTooltip <- o JSON..:? "tooltip" wpfbOptional <- o JSON..: "optional" wpfbDefault <- (o JSON..: "default" :: Parser (Maybe Bool)) return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} - "file" -> do + WPFFile' -> do wpffLabel <- o JSON..: "label" wpffTooltip <- o JSON..:? "tooltip" - wpffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) + wpffConfig <- o JSON..: "config" wpffOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} - "user" -> do + WPFUser' -> do wpfuLabel <- o JSON..: "label" wpfuTooltip <- o JSON..:? "tooltip" wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) wpfuOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} - "reference" -> do + WPFCaptureUser' -> pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser + WPFReference' -> do wpfrTarget <- o JSON..: "target" return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} - _ -> terror $ "WorkflowPayloadSpec parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag + WPFMultiple' -> do + wpfmLabel <- o JSON..: "label" + wpfmTooltip <- o JSON..:? "tooltip" + wpfmDefault <- o JSON..:? "default" + wpfmSub <- o JSON..: "sub" + wpfmMin <- o JSON..: "min" + wpfmRange <- o JSON..:? "range" + return $ WorkflowPayloadSpec WorkflowPayloadFieldMultiple{..} -instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphNode fileid userid) where +instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphNode fileid userid) where toJSON = genericToJSON workflowGraphNodeAesonOptions instance ( FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , FromJSON (FileField fileid) + , Ord (FileField fileid) ) => FromJSON (WorkflowGraphNode fileid userid) where parseJSON = genericParseJSON workflowGraphNodeAesonOptions @@ -520,15 +753,19 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid [ "tag" JSON..= WFPBool' , toPathPiece WFPBool' JSON..= b ] - toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object - [ "tag" JSON..= WFPFile' - , toPathPiece WFPFile' JSON..= fid + toJSON (WorkflowFieldPayloadW (WFPFiles fid)) = JSON.object + [ "tag" JSON..= WFPFiles' + , toPathPiece WFPFiles' JSON..= fid ] toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object [ "tag" JSON..= WFPUser' , toPathPiece WFPUser' JSON..= uid ] -instance (FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where + toJSON (WorkflowFieldPayloadW (WFPMultiple uid)) = JSON.object + [ "tag" JSON..= WFPMultiple' + , toPathPiece WFPMultiple' JSON..= uid + ] +instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do fieldTag <- o JSON..: "tag" case fieldTag of @@ -541,12 +778,15 @@ instance (FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => WFPBool' -> do b <- o JSON..: toPathPiece WFPBool' return $ WorkflowFieldPayloadW $ WFPBool b - WFPFile' -> do - fid <- o JSON..: toPathPiece WFPFile' - return $ WorkflowFieldPayloadW $ WFPFile fid + WFPFiles' -> do + fid <- o JSON..: toPathPiece WFPFiles' + return $ WorkflowFieldPayloadW $ WFPFiles fid WFPUser' -> do uid <- o JSON..: toPathPiece WFPUser' return $ WorkflowFieldPayloadW $ WFPUser uid + WFPMultiple' -> do + uid <- o JSON..: toPathPiece WFPMultiple' + return $ WorkflowFieldPayloadW $ WFPMultiple uid @@ -556,6 +796,8 @@ instance ( ToJSON fileid, ToJSON userid , FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , ToJSON (FileField fileid), FromJSON (FileField fileid) + , Ord (FileField fileid) ) => PersistField (WorkflowGraph fileid userid) where toPersistValue = toPersistValueJSON fromPersistValue = fromPersistValueJSON @@ -563,6 +805,8 @@ instance ( ToJSON fileid, ToJSON userid , FromJSON fileid, FromJSON userid , Ord fileid, Ord userid , Typeable fileid, Typeable userid + , ToJSON (FileField fileid), FromJSON (FileField fileid) + , Ord (FileField fileid) ) => PersistFieldSql (WorkflowGraph fileid userid) where sqlType _ = sqlTypeJSON @@ -598,3 +842,5 @@ instance ( ToJSON fileid, ToJSON userid instance Binary WorkflowScope' instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid) + +instance Binary userid => Binary (WorkflowRole userid) diff --git a/src/Settings.hs b/src/Settings.hs index 4e40ba9a4..9647bbadc 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -36,7 +36,7 @@ import Language.Haskell.TH.Syntax (Exp, Q) #endif import qualified Yesod.Auth.Util.PasswordStore as PWStore -import Data.Scientific (Scientific, toBoundedInteger) +import qualified Data.Scientific as Scientific import Data.Word (Word16) import qualified Data.Text as Text @@ -338,7 +338,7 @@ deriveFromJSON ''ResourcePoolConf instance FromJSON HaskellNet.PortNumber where - parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of + parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of Just int -> return $ fromIntegral (int :: Word16) Nothing -> fail "Expected whole number of plausible size to denote port" diff --git a/src/Utils.hs b/src/Utils.hs index c852b0295..07f37c889 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -565,6 +565,9 @@ mapF = flip Map.fromSet $ Set.fromList universeF partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v) partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . over _1 (Map.mapKeysMonotonic . view $ singular _Left) . Map.partitionWithKey (\k _ -> is _Left k) +mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v) +mapFromSetM = (sequenceA .) . Map.fromSet + --------------- -- Functions -- --------------- @@ -651,6 +654,9 @@ catchMPlus _ = handle (const mzero :: e -> m a) catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a catchIfMPlus p act = catchIf p act (const mzero) +fromMaybeT :: MaybeT Identity a -> Maybe a +fromMaybeT = runIdentity . runMaybeT + mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index f37b160a4..d8274a476 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -350,7 +350,12 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do { fvLabel = toHtml $ mr fsLabel , fvTooltip = fmap (toHtml . mr) fsTooltip , fvId - , fvInput = foldMap fvInput fvs + , fvInput = + [whamlet| + $newline never +
+ ^{foldMap fvInput fvs} + |] , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs , fvRequired = False } @@ -698,6 +703,9 @@ cfCI = convertField CI.mk CI.original isoField :: Functor m => AnIso' a b -> Field m a -> Field m b isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso) +convertFieldM :: forall m a b. Monad m => (a -> m b) -> (b -> a) -> Field m a -> Field m b +convertFieldM = checkMMap . ((fmap Right .) :: (a -> m b) -> (a -> m (Either (SomeMessage (HandlerSite m)) b))) + selectField' :: ( Eq a , RenderMessage (HandlerSite m) FormMessage @@ -1150,7 +1158,7 @@ warnValidation msg isValid = unless isValid $ addMessageI Warning msg -- Form Manipulation -- ----------------------- -aFormToWForm :: MonadHandler m => AForm m a -> WForm m (FormResult a) +aFormToWForm :: Monad m => AForm m a -> WForm m (FormResult a) aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm where mFormToWForm' f = do @@ -1166,6 +1174,13 @@ wFormFields :: Monad m => WForm m a -> WForm m (a, [FieldView (HandlerSite m)]) -- ^ Suppress side effect of appending `FieldView`s and instead add them to the result wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (const mempty) . listen) + +wSetTooltip :: Monad m => Maybe Html -> WForm m a -> WForm m a +wSetTooltip tip = hoist (censoring _head $ set _fvTooltip tip) + +aSetTooltip :: MonadHandler m => Maybe Html -> AForm m a -> AForm m a +aSetTooltip tip = wFormToAForm . wSetTooltip tip . aFormToWForm + --------------------------------------------- -- Special variants of @mopt@, @mreq@, ... -- --------------------------------------------- diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs index 937f56ef2..3c58c4213 100644 --- a/src/Utils/I18n.hs +++ b/src/Utils/I18n.hs @@ -5,6 +5,8 @@ module Utils.I18n , I18nText, I18nHtml , renderMessageI18n , i18nMessageFor + , LanguageSelectI18n(..), getLanguageSelectI18n + , selectLanguageI18n , Element , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable' ) where @@ -27,7 +29,7 @@ import Language.Haskell.TH.Syntax (qRunIO) import qualified Language.Haskell.TH.Syntax as TH import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text @@ -37,12 +39,17 @@ import System.Directory (listDirectory) import Utils.NTop -import Control.Lens (iforM) +import Utils.Lang (selectLanguage') + +import Control.Lens +import Control.Lens.Extras (is) + import Control.Monad.Fail (fail) data I18n a = I18n - { i18nFallback :: a + { i18nFallback :: a + , i18nFallbackLang :: Maybe Lang , i18nTranslations :: Map Lang a } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable) deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable) @@ -53,7 +60,7 @@ type I18nHtml = I18n Html instance MonoPointed (I18n a) where - opoint = flip I18n Map.empty + opoint i18nFallback = I18n { i18nFallback, i18nFallbackLang = Nothing, i18nTranslations = Map.empty } instance IsString a => IsString (I18n a) where fromString = opoint . fromString @@ -61,28 +68,32 @@ instance IsString a => IsString (I18n a) where instance ToJSON a => ToJSON (I18n a) where toJSON I18n{..} | Map.null i18nTranslations + , is _Nothing i18nFallbackLang , fallbackUnambiguous = toJSON i18nFallback - | Map.null i18nTranslations - = JSON.object [ "fallback" JSON..= i18nFallback ] | otherwise - = JSON.object [ "fallback" JSON..= i18nFallback - , "translations" JSON..= i18nTranslations - ] + = JSON.object $ catMaybes + [ pure $ "fallback" JSON..= i18nFallback + , ("fallback-lang" JSON..=) <$> i18nFallbackLang + , ("translations" JSON..=) <$> (i18nTranslations <$ guard (not $ Map.null i18nTranslations)) + ] where fallbackUnambiguous = case toJSON i18nFallback of - JSON.Object hm -> not $ HashMap.member "fallback" hm + JSON.Object hm -> not (HashMap.member "fallback" hm) + && not (HashMap.member "fallback-lang" hm) _other -> True instance FromJSON a => FromJSON (I18n a) where parseJSON (JSON.Object o) - | HashMap.member "fallback" o = do + | HashMap.member "fallback" o || HashMap.member "fallback-lang" o = do i18nFallback <- o JSON..: "fallback" + i18nFallbackLang <- o JSON..:? "fallback-lang" i18nTranslations <- o JSON..:? "translations" JSON..!= Map.empty return I18n{..} parseJSON val = do i18nFallback <- JSON.parseJSON val let i18nTranslations = Map.empty + i18nFallbackLang = Nothing return I18n{..} derivePersistFieldJSON ''I18n @@ -90,10 +101,14 @@ derivePersistFieldJSON ''I18n renderMessageI18n :: RenderMessage site msg => [Lang] -> site -> msg -> I18nText -renderMessageI18n ls app msg = I18n - { i18nFallback = renderMessage app ls msg - , i18nTranslations = Map.fromList . flip map ls $ \l -> (l, ) $ renderMessage app (l : filter (/= l) ls) msg - } +renderMessageI18n ls app msg = I18n{..} + where + i18nFallback = renderMessage app [] msg + i18nFallbackLang = listToMaybe $ do + (lang, translation) <- Map.toList i18nTranslations + guard $ translation == i18nFallback + return lang + i18nTranslations = Map.fromList . flip map ls $ \l -> (l, ) $ renderMessage app (l : filter (/= l) ls) msg i18nMessageFor :: ( MonadHandler m , RenderMessage (HandlerSite m) msg @@ -101,6 +116,33 @@ i18nMessageFor :: ( MonadHandler m => [Lang] -> msg -> m I18nText i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg +data LanguageSelectI18n = LanguageSelectI18n { slI18n :: forall a. I18n a -> a } + +getLanguageSelectI18n :: MonadHandler m + => m LanguageSelectI18n +getLanguageSelectI18n = do + langs <- languages + return $ LanguageSelectI18n + ( \I18n{..} -> case i18nFallbackLang of + Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations + avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations) + in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations' + Nothing -> let fakeLang = go Nothing + where go Nothing | fake `Map.member` i18nTranslations = go $ Just 1 + | otherwise = fake + where fake = "fake" + go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n + | otherwise = fake + where fake = "fake-" <> tshow n + in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations + ) + +selectLanguageI18n :: MonadHandler m + => I18n a -> m a +selectLanguageI18n i18n = do + LanguageSelectI18n{..} <- getLanguageSelectI18n + return $ slI18n i18n + i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text)) i18nWidgetFilesAvailable' basename = do diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c16b76fc0..ddb39a07b 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -251,6 +251,13 @@ makeLenses_ ''WorkflowDefinitionInstanceDescription makeLenses_ ''WorkflowScope makeLenses_ ''WorkflowInstance makeLenses_ ''WorkflowInstanceDescription +makeLenses_ ''WorkflowWorkflow + +makeLenses_ ''WorkflowGraph +makeLenses_ ''WorkflowGraphNode + +makeLenses_ ''WorkflowGraphEdge +makePrisms ''WorkflowGraphEdge makeWrapped ''Textarea diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs new file mode 100644 index 000000000..ee4e24a7e --- /dev/null +++ b/src/Utils/Workflow.hs @@ -0,0 +1,48 @@ +module Utils.Workflow + ( _DBWorkflowScope + , fromRouteWorkflowScope, toRouteWorkflowScope + , _DBWorkflowGraph + , _DBWorkflowState + ) where + +import Import.NoFoundation + + +_DBWorkflowScope :: Iso' (WorkflowScope TermId SchoolId CourseId) (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) +_DBWorkflowScope = iso toScope' toScope + where + toScope' scope = scope + & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolId CourseId)) unTermKey + & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolShorthand CourseId)) unSchoolKey + & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand CourseId) @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @CourseId @SqlBackendKey) (view _SqlKey) + toScope scope' = scope' + & over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolShorthand SqlBackendKey)) TermKey + & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey + & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey) + +fromRouteWorkflowScope :: ( MonadIO m + , BackendCompatible SqlReadBackend backend + ) + => WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) + -> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId CourseId) +fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + +toRouteWorkflowScope :: ( MonadIO m + , BackendCompatible SqlReadBackend backend + ) + => WorkflowScope TermId SchoolId CourseId + -> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) +toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand) + + +_DBWorkflowGraph :: Iso' (WorkflowGraph FileReference UserId) (WorkflowGraph FileReference SqlBackendKey) +_DBWorkflowGraph = iso toDB fromDB + where + toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey) + fromDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference SqlBackendKey) @(WorkflowGraph FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey) + +_DBWorkflowState :: Iso' (WorkflowState FileReference UserId) (WorkflowState FileReference SqlBackendKey) +_DBWorkflowState = iso toDB fromDB + where + toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey) + fromDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference SqlBackendKey) @(WorkflowState FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey) diff --git a/templates/widgets/massinput/workflow-payload-field-multiple/add.hamlet b/templates/widgets/massinput/workflow-payload-field-multiple/add.hamlet new file mode 100644 index 000000000..f213ee713 --- /dev/null +++ b/templates/widgets/massinput/workflow-payload-field-multiple/add.hamlet @@ -0,0 +1,7 @@ +$newline never + + #{csrf} + $forall fv <- fvs + ^{fvWidget fv} + + ^{fvWidget btn} diff --git a/templates/widgets/massinput/workflow-payload-field-multiple/cell.hamlet b/templates/widgets/massinput/workflow-payload-field-multiple/cell.hamlet new file mode 100644 index 000000000..c7145d434 --- /dev/null +++ b/templates/widgets/massinput/workflow-payload-field-multiple/cell.hamlet @@ -0,0 +1,5 @@ +$newline never + + #{csrf} + $forall fv <- fvs + ^{fvWidget fv} diff --git a/templates/widgets/massinput/workflow-payload-field-multiple/layout.hamlet b/templates/widgets/massinput/workflow-payload-field-multiple/layout.hamlet new file mode 100644 index 000000000..e87bf6f48 --- /dev/null +++ b/templates/widgets/massinput/workflow-payload-field-multiple/layout.hamlet @@ -0,0 +1,19 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + + ^{addWdgt} diff --git a/templates/widgets/occurrence/form/except-layout.hamlet b/templates/widgets/occurrence/form/except-layout.hamlet index 253b9cd6e..164aca947 100644 --- a/templates/widgets/occurrence/form/except-layout.hamlet +++ b/templates/widgets/occurrence/form/except-layout.hamlet @@ -8,7 +8,7 @@ $newline never ^{fvWidget (delButtons ! coord)} $if null (review liveCoords lLength) - -
+ $maybe delView <- delButtons !? coord + ^{fvWidget delView} + $if null (review liveCoords lLength) +
+ _{MsgWorkflowEdgeFormFieldMultipleNoneAdded} + +
+ $maybe addWdgt <- addWdgts !? (0, 0) +
+ _{MsgOccurrenceNoneExceptions}
diff --git a/templates/widgets/occurrence/form/scheduled-layout.hamlet b/templates/widgets/occurrence/form/scheduled-layout.hamlet index fd1c4ab3c..ce5877e57 100644 --- a/templates/widgets/occurrence/form/scheduled-layout.hamlet +++ b/templates/widgets/occurrence/form/scheduled-layout.hamlet @@ -8,7 +8,7 @@ $newline never ^{fvWidget (delButtons ! coord)} $if null (review liveCoords lLength)
+ _{MsgOccurrenceNoneScheduled}
diff --git a/templates/workflows/instance-initiate.hamlet b/templates/workflows/instance-initiate.hamlet new file mode 100644 index 000000000..6b9d76a41 --- /dev/null +++ b/templates/workflows/instance-initiate.hamlet @@ -0,0 +1,6 @@ +$newline never +$maybe desc <- workflowInstanceDescriptionDescription =<< mDesc +
+ #{desc} +
+ ^{edgeView} diff --git a/templates/workflows/instances.hamlet b/templates/workflows/instances.hamlet new file mode 100644 index 000000000..9f4c5b588 --- /dev/null +++ b/templates/workflows/instances.hamlet @@ -0,0 +1,19 @@ +$newline never +
    + $forall (Entity _ WorkflowInstance{workflowInstanceName}, mDesc) <- instances +
  • + $maybe WorkflowInstanceDescription{workflowInstanceDescriptionTitle} <- mDesc +

    + #{workflowInstanceDescriptionTitle} + $nothing +

    + #{workflowInstanceName} + +

    + ^{linkButton mempty (i18n MsgMenuWorkflowInstanceWorkflows) [BCIsButton, BCPrimary] $ SomeRoute $ toListRoute workflowInstanceName} + ^{linkButton mempty (i18n MsgMenuWorkflowInstanceInitiate) [BCIsButton] $ SomeRoute $ toInitiateRoute workflowInstanceName} + ^{linkButton mempty (i18n MsgMenuWorkflowInstanceEdit) [BCIsButton] $ SomeRoute $ toEditRoute workflowInstanceName} + + $maybe desc <- workflowInstanceDescriptionDescription =<< mDesc +
    + #{desc} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 3939cfdd2..c8a173893 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -31,6 +31,8 @@ import Data.List (genericLength) import qualified Data.Conduit.Combinators as C +import qualified Data.Yaml as Yaml + testdataDir :: FilePath testdataDir = "testdata" @@ -1282,3 +1284,55 @@ fillDb = do _other -> return mempty liftIO . LBS.writeFile (testdataDir "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities + + do + workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir "exam-rooms.yaml" + let + examRoomsWorkflowDef = WorkflowDefinition{..} + where workflowDefinitionInstanceCategory = Just "rooms" + workflowDefinitionName = "exam-rooms" + workflowDefinitionScope = WSGlobal' -- TODO + wdId <- insert examRoomsWorkflowDef + let + examRoomsWorkflowInst = WorkflowInstance{..} + where workflowInstanceDefinition = Just wdId + workflowInstanceGraph = workflowDefinitionGraph + workflowInstanceScope = WSGlobal -- TODO + workflowInstanceName = workflowDefinitionName examRoomsWorkflowDef + workflowInstanceCategory = workflowDefinitionInstanceCategory examRoomsWorkflowDef + insert_ examRoomsWorkflowInst + + do + workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir "theses.yaml" + let + thesesWorkflowDef = WorkflowDefinition{..} + where workflowDefinitionInstanceCategory = Just "theses" + workflowDefinitionName = "theses" + workflowDefinitionScope = WSGlobal' -- TODO + wdId <- insert thesesWorkflowDef + insert_ WorkflowDefinitionDescription + { workflowDefinitionDescriptionDefinition = wdId + , workflowDefinitionDescriptionLanguage = "de-de-formal" + , workflowDefinitionDescriptionTitle = "Abschlussarbeiten" + , workflowDefinitionDescriptionDescription = Just "Erlaubt Abschlussarbeiten in Uni2work zu verwalten" + } + insert_ WorkflowDefinitionInstanceDescription + { workflowDefinitionInstanceDescriptionDefinition = wdId + , workflowDefinitionInstanceDescriptionLanguage = "de-de-formal" + , workflowDefinitionInstanceDescriptionTitle = "Abschlussarbeiten" + , workflowDefinitionInstanceDescriptionDescription = Just "Hier können Sie Abschlussarbeiten bei der Prüfungsverwaltung angemeldet werden, der relevante Student die Arbeit digital abgeben und im Anschluss auch die Benotung an die Prüfungsverwaltung übermittelt werden." + } + let + thesesWorkflowInst = WorkflowInstance{..} + where workflowInstanceDefinition = Just wdId + workflowInstanceGraph = workflowDefinitionGraph + workflowInstanceScope = WSGlobal -- TODO + workflowInstanceName = workflowDefinitionName thesesWorkflowDef + workflowInstanceCategory = workflowDefinitionInstanceCategory thesesWorkflowDef + wiId <- insert thesesWorkflowInst + insert_ WorkflowInstanceDescription + { workflowInstanceDescriptionInstance = wiId + , workflowInstanceDescriptionLanguage = "de-de-formal" + , workflowInstanceDescriptionTitle = "Abschlussarbeiten" + , workflowInstanceDescriptionDescription = Just "Hier können Sie Abschlussarbeiten bei der Prüfungsverwaltung angemeldet werden, der relevante Student die Arbeit digital abgeben und im Anschluss auch die Benotung an die Prüfungsverwaltung übermittelt werden." + } diff --git a/testdata/exam-rooms.yaml b/testdata/exam-rooms.yaml new file mode 100644 index 000000000..e0ed23b5f --- /dev/null +++ b/testdata/exam-rooms.yaml @@ -0,0 +1,30 @@ +nodes: + "beantragt": + display-label: "Beantragt" + final: false + viewers: + - tag: initiator + - tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] } + edges: + "beantragen": + mode: initial + display-label: "Beantragen" + actors: + - tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer"}]] } + form: + "raumbeschreibung": + - tag: text + label: "Raumbeschreibung" + placeholder: null + tooltip: null + default: null + optional: false +payload-view: + "raumbeschreibung": + display-label: "Raumbeschreibung" + viewers: + - tag: initiator + - tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] } diff --git a/testdata/theses.yaml b/testdata/theses.yaml new file mode 100644 index 000000000..0ab97c2b6 --- /dev/null +++ b/testdata/theses.yaml @@ -0,0 +1,241 @@ +nodes: + "antrag": + display-label: "Antrag angelegt" + final: false + viewers: + - &pruefungsamt + tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] } + - &hochschullehrer + tag: payload-reference + payload-label: "hochschullehrer" + - &betreuer + tag: payload-reference + payload-label: "betreuer" + - &student + tag: payload-reference + payload-label: "student" + edges: + "antrag als pruefungsamt": + mode: initial + display-label: "Antrag anlegen (als Prüfungsverwaltung)" + actors: + - *pruefungsamt + form: + "hochschullehrer": &hochschullehrer-form + - tag: multiple + label: "Verantwortliche Hochschullehrer" + tooltip: null + default: null + min: 1 + range: null + sub: + tag: user + label: "Verantwortlicher Hochschullehrer" + tooltip: null + default: null + optional: false + "betreuer": &betreuer-form + - tag: multiple + label: "Betreuer" + tooltip: null + default: null + min: 0 + range: null + sub: + tag: user + label: "Betreuer" + tooltip: null + default: null + optional: false + "student": &student-form + - tag: user + label: "Student" + tooltip: null + default: null + optional: false + "antrag als hochschullehrer": + mode: initial + display-label: "Antrag anlegen (als verantwortlicher Hochschullehrer)" + actors: + - tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer" }]] } + form: + "hochschullehrer": + - tag: capture-user + - tag: multiple + label: "Zusätzliche verantwortliche Hochschullehrer" + tooltip: null + default: null + min: 0 + range: null + sub: + tag: user + label: "Verantwortlicher Hochschullehrer" + tooltip: null + default: null + optional: false + "betreuer": *betreuer-form + "student": *student-form + "antrag als betreuer": + mode: initial + display-label: "Antrag anlegen (als Betreuer)" + actors: + - tag: authorized + authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer" }]] } + form: + "betreuer": + - tag: capture-user + - tag: multiple + label: "Zusätzliche Betreuer" + tooltip: null + default: null + min: 0 + range: null + sub: + tag: user + label: "Betreuer" + tooltip: null + default: null + optional: false + "hochschullehrer": *hochschullehrer-form + "student": *student-form + "antrag, hochschullehrer": + display-label: "Antrag angelegt und vom Hochschullehrer bestätigt" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + edges: + "antrag bestaetigen als hochschullehrer": + mode: manual + display-label: "Antrag bestätigen (als verantwortlicher Hochschullehrer)" + source: "antrag" + actors: + - *hochschullehrer + - *pruefungsamt + form: {} + "antrag, student": + display-label: "Antrag angelegt und vom Student bestätigt" + final: false + viewers: + - *pruefungsamt + - *student + - *hochschullehrer + - *betreuer + edges: + "antrag bestaetigen als student": + mode: manual + display-label: "Antrag bestätigen (als Student)" + source: "antrag" + actors: + - *student + - *pruefungsamt + form: {} + "antrag, student&hochschullehrer": + display-label: "Antrag angelegt und von Student und Hochschullehrer bestätigt" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + edges: + "antrag bestaetigen als student": + mode: manual + display-label: "Antrag bestätigen (als Student)" + source: "antrag, hochschullehrer" + actors: + - *student + - *pruefungsamt + form: {} + "antrag bestaetigen als hochschullehrer": + mode: manual + display-label: "Antrag bestätigen (als verantwortlicher Hochschullehrer)" + source: "antrag, student" + actors: + - *hochschullehrer + - *pruefungsamt + form: {} + "angemeldet": + display-label: "Angemeldet" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + - *student + edges: + "anmelden, bestaetigt student&hochschullehrer": + mode: manual + display-label: "Arbeit anmelden (bestätigt vom Student und verantwortlichem Hochschullehrer)" + source: "antrag, student&hochschullehrer" + actors: + - *pruefungsamt + form: + "hochschullehrer": *hochschullehrer-form + "betreuer": *betreuer-form + "student": *student-form + "anmelden, bestaetigt student": + mode: manual + display-label: "Arbeit anmelden (bestätigt nur vom Student)" + source: "antrag, student" + actors: + - *pruefungsamt + form: + "hochschullehrer": *hochschullehrer-form + "betreuer": *betreuer-form + "student": *student-form + "anmelden, bestaetigt hochschullehrer": + mode: manual + display-label: "Arbeit anmelden (bestätigt nur vom Hochschullehrer)" + source: "antrag, hochschullehrer" + actors: + - *pruefungsamt + form: + "hochschullehrer": *hochschullehrer-form + "betreuer": *betreuer-form + "student": *student-form + "datei": + display-label: "Datei hochgeladen" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + - *student + edges: {} + "abgegeben": + display-label: "Abgabe akzeptiert" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + - *student + edges: {} + "benotet": + display-label: "Benotet" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + - *student + edges: {} + "abgebrochen": + display-label: "Abgebrochen" + final: false + viewers: + - *pruefungsamt + - *hochschullehrer + - *betreuer + - *student + edges: {} + "fertig": + display-label: "Fertig" + final: true + viewers: + - *pruefungsamt + edges: {} +payload-view: {}