feat(workflows): initiate
This commit is contained in:
Gregor Kleen
parent
ddd1dd5df4
commit
fd7c91f5b8
@ -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
|
||||
|
||||
@ -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
|
||||
InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt
|
||||
|
||||
@ -154,6 +154,9 @@ dependencies:
|
||||
- data-textual
|
||||
- fastcdc
|
||||
- bimap
|
||||
- list-t
|
||||
- insert-ordered-containers
|
||||
- topograph
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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])
|
||||
|
||||
@ -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
|
||||
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
|
||||
^{lbl}
|
||||
|]
|
||||
access <- hasReadAccessTo $ urlRoute url
|
||||
if | not access -> defWdgt
|
||||
| otherwise -> do
|
||||
url' <- toTextUrl url
|
||||
[whamlet|
|
||||
$newline never
|
||||
<a href=#{url'} :not (onull cls):class=#{unwords $ map toPathPiece cls}>
|
||||
^{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
|
||||
]
|
||||
|
||||
60
src/Handler/Utils/Workflow/CanonicalRoute.hs
Normal file
60
src/Handler/Utils/Workflow/CanonicalRoute.hs
Normal file
@ -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
|
||||
454
src/Handler/Utils/Workflow/EdgeForm.hs
Normal file
454
src/Handler/Utils/Workflow/EdgeForm.hs
Normal file
@ -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}
|
||||
<br />
|
||||
#{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}
|
||||
<br />
|
||||
#{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
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -162,6 +162,7 @@ makePrisms ''PredLiteral
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "val" "var"
|
||||
} ''PredLiteral
|
||||
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<div .buttongroup>
|
||||
^{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@, ... --
|
||||
---------------------------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -251,6 +251,13 @@ makeLenses_ ''WorkflowDefinitionInstanceDescription
|
||||
makeLenses_ ''WorkflowScope
|
||||
makeLenses_ ''WorkflowInstance
|
||||
makeLenses_ ''WorkflowInstanceDescription
|
||||
makeLenses_ ''WorkflowWorkflow
|
||||
|
||||
makeLenses_ ''WorkflowGraph
|
||||
makeLenses_ ''WorkflowGraphNode
|
||||
|
||||
makeLenses_ ''WorkflowGraphEdge
|
||||
makePrisms ''WorkflowGraphEdge
|
||||
|
||||
makeWrapped ''Textarea
|
||||
|
||||
|
||||
48
src/Utils/Workflow.hs
Normal file
48
src/Utils/Workflow.hs
Normal file
@ -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)
|
||||
@ -0,0 +1,7 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
$forall fv <- fvs
|
||||
^{fvWidget fv}
|
||||
<td style="vertical-align: bottom">
|
||||
^{fvWidget btn}
|
||||
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
$forall fv <- fvs
|
||||
^{fvWidget fv}
|
||||
@ -0,0 +1,19 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
$maybe delView <- delButtons !? coord
|
||||
^{fvWidget delView}
|
||||
$if null (review liveCoords lLength)
|
||||
<tr>
|
||||
<td colspan=2 .note>
|
||||
_{MsgWorkflowEdgeFormFieldMultipleNoneAdded}
|
||||
<td colspan=2>
|
||||
<div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">
|
||||
$maybe addWdgt <- addWdgts !? (0, 0)
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgt}
|
||||
@ -8,7 +8,7 @@ $newline never
|
||||
^{fvWidget (delButtons ! coord)}
|
||||
$if null (review liveCoords lLength)
|
||||
<tr>
|
||||
<td colspan=3 style="font-weight: 600; font-size: 0.9rem; color: var(--color-fontsec);">
|
||||
<td colspan=3 .note>
|
||||
_{MsgOccurrenceNoneExceptions}
|
||||
<td colspan=3>
|
||||
<div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">
|
||||
|
||||
@ -8,7 +8,7 @@ $newline never
|
||||
^{fvWidget (delButtons ! coord)}
|
||||
$if null (review liveCoords lLength)
|
||||
<tr>
|
||||
<td colspan=3 style="font-weight: 600; font-size: 0.9rem; color: var(--color-fontsec);">
|
||||
<td colspan=3 .note>
|
||||
_{MsgOccurrenceNoneScheduled}
|
||||
<td colspan=3>
|
||||
<div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">
|
||||
|
||||
6
templates/workflows/instance-initiate.hamlet
Normal file
6
templates/workflows/instance-initiate.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
$newline never
|
||||
$maybe desc <- workflowInstanceDescriptionDescription =<< mDesc
|
||||
<section>
|
||||
#{desc}
|
||||
<section>
|
||||
^{edgeView}
|
||||
19
templates/workflows/instances.hamlet
Normal file
19
templates/workflows/instances.hamlet
Normal file
@ -0,0 +1,19 @@
|
||||
$newline never
|
||||
<ul .workflow-instances>
|
||||
$forall (Entity _ WorkflowInstance{workflowInstanceName}, mDesc) <- instances
|
||||
<li>
|
||||
$maybe WorkflowInstanceDescription{workflowInstanceDescriptionTitle} <- mDesc
|
||||
<p .workflow-instance--title>
|
||||
#{workflowInstanceDescriptionTitle}
|
||||
$nothing
|
||||
<p .workflow-instance--name>
|
||||
#{workflowInstanceName}
|
||||
|
||||
<div .workflow-instance--actions .buttongroup>
|
||||
^{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
|
||||
<div .workflow-instance--description>
|
||||
#{desc}
|
||||
@ -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."
|
||||
}
|
||||
|
||||
30
testdata/exam-rooms.yaml
vendored
Normal file
30
testdata/exam-rooms.yaml
vendored
Normal file
@ -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"}]] }
|
||||
241
testdata/theses.yaml
vendored
Normal file
241
testdata/theses.yaml
vendored
Normal file
@ -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: {}
|
||||
Reference in New Issue
Block a user