fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(workflows): initiate

Browse Source
This commit is contained in:
Gregor Kleen 2020-10-19 21:46:10 +02:00
parent ddd1dd5df4
commit fd7c91f5b8
35 changed files with 1987 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
frontend/src/app.sass
View File

@ -273,7 +273,7 @@ button:not(.btn-link),
.buttongroup .buttongroup
display: grid display: grid
grid: min-content / auto-flow 1fr grid: min-content / auto-flow max-content
input[type="submit"][disabled]:not(.btn-link), input[type="submit"][disabled]:not(.btn-link),
input[type="button"][disabled]:not(.btn-link), input[type="button"][disabled]:not(.btn-link),
@ -962,12 +962,15 @@ th, td
dd, .dd dd, .dd
margin-left: 12px margin-left: 12px
.explanation .note
font-style: italic
font-size: 0.9rem font-size: 0.9rem
font-weight: 600 font-weight: 600
color: var(--color-fontsec) color: var(--color-fontsec)
.explanation
font-style: italic
@extend .note
// SORTABLE TABLE-HEADERS // SORTABLE TABLE-HEADERS
.table__th.sortable .table__th.sortable
position: relative position: relative
@ -1401,3 +1404,25 @@ a.breadcrumbs__home
pre, tt, code pre, tt, code
font-family: var(--font-monospace) 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

29
messages/uniworx/de-de-formal.msg
View File

@ -527,6 +527,16 @@ UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum
UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
UnauthorizedAllocatedCourseDeregister: Abmeldungen vom 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 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 EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -1394,6 +1404,7 @@ MenuAdminWorkflowDefinitionInstantiate: Instanziieren
MenuWorkflowInstanceDelete: Löschen MenuWorkflowInstanceDelete: Löschen
MenuWorkflowInstanceWorkflows: Laufende Workflows MenuWorkflowInstanceWorkflows: Laufende Workflows
MenuWorkflowInstanceInitiate: Workflow starten MenuWorkflowInstanceInitiate: Workflow starten
MenuWorkflowInstanceEdit: Bearbeiten
MenuWorkflowWorkflowEdit: Editieren MenuWorkflowWorkflowEdit: Editieren
MenuWorkflowWorkflowDelete: Löschen MenuWorkflowWorkflowDelete: Löschen
MenuGlobalWorkflowInstanceList: Workflows MenuGlobalWorkflowInstanceList: Workflows
@ -2963,10 +2974,28 @@ WorkflowInstanceCreated: Instanz angelegt
WorkflowInstanceDescriptionTitle: Instanz-Titel WorkflowInstanceDescriptionTitle: Instanz-Titel
WorkflowInstanceWorkflowCount: Workflows WorkflowInstanceWorkflowCount: Workflows
WorkflowInstanceInitiateSuccess: Workflow erfolgreich initiiert
WorkflowDescriptionLanguage: Sprach-Code (RFC1766) WorkflowDescriptionLanguage: Sprach-Code (RFC1766)
WorkflowDescriptionTitle: Titel WorkflowDescriptionTitle: Titel
WorkflowDescription: Beschreibung 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 ChangelogItemFeature: Feature
ChangelogItemBugfix: Bugfix ChangelogItemBugfix: Bugfix

3
package.yaml
View File

@ -154,6 +154,9 @@ dependencies:
- data-textual - data-textual
- fastcdc - fastcdc
- bimap - bimap
- list-t
- insert-ordered-containers
- topograph
other-extensions: other-extensions:
- GeneralizedNewtypeDeriving - GeneralizedNewtypeDeriving

250
src/Foundation/Authorization.hs
View File

@ -14,9 +14,11 @@ module Foundation.Authorization
, BearerAuthSite , BearerAuthSite
, routeAuthTags , routeAuthTags
, orAR, andAR, notAR, trueAR, falseAR , orAR, andAR, notAR, trueAR, falseAR
, evalWorkflowRoleFor, evalWorkflowRoleFor'
, hasWorkflowRole
) where ) where
import Import.NoFoundation import Import.NoFoundation hiding (Last(..))
import Foundation.Type import Foundation.Type
import Foundation.Routes import Foundation.Routes
@ -26,7 +28,9 @@ import Foundation.DB
import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.Workflow.CanonicalRoute
import Utils.Course (courseIsVisible) import Utils.Course (courseIsVisible)
import Utils.Workflow
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
@ -35,6 +39,7 @@ import qualified Data.Map as Map
import Data.Map ((!?)) import Data.Map ((!?))
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.List (findIndex) import Data.List (findIndex)
import Data.Semigroup (Last(..))
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils 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 Data.Aeson.Lens hiding (_Value, key)
import qualified Data.Conduit.Combinators as C
type BearerAuthSite site type BearerAuthSite site
= ( MonadCrypto (HandlerFor site) = ( MonadCrypto (HandlerFor site)
@ -1190,27 +1197,55 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
guard $ not hasOther guard $ not hasOther
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRegisterGroup r r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do
EExamListR -> exceptT return return $ do let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId scope <- fromRouteWorkflowScope rScope
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam let checkAccess (Entity _ WorkflowInstance{..})
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId = fmap (is _Authorized) . flip (evalAccessFor mAuthId) True $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
E.||. E.exists (E.from $ \externalExamResult -> getInstances = E.selectSource . E.from $ \workflowInstance -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId return workflowInstance
)
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getInstances .| C.mapM checkAccess .| C.or
return Authorized return Authorized
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh wWorkflows rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh scope <- fromRouteWorkflowScope rScope
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do let checkAccess (E.Value wwId) = do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet cID <- encrypt wwId
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
return Authorized getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
r -> $unsupportedAuthPredicate AuthEmpty r 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 tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh 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 guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r 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 tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
MsgRenderer mr <- ask MsgRenderer mr <- ask
return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
@ -1417,10 +1516,24 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
return result return result
evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessWithFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor mAuthId route isWrite = do 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 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do evalAccessWith assumptions route isWrite = do
mAuthId <- liftHandler maybeAuthId mAuthId <- liftHandler maybeAuthId
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags evalAccessWithFor assumptions mAuthId route isWrite
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
evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith evalAccessWithDB = evalAccessWith
@ -1483,3 +1589,79 @@ wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
-> m Bool -> m Bool
wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo 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

2
src/Foundation/I18n.hs
View File

@ -46,6 +46,8 @@ import Data.Text.Lens (packed)
import Data.List ((!!)) import Data.List ((!!))
import qualified Data.Scientific as Scientific
pluralDE :: (Eq a, Num a) pluralDE :: (Eq a, Num a)
=> a -- ^ Count => a -- ^ Count

27
src/Foundation/Yesod/Middleware.hs
View File

@ -10,6 +10,9 @@ import Foundation.Routes
import Foundation.Authorization import Foundation.Authorization
import Utils.Metrics import Utils.Metrics
import Utils.Workflow
import Handler.Utils.Workflow.CanonicalRoute
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
@ -156,10 +159,11 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
, ncExam , ncExam
, ncExternalExam , ncExternalExam
, ncAdminWorkflowDefinition , ncAdminWorkflowDefinition
, ncGlobalWorkflowInstance , ncWorkflowInstance
, verifySubmission , verifySubmission
, verifyCourseApplication , verifyCourseApplication
, verifyCourseNews , verifyCourseNews
, verifyWorkflowWorkflow
] ]
where where
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX) 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 caseChanged wdn workflowDefinitionName
return $ route return $ route
& typesUsing @RouteChildren @WorkflowDefinitionName . filtered (== wdn) .~ workflowDefinitionName & typesUsing @RouteChildren @WorkflowDefinitionName . filtered (== wdn) .~ workflowDefinitionName
ncGlobalWorkflowInstance = maybeOrig $ \route -> do ncWorkflowInstance = maybeOrig $ \route -> do
GlobalWorkflowInstanceR wdn _ <- return route (rScope, WorkflowInstanceR win _) <- hoistMaybe $ route ^? _WorkflowScopeRoute
Entity _ WorkflowInstance{..} <- MaybeT . $cachedHereBinary wdn . lift . getBy $ UniqueWorkflowInstance wdn WSGlobal dbScope <- fmap (view _DBWorkflowScope) . hoist lift $ fromRouteWorkflowScope rScope
caseChanged wdn workflowInstanceName Entity _ WorkflowInstance{..} <- lift . lift . getBy404 $ UniqueWorkflowInstance win dbScope
caseChanged win workflowInstanceName
return $ route return $ route
& typesUsing @RouteChildren @WorkflowInstanceName . filtered (== wdn) .~ workflowInstanceName & typesUsing @RouteChildren @WorkflowInstanceName . filtered (== win) .~ workflowInstanceName
verifySubmission = maybeOrig $ \route -> do verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- $cachedHereBinary cID $ decrypt cID sId <- $cachedHereBinary cID $ decrypt cID
@ -270,5 +275,11 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
tell . Any $ route /= newRoute tell . Any $ route /= newRoute
return newRoute return newRoute
verifyWorkflowWorkflow = maybeOrig $ \route -> do
-- TODO: verify*WorkflowWorkflow (_, 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

16
src/Handler/Utils.hs
View File

@ -177,3 +177,19 @@ redirectAccessWith status url = liftHandler $ do
case access of case access of
Authorized -> redirectWith status url Authorized -> redirectWith status url
_ -> permissionDeniedI MsgUnauthorizedRedirect _ -> 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])

77
src/Handler/Utils/Form.hs
View File

@ -161,25 +161,22 @@ instance Button UniWorX ButtonSubmitDelete where
nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- | Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX) linkButton :: Widget -- ^ Widget to display if unauthorized
-- deriving (Enum, Eq, Ord, Bounded, Read, Show) -> Widget -- ^ Button label
-- -> [ButtonClass UniWorX]
-- instance PathPiece LinkButton where -> SomeRoute UniWorX
-- LinkButton route = ??? -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton :: Widget -> Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton defWdgt lbl cls url = do linkButton defWdgt lbl cls url = do
access <- evalAccess (urlRoute url) False access <- hasReadAccessTo $ urlRoute url
case access of if | not access -> defWdgt
Unauthorized _ -> defWdgt | otherwise -> do
_other -> do url' <- toTextUrl url
url' <- toTextUrl url [whamlet|
[whamlet| $newline never
$newline never <a href=#{url'} :not (onull cls):class=#{unwords $ map toPathPiece cls}>
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button> ^{lbl}
^{lbl} |]
|]
-------------------------- --------------------------
-- Interactive fieldset -- -- Interactive fieldset --
@ -847,37 +844,23 @@ uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybeM file
File{fileContent = Just fc} <- return f File{fileContent = Just fc} <- return f
liftHandler . runDB . runConduit $ fc .| C.fold 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. genericFileField :: forall m.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
) )
=> Handler FileField -> Field m FileUploads => Handler (FileField FileReference) -> Field m FileUploads
genericFileField mkOpts = Field{..} genericFileField mkOpts = Field{..}
where where
permittedExtension :: FileField -> FileName -> Bool permittedExtension :: FileField FileReference -> FileName -> Bool
permittedExtension FileField{..} fTitle permittedExtension FileField{..} fTitle
| unpack fTitle `Map.member` fieldAdditionalFiles | unpack fTitle `Map.member` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
= True = True
| Just exts <- fieldRestrictExtensions | Just exts <- fieldRestrictExtensions
= anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
| otherwise | otherwise
= True = 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 getIdent FileField{..} = do
ident <- case fieldIdent of ident <- case fieldIdent of
Just ident -> return $ Just ident Just ident -> return $ Just ident
@ -891,7 +874,7 @@ genericFileField mkOpts = Field{..}
$logDebugS "genericFileField.getIdent" $ tshow ident $logDebugS "genericFileField.getIdent" $ tshow ident
return 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 getPermittedFiles mIdent opts@FileField{..} = do
sessionFiles <- for mIdent $ \fieldIdent' -> sessionFiles <- for mIdent $ \fieldIdent' ->
foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles 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" $ "Additional: " <> tshow fieldAdditionalFiles
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
return $ mconcat return $ mconcat
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) fieldAdditionalFiles [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
, sessionFiles' , 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 handleUpload FileField{fieldMaxFileSize} mIdent
= C.map (transFile liftHandler) = C.map (transFile liftHandler)
.| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do .| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do
@ -1029,10 +1012,10 @@ genericFileField mkOpts = Field{..}
fuiChecked fuiChecked
| Right sentVals' <- sentVals | Right sentVals' <- sentVals
= fuiTitle `Set.member` sentVals' = fuiTitle `Set.member` sentVals'
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle fieldAdditionalFiles | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
= fieldOptionDefault = fieldOptionDefault
| otherwise = False | otherwise = False
fuiSession = fuiTitle `Map.notMember` fieldAdditionalFiles fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
fuiForced fuiForced
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles
= fieldOptionForce = fieldOptionForce
@ -1066,7 +1049,7 @@ fileFieldMultiple = genericFileField $ return FileField
, fieldUnpackZips = FileFieldUserOption True False , fieldUnpackZips = FileFieldUserOption True False
, fieldMultiple = True , fieldMultiple = True
, fieldRestrictExtensions = Nothing , fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = Map.empty , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing
} }
@ -1082,7 +1065,7 @@ singleFileField prev = genericFileField $ do
, fieldUnpackZips = FileFieldUserOption True False , fieldUnpackZips = FileFieldUserOption True False
, fieldMultiple = False , fieldMultiple = False
, fieldRestrictExtensions = Nothing , fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = Map.fromList , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList permitted | FileReference{..} <- Set.toList permitted
] ]
@ -1095,7 +1078,7 @@ specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id
, fieldUnpackZips = FileFieldUserOption True False , fieldUnpackZips = FileFieldUserOption True False
, fieldMultiple = False , fieldMultiple = False
, fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName , 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 , fieldMaxFileSize = specificFileMaxSize
} }
where where
@ -1109,7 +1092,7 @@ zipFileField doUnpack permittedExtensions = genericFileField $ return FileField
, fieldUnpackZips = FileFieldUserOption True doUnpack , fieldUnpackZips = FileFieldUserOption True doUnpack
, fieldMultiple = doUnpack , fieldMultiple = doUnpack
, fieldRestrictExtensions = permittedExtensions , fieldRestrictExtensions = permittedExtensions
, fieldAdditionalFiles = Map.empty , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
, fieldMaxFileSize = Nothing , fieldMaxFileSize = Nothing
} }
@ -1145,7 +1128,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
, fieldUnpackZips = FileFieldUserOption False False , fieldUnpackZips = FileFieldUserOption False False
, fieldMultiple = True , fieldMultiple = True
, fieldRestrictExtensions = Nothing , fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = Map.fromList , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
| FileReference{..} <- Set.toList permitted | FileReference{..} <- Set.toList permitted
] ]

60
src/Handler/Utils/Workflow/CanonicalRoute.hs Normal file
View 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
View 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

50
src/Handler/Utils/Workflow/Form.hs
View File

@ -26,6 +26,8 @@ import qualified Control.Monad.State.Class as State
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Aeson as JSON
newtype FileIdent = FileIdent (CI Text) newtype FileIdent = FileIdent (CI Text)
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -33,6 +35,54 @@ newtype FileIdent = FileIdent (CI Text)
makeWrapped ''FileIdent 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 data WorkflowGraphForm = WorkflowGraphForm
{ wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser { wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
, wgfFiles :: Map FileIdent FileReference , wgfFiles :: Map FileIdent FileReference

60
src/Handler/Workflow/Instance/Initiate.hs
View File

@ -5,6 +5,16 @@ module Handler.Workflow.Instance.Initiate
import Import 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 :: WorkflowInstanceName -> Handler Html
getGWIInitiateR = postGWIInitiateR getGWIInitiateR = postGWIInitiateR
@ -12,4 +22,52 @@ postGWIInitiateR win
= workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal = workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html 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")

44
src/Handler/Workflow/Instance/List.hs
View File

@ -9,12 +9,16 @@ module Handler.Workflow.Instance.List
import Import import Import
import Handler.Utils import Handler.Utils
import Utils.Workflow
import Handler.Utils.Workflow.CanonicalRoute
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.List.NonEmpty as NonEmpty
type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance) type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance)
@ -121,5 +125,41 @@ getAdminWorkflowInstanceListR = do
getGlobalWorkflowInstanceListR :: Handler Html getGlobalWorkflowInstanceListR :: Handler Html
getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
workflowInstanceListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html
workflowInstanceListR = error "not implemented" 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)

2
src/Import/NoModel.hs
View File

@ -202,6 +202,8 @@ import Data.Word.Word24 as Import
import Data.Kind as Import (Type, Constraint) import Data.Kind as Import (Type, Constraint)
import Data.Scientific as Import (Scientific, formatScientific)
import Control.Monad.Trans.RWS (RWST) import Control.Monad.Trans.RWS (RWST)

2
src/Jobs/Handler/Files.hs
View File

@ -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) 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.^. 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.^. 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)
] ]

109
src/Model/Types/File.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
module Model.Types.File module Model.Types.File
( FileContentChunkReference(..), FileContentReference(..) ( FileContentChunkReference(..), FileContentReference(..)
, File(..), _fileTitle, _fileContent, _fileModified , File(..), _fileTitle, _fileContent, _fileModified
@ -6,6 +8,13 @@ module Model.Types.File
, minioFileReference , minioFileReference
, FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
, HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual) , 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 ) where
import Import.NoModel import Import.NoModel
@ -26,6 +35,9 @@ import qualified Data.Conduit.Combinators as C
import Text.Show import Text.Show
import qualified Data.Aeson as JSON
import qualified Data.Map as Map
newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512) newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512)
@ -144,13 +156,27 @@ class HasFileReference record where
_FileReference :: Iso' record (FileReference, FileReferenceResidual record) _FileReference :: Iso' record (FileReference, FileReferenceResidual record)
instance HasFileReference FileReference where instance HasFileReference FileReference where
data FileReferenceResidual FileReference = FileReferenceResidual 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 _FileReference = iso (, FileReferenceResidual) $ view _1
-- _FileReferenceTitleMapElem = iso (\FileReferenceFileReferenceTitleMapElem{..} -> (fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional)) (\(fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional) -> FileReferenceFileReferenceTitleMapElem{..})
instance HasFileReference PureFile where instance HasFileReference PureFile where
newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON)
_FileReference = iso toFileReference fromFileReference _FileReference = iso toFileReference fromFileReference
where where
@ -168,6 +194,7 @@ instance HasFileReference PureFile where
instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where
newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) }
_FileReference = iso doSplit doJoin _FileReference = iso doSplit doJoin
where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference
doSplit (Left r) = over _2 (FileReferenceResidualEither . Left ) $ 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 { fileReferenceResidualEntityKey :: Key record
, fileReferenceResidualEntityResidual :: FileReferenceResidual record , fileReferenceResidualEntityResidual :: FileReferenceResidual record
} }
_FileReference = iso doSplit doJoin _FileReference = iso doSplit doJoin
where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res)
where (fRef, res) = entityVal ^. _FileReference where (fRef, res) = entityVal ^. _FileReference
@ -188,3 +216,84 @@ class (PersistEntity record, HasFileReference record) => IsFileReference record
fileReferenceTitleField :: EntityField record FilePath fileReferenceTitleField :: EntityField record FilePath
fileReferenceContentField :: EntityField record (Maybe FileContentReference) fileReferenceContentField :: EntityField record (Maybe FileContentReference)
fileReferenceModifiedField :: EntityField record UTCTime 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

1
src/Model/Types/Security.hs
View File

@ -162,6 +162,7 @@ makePrisms ''PredLiteral
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = TaggedObject "val" "var" , sumEncoding = TaggedObject "val" "var"
} ''PredLiteral } ''PredLiteral

5
src/Model/Types/TH/JSON.hs
View File

@ -63,9 +63,8 @@ predNFAesonOptions :: Options
-- --
-- Moved to this module due to stage restriction -- Moved to this module due to stage restriction
predNFAesonOptions = defaultOptions predNFAesonOptions = defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece
, sumEncoding = ObjectWithSingleField , tagSingleConstructors = False
, tagSingleConstructors = True
} }

440
src/Model/Types/Workflow.hs
View File

@ -3,36 +3,57 @@
module Model.Types.Workflow module Model.Types.Workflow
( WorkflowGraph(..) ( WorkflowGraph(..)
, WorkflowGraphNodeLabel , WorkflowGraphNodeLabel
, WorkflowGraphNode(..)
, WorkflowGraphEdgeLabel
, WorkflowGraphEdge(..)
, WorkflowGraphEdgeFormOrder
, WorkflowGraphEdgeForm(..)
, WorkflowRole(..)
, WorkflowPayloadView(..)
, WorkflowPayloadSpec(..), _WorkflowPayloadSpec
, WorkflowPayloadFieldReference
, WorkflowPayloadField(..)
, WorkflowScope(..) , WorkflowScope(..)
, WorkflowScope'(..), classifyWorkflowScope , WorkflowScope'(..), classifyWorkflowScope
, WorkflowPayloadLabel
, WorkflowState , WorkflowState
, WorkflowAction(..) , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime
, WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload
, WorkflowFieldPayload(..), _WorkflowFieldPayload
, workflowStatePayload, workflowStateCurrentPayloads
, WorkflowChildren , WorkflowChildren
) where ) where
import Import.NoModel import Import.NoModel
import Model.Types.Security (AuthDNF) 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 Database.Persist.Sql (PersistFieldSql(..))
import Data.Scientific
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Aeson (genericToJSON, genericParseJSON) import Data.Aeson (genericToJSON, genericParseJSON)
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON import qualified Data.Aeson.Types as JSON
import qualified Data.Aeson.Encoding as JSON
import Data.Aeson.Lens (_Null) import Data.Aeson.Lens (_Null)
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
import qualified Data.Set as Set 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 qualified Data.CaseInsensitive as CI
import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..)) import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..))
import Data.Typeable (cast)
import Data.Generics.Product.Types import Data.Generics.Product.Types
import Unsafe.Coerce
import Utils.Lens.TH
----- WORKFLOW GRAPH ----- ----- WORKFLOW GRAPH -----
@ -40,14 +61,17 @@ data WorkflowGraph fileid userid = WorkflowGraph
{ wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)
, wgPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView 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 ----- ----- WORKFLOW GRAPH: NODES -----
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) 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 data WorkflowGraphNode fileid userid = WGN
{ wgnDisplayLabel :: Maybe I18nText { wgnDisplayLabel :: Maybe I18nText
@ -55,20 +79,51 @@ data WorkflowGraphNode fileid userid = WGN
, wgnViewers :: Set (WorkflowRole userid) , wgnViewers :: Set (WorkflowRole userid)
, wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid 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 ----- ----- WORKFLOW GRAPH: EDGES -----
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) 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 data WorkflowGraphEdge fileid userid
= WorkflowGraphEdgeManual = WorkflowGraphEdgeManual
{ wgeSource :: WorkflowGraphNodeLabel { wgeSource :: WorkflowGraphNodeLabel
, wgeActors :: Set (WorkflowRole userid) , wgeActors :: Set (WorkflowRole userid)
, wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid 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: -- ^ field requirement forms a cnf:
-- --
-- - all labels must be filled -- - all labels must be filled
@ -76,22 +131,18 @@ data WorkflowGraphEdge fileid userid
-- - optional fields are always considered to be filled -- - optional fields are always considered to be filled
-- --
-- since fields can reference other labels this allows arbitrary requirements to be encoded. -- since fields can reference other labels this allows arbitrary requirements to be encoded.
} } deriving (Generic, Typeable)
| WorkflowGraphEdgeAutomatic
{ wgeSource :: WorkflowGraphNodeLabel
}
| WorkflowGraphEdgeInitial
{ wgeActors :: Set (WorkflowRole userid)
, wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid userid)))
}
deriving (Eq, Ord, Show, 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 ----- ----- WORKFLOW GRAPH: ROLES / ACTORS -----
data WorkflowRole userid data WorkflowRole userid
= WorkflowRoleUser { workflowRoleUser :: userid } = WorkflowRoleUser { workflowRoleUser :: userid }
| WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF } | WorkflowRolePayloadReference { workflowRolePayloadLabel :: WorkflowPayloadLabel }
| WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF }
| WorkflowRoleInitiator | WorkflowRoleInitiator
deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) 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) data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload)
deriving (Typeable) 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 data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldText :: { wpftLabel :: I18nText WorkflowPayloadFieldText :: { wpftLabel :: I18nText
@ -131,29 +185,37 @@ data WorkflowPayloadField fileid userid (payload :: Type) where
} -> WorkflowPayloadField fileid userid Bool } -> WorkflowPayloadField fileid userid Bool
WorkflowPayloadFieldFile :: { wpffLabel :: I18nText WorkflowPayloadFieldFile :: { wpffLabel :: I18nText
, wpffTooltip :: Maybe I18nHtml , wpffTooltip :: Maybe I18nHtml
, wpffDefault :: Maybe fileid , wpffConfig :: FileField fileid
, wpffOptional :: Bool , wpffOptional :: Bool
} -> WorkflowPayloadField fileid userid FileInfo } -> WorkflowPayloadField fileid userid (Set fileid)
WorkflowPayloadFieldUser :: { wpfuLabel :: I18nText WorkflowPayloadFieldUser :: { wpfuLabel :: I18nText
, wpfuTooltip :: Maybe I18nHtml , wpfuTooltip :: Maybe I18nHtml
, wpfuDefault :: Maybe userid , wpfuDefault :: Maybe userid
, wpfuOptional :: Bool , wpfuOptional :: Bool
} -> WorkflowPayloadField fileid userid userid } -> WorkflowPayloadField fileid userid userid
WorkflowPayloadFieldCaptureUser :: WorkflowPayloadField fileid userid userid
WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel 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 (Typeable)
deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadField fileid userid payload) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadField fileid userid payload)
deriving instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadField fileid userid payload) deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid, Eq (FileField fileid)) => Eq (WorkflowPayloadField fileid userid payload)
deriving instance (Ord fileid, Ord userid) => Ord (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) (WorkflowPayloadSpec a) == (WorkflowPayloadSpec b)
= case typeOf a `eqTypeRep` typeOf b of = case typeOf a `eqTypeRep` typeOf b of
Just HRefl -> a == b Just HRefl -> a == b
Nothing -> False 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) (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b)
= case typeOf a `eqTypeRep` typeOf b of = case typeOf a `eqTypeRep` typeOf b of
Just HRefl -> a `compare` b Just HRefl -> a `compare` b
@ -173,7 +235,29 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work
(WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT
(WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT
(WorkflowPayloadFieldUser{}, _) -> LT (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 ----- ----- WORKFLOW INSTANCE -----
@ -203,20 +287,20 @@ classifyWorkflowScope = \case
newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text }
deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) 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)) type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))
data WorkflowAction fileid userid = WorkflowAction data WorkflowAction fileid userid = WorkflowAction
{ wpTo :: WorkflowGraphNodeLabel { wpTo :: WorkflowGraphNodeLabel
, wpVia :: WorkflowGraphEdgeLabel , 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 , wpUser :: Maybe (Maybe userid) -- ^ Outer `Maybe` encodes automatic/manual, inner `Maybe` encodes whether user was authenticated
, wpTime :: UTCTime , wpTime :: UTCTime
} }
deriving (Eq, Ord, Show, Generic, Typeable) 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) deriving (Typeable)
instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where 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{}, WFPText{}) -> GT
(WFPBool{}, WFPNumber{}) -> GT (WFPBool{}, WFPNumber{}) -> GT
(WFPBool{}, _) -> LT (WFPBool{}, _) -> LT
(WFPFile{}, WFPText{}) -> GT (WFPFiles{}, WFPText{}) -> GT
(WFPFile{}, WFPNumber{}) -> GT (WFPFiles{}, WFPNumber{}) -> GT
(WFPFile{}, WFPBool{}) -> GT (WFPFiles{}, WFPBool{}) -> GT
(WFPFile{}, _) -> LT (WFPFiles{}, _) -> LT
(WFPUser{}, _) -> GT (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 instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
show (WorkflowFieldPayloadW payload) = show payload show (WorkflowFieldPayloadW payload) = show payload
data WorkflowFieldPayload fileid userid (payload :: Type) where data WorkflowFieldPayload fileid userid (payload :: Type) where
WFPText :: Text -> WorkflowFieldPayload fileid userid Text WFPText :: Text -> WorkflowFieldPayload fileid userid Text
WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific
WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool
WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid WFPFiles :: Set fileid -> WorkflowFieldPayload fileid userid (Set fileid)
WFPUser :: userid -> WorkflowFieldPayload fileid userid userid WFPUser :: userid -> WorkflowFieldPayload fileid userid userid
WFPMultiple :: NonEmpty (WorkflowFieldPayloadW fileid userid) -> WorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))
deriving (Typeable) deriving (Typeable)
deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload) deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload)
deriving instance (Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) deriving instance (Typeable fileid, Typeable userid, 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, 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 (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
deriving anyclass (Universe, Finite) 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 "'" workflowStatePayload :: forall fileid userid payload.
nullaryPathPiece ''WorkflowFieldPayload'' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" ( 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 ----- ----- Generic traversal -----
@ -282,6 +409,8 @@ type family ChildrenWorkflowChildren a where
ChildrenWorkflowChildren (Map k v) = '[v] ChildrenWorkflowChildren (Map k v) = '[v]
ChildrenWorkflowChildren (Set a) = '[a] ChildrenWorkflowChildren (Set a) = '[a]
ChildrenWorkflowChildren (Seq a) = '[a] ChildrenWorkflowChildren (Seq a) = '[a]
ChildrenWorkflowChildren [a] = '[a]
ChildrenWorkflowChildren (NonEmpty a) = '[a]
ChildrenWorkflowChildren (NonNull mono) = '[Element mono] ChildrenWorkflowChildren (NonNull mono) = '[Element mono]
ChildrenWorkflowChildren (CI a) = '[a] ChildrenWorkflowChildren (CI a) = '[a]
ChildrenWorkflowChildren UUID = '[] ChildrenWorkflowChildren UUID = '[]
@ -315,6 +444,9 @@ type family ChildrenWorkflowChildren a where
instance HasTypesCustom WorkflowChildren a a a a where instance HasTypesCustom WorkflowChildren a a a a where
typesCustom = id 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 instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where
typesCustom = traverse . typesCustom @WorkflowChildren 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 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 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 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{ wpffDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid', .. } typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = traverseOf (_fieldAdditionalFiles . _FileReferenceTitleMap . _1) f wpffConfig <&> \wpffConfig' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffConfig = wpffConfig', .. }
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, .. }) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, ..} 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 WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} 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 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 _ (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 WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} 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 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 Nothing -> pure pw
instance (fileid ~ fileid', userid ~ userid', payload ~ payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where 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 (WFPText x) = WFPText <$> f x typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid userid) of
typesCustom f (WFPNumber x) = WFPNumber <$> f x Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid userid) @(WorkflowFieldPayload fileid' userid' userid') @userid @userid' f p
typesCustom f (WFPBool x) = WFPBool <$> f x 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
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 ----- ----- ToJSON / FromJSON instances -----
@ -371,38 +534,84 @@ deriveJSON defaultOptions
} ''WorkflowRole } ''WorkflowRole
deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
pathPieceJSON ''WorkflowFieldPayload'' pathPieceJSON ''WorkflowFieldPayload'
pathPieceJSON ''WorkflowPayloadField'
instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where
parseJSON = genericParseJSON workflowPayloadViewAesonOptions 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 toJSON = genericToJSON workflowGraphAesonOptions
instance ( FromJSON fileid, FromJSON userid instance ( FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, FromJSON (FileField fileid)
, Ord (FileField fileid)
) => FromJSON (WorkflowGraph fileid userid) where ) => FromJSON (WorkflowGraph fileid userid) where
parseJSON = genericParseJSON workflowGraphAesonOptions 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 toJSON = genericToJSON workflowGraphEdgeAesonOptions
instance ( FromJSON fileid, FromJSON userid instance ( FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, FromJSON (FileField fileid)
, Ord (FileField fileid)
) => FromJSON (WorkflowGraphEdge fileid userid) where ) => FromJSON (WorkflowGraphEdge fileid userid) where
parseJSON = genericParseJSON workflowGraphEdgeAesonOptions parseJSON = genericParseJSON workflowGraphEdgeAesonOptions
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid userid) where instance ToJSON WorkflowGraphEdgeFormOrder where
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = JSON.object $ omitNothing toJSON WorkflowGraphEdgeFormOrder{..} = case unWorkflowGraphEdgeFormOrder of
[ "tag" JSON..= ("text" :: Text) 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 , "label" JSON..= wpftLabel
, "placeholder" JSON..= wpftPlaceholder , "placeholder" JSON..= wpftPlaceholder
, "tooltip" JSON..= wpftTooltip , "tooltip" JSON..= wpftTooltip
, "default" JSON..= wpftDefault , "default" JSON..= wpftDefault
, "optional" JSON..= wpftOptional , "optional" JSON..= wpftOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing toJSON (WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("number" :: Text) [ "tag" JSON..= WPFNumber'
, "label" JSON..= wpfnLabel , "label" JSON..= wpfnLabel
, "placeholder" JSON..= wpfnPlaceholder , "placeholder" JSON..= wpfnPlaceholder
, "tooltip" JSON..= wpfnTooltip , "tooltip" JSON..= wpfnTooltip
@ -412,46 +621,60 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us
, "step" JSON..= wpfnStep , "step" JSON..= wpfnStep
, "optional" JSON..= wpfnOptional , "optional" JSON..= wpfnOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing toJSON (WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("bool" :: Text) [ "tag" JSON..= WPFBool'
, "label" JSON..= wpfbLabel , "label" JSON..= wpfbLabel
, "tooltip" JSON..= wpfbTooltip , "tooltip" JSON..= wpfbTooltip
, "default" JSON..= wpfbDefault , "default" JSON..= wpfbDefault
, "optional" JSON..= wpfbOptional , "optional" JSON..= wpfbOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing toJSON (WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("file" :: Text) [ "tag" JSON..= WPFFile'
, "label" JSON..= wpffLabel , "label" JSON..= wpffLabel
, "tooltip" JSON..= wpffTooltip , "tooltip" JSON..= wpffTooltip
, "default" JSON..= wpffDefault , "config" JSON..= wpffConfig
, "optional" JSON..= wpffOptional , "optional" JSON..= wpffOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing toJSON (WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("user" :: Text) [ "tag" JSON..= WPFUser'
, "label" JSON..= wpfuLabel , "label" JSON..= wpfuLabel
, "tooltip" JSON..= wpfuTooltip , "tooltip" JSON..= wpfuTooltip
, "default" JSON..= wpfuDefault , "default" JSON..= wpfuDefault
, "optional" JSON..= wpfuOptional , "optional" JSON..= wpfuOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = JSON.object toJSON (WorkflowPayloadFieldCaptureUser{}) = JSON.object
[ "tag" JSON..= ("reference" :: Text) [ "tag" JSON..= WPFCaptureUser'
]
toJSON (WorkflowPayloadFieldReference{..}) = JSON.object
[ "tag" JSON..= WPFReference'
, "target" JSON..= wpfrTarget , "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 instance ( FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, FromJSON (FileField fileid)
) => FromJSON (WorkflowPayloadSpec fileid userid) where ) => FromJSON (WorkflowPayloadSpec fileid userid) where
parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do
fieldTag <- (o JSON..: "tag" :: Parser Text) fieldTag <- o JSON..: "tag"
case fieldTag of case fieldTag of
"text" -> do WPFText' -> do
wpftLabel <- o JSON..: "label" wpftLabel <- o JSON..: "label"
wpftPlaceholder <- o JSON..:? "placeholder" wpftPlaceholder <- o JSON..:? "placeholder"
wpftTooltip <- o JSON..:? "tooltip" wpftTooltip <- o JSON..:? "tooltip"
wpftDefault <- o JSON..:? "default" wpftDefault <- o JSON..:? "default"
wpftOptional <- o JSON..: "optional" wpftOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
"number" -> do WPFNumber' -> do
wpfnLabel <- o JSON..: "label" wpfnLabel <- o JSON..: "label"
wpfnPlaceholder <- o JSON..:? "placeholder" wpfnPlaceholder <- o JSON..:? "placeholder"
wpfnTooltip <- o JSON..:? "tooltip" wpfnTooltip <- o JSON..:? "tooltip"
@ -461,34 +684,44 @@ instance ( FromJSON fileid, FromJSON userid
wpfnStep <- o JSON..: "step" wpfnStep <- o JSON..: "step"
wpfnOptional <- o JSON..: "optional" wpfnOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
"bool" -> do WPFBool' -> do
wpfbLabel <- o JSON..: "label" wpfbLabel <- o JSON..: "label"
wpfbTooltip <- o JSON..:? "tooltip" wpfbTooltip <- o JSON..:? "tooltip"
wpfbOptional <- o JSON..: "optional" wpfbOptional <- o JSON..: "optional"
wpfbDefault <- (o JSON..: "default" :: Parser (Maybe Bool)) wpfbDefault <- (o JSON..: "default" :: Parser (Maybe Bool))
return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
"file" -> do WPFFile' -> do
wpffLabel <- o JSON..: "label" wpffLabel <- o JSON..: "label"
wpffTooltip <- o JSON..:? "tooltip" wpffTooltip <- o JSON..:? "tooltip"
wpffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) wpffConfig <- o JSON..: "config"
wpffOptional <- o JSON..: "optional" wpffOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
"user" -> do WPFUser' -> do
wpfuLabel <- o JSON..: "label" wpfuLabel <- o JSON..: "label"
wpfuTooltip <- o JSON..:? "tooltip" wpfuTooltip <- o JSON..:? "tooltip"
wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid))
wpfuOptional <- o JSON..: "optional" wpfuOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
"reference" -> do WPFCaptureUser' -> pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
WPFReference' -> do
wpfrTarget <- o JSON..: "target" wpfrTarget <- o JSON..: "target"
return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} 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 toJSON = genericToJSON workflowGraphNodeAesonOptions
instance ( FromJSON fileid, FromJSON userid instance ( FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, FromJSON (FileField fileid)
, Ord (FileField fileid)
) => FromJSON (WorkflowGraphNode fileid userid) where ) => FromJSON (WorkflowGraphNode fileid userid) where
parseJSON = genericParseJSON workflowGraphNodeAesonOptions parseJSON = genericParseJSON workflowGraphNodeAesonOptions
@ -520,15 +753,19 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid
[ "tag" JSON..= WFPBool' [ "tag" JSON..= WFPBool'
, toPathPiece WFPBool' JSON..= b , toPathPiece WFPBool' JSON..= b
] ]
toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object toJSON (WorkflowFieldPayloadW (WFPFiles fid)) = JSON.object
[ "tag" JSON..= WFPFile' [ "tag" JSON..= WFPFiles'
, toPathPiece WFPFile' JSON..= fid , toPathPiece WFPFiles' JSON..= fid
] ]
toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object
[ "tag" JSON..= WFPUser' [ "tag" JSON..= WFPUser'
, toPathPiece WFPUser' JSON..= uid , 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 parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do
fieldTag <- o JSON..: "tag" fieldTag <- o JSON..: "tag"
case fieldTag of case fieldTag of
@ -541,12 +778,15 @@ instance (FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) =>
WFPBool' -> do WFPBool' -> do
b <- o JSON..: toPathPiece WFPBool' b <- o JSON..: toPathPiece WFPBool'
return $ WorkflowFieldPayloadW $ WFPBool b return $ WorkflowFieldPayloadW $ WFPBool b
WFPFile' -> do WFPFiles' -> do
fid <- o JSON..: toPathPiece WFPFile' fid <- o JSON..: toPathPiece WFPFiles'
return $ WorkflowFieldPayloadW $ WFPFile fid return $ WorkflowFieldPayloadW $ WFPFiles fid
WFPUser' -> do WFPUser' -> do
uid <- o JSON..: toPathPiece WFPUser' uid <- o JSON..: toPathPiece WFPUser'
return $ WorkflowFieldPayloadW $ WFPUser uid 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 , FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, ToJSON (FileField fileid), FromJSON (FileField fileid)
, Ord (FileField fileid)
) => PersistField (WorkflowGraph fileid userid) where ) => PersistField (WorkflowGraph fileid userid) where
toPersistValue = toPersistValueJSON toPersistValue = toPersistValueJSON
fromPersistValue = fromPersistValueJSON fromPersistValue = fromPersistValueJSON
@ -563,6 +805,8 @@ instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON userid , FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid , Typeable fileid, Typeable userid
, ToJSON (FileField fileid), FromJSON (FileField fileid)
, Ord (FileField fileid)
) => PersistFieldSql (WorkflowGraph fileid userid) where ) => PersistFieldSql (WorkflowGraph fileid userid) where
sqlType _ = sqlTypeJSON sqlType _ = sqlTypeJSON
@ -598,3 +842,5 @@ instance ( ToJSON fileid, ToJSON userid
instance Binary WorkflowScope' instance Binary WorkflowScope'
instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid) instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)
instance Binary userid => Binary (WorkflowRole userid)

4
src/Settings.hs
View File

@ -36,7 +36,7 @@ import Language.Haskell.TH.Syntax (Exp, Q)
#endif #endif
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Data.Scientific (Scientific, toBoundedInteger) import qualified Data.Scientific as Scientific
import Data.Word (Word16) import Data.Word (Word16)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -338,7 +338,7 @@ deriveFromJSON
''ResourcePoolConf ''ResourcePoolConf
instance FromJSON HaskellNet.PortNumber where 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) Just int -> return $ fromIntegral (int :: Word16)
Nothing -> fail "Expected whole number of plausible size to denote port" Nothing -> fail "Expected whole number of plausible size to denote port"

6
src/Utils.hs
View File

@ -565,6 +565,9 @@ mapF = flip Map.fromSet $ Set.fromList universeF
partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v) 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) 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 -- -- 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 :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a
catchIfMPlus p act = catchIf p act (const mzero) catchIfMPlus p act = catchIf p act (const mzero)
fromMaybeT :: MaybeT Identity a -> Maybe a
fromMaybeT = runIdentity . runMaybeT
mcons :: Maybe a -> [a] -> [a] mcons :: Maybe a -> [a] -> [a]
mcons Nothing xs = xs mcons Nothing xs = xs
mcons (Just x) xs = x:xs mcons (Just x) xs = x:xs

19
src/Utils/Form.hs
View File

@ -350,7 +350,12 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
{ fvLabel = toHtml $ mr fsLabel { fvLabel = toHtml $ mr fsLabel
, fvTooltip = fmap (toHtml . mr) fsTooltip , fvTooltip = fmap (toHtml . mr) fsTooltip
, fvId , 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 , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
, fvRequired = False , 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 :: Functor m => AnIso' a b -> Field m a -> Field m b
isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso) 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 selectField' :: ( Eq a
, RenderMessage (HandlerSite m) FormMessage , RenderMessage (HandlerSite m) FormMessage
@ -1150,7 +1158,7 @@ warnValidation msg isValid = unless isValid $ addMessageI Warning msg
-- Form Manipulation -- -- 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 aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
where where
mFormToWForm' f = do 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 -- ^ 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) 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@, ... -- -- Special variants of @mopt@, @mreq@, ... --
--------------------------------------------- ---------------------------------------------

72
src/Utils/I18n.hs
View File

@ -5,6 +5,8 @@ module Utils.I18n
, I18nText, I18nHtml , I18nText, I18nHtml
, renderMessageI18n , renderMessageI18n
, i18nMessageFor , i18nMessageFor
, LanguageSelectI18n(..), getLanguageSelectI18n
, selectLanguageI18n
, Element , Element
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable' , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
) where ) where
@ -27,7 +29,7 @@ import Language.Haskell.TH.Syntax (qRunIO)
import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.List as List 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.List.NonEmpty as NonEmpty
import qualified Data.Text as Text import qualified Data.Text as Text
@ -37,12 +39,17 @@ import System.Directory (listDirectory)
import Utils.NTop import Utils.NTop
import Control.Lens (iforM) import Utils.Lang (selectLanguage')
import Control.Lens
import Control.Lens.Extras (is)
import Control.Monad.Fail (fail) import Control.Monad.Fail (fail)
data I18n a = I18n data I18n a = I18n
{ i18nFallback :: a { i18nFallback :: a
, i18nFallbackLang :: Maybe Lang
, i18nTranslations :: Map Lang a , i18nTranslations :: Map Lang a
} deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable) } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable)
deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable) deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable)
@ -53,7 +60,7 @@ type I18nHtml = I18n Html
instance MonoPointed (I18n a) where 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 instance IsString a => IsString (I18n a) where
fromString = opoint . fromString fromString = opoint . fromString
@ -61,28 +68,32 @@ instance IsString a => IsString (I18n a) where
instance ToJSON a => ToJSON (I18n a) where instance ToJSON a => ToJSON (I18n a) where
toJSON I18n{..} toJSON I18n{..}
| Map.null i18nTranslations | Map.null i18nTranslations
, is _Nothing i18nFallbackLang
, fallbackUnambiguous , fallbackUnambiguous
= toJSON i18nFallback = toJSON i18nFallback
| Map.null i18nTranslations
= JSON.object [ "fallback" JSON..= i18nFallback ]
| otherwise | otherwise
= JSON.object [ "fallback" JSON..= i18nFallback = JSON.object $ catMaybes
, "translations" JSON..= i18nTranslations [ pure $ "fallback" JSON..= i18nFallback
] , ("fallback-lang" JSON..=) <$> i18nFallbackLang
, ("translations" JSON..=) <$> (i18nTranslations <$ guard (not $ Map.null i18nTranslations))
]
where where
fallbackUnambiguous = case toJSON i18nFallback of 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 _other -> True
instance FromJSON a => FromJSON (I18n a) where instance FromJSON a => FromJSON (I18n a) where
parseJSON (JSON.Object o) parseJSON (JSON.Object o)
| HashMap.member "fallback" o = do | HashMap.member "fallback" o || HashMap.member "fallback-lang" o = do
i18nFallback <- o JSON..: "fallback" i18nFallback <- o JSON..: "fallback"
i18nFallbackLang <- o JSON..:? "fallback-lang"
i18nTranslations <- o JSON..:? "translations" JSON..!= Map.empty i18nTranslations <- o JSON..:? "translations" JSON..!= Map.empty
return I18n{..} return I18n{..}
parseJSON val = do parseJSON val = do
i18nFallback <- JSON.parseJSON val i18nFallback <- JSON.parseJSON val
let i18nTranslations = Map.empty let i18nTranslations = Map.empty
i18nFallbackLang = Nothing
return I18n{..} return I18n{..}
derivePersistFieldJSON ''I18n derivePersistFieldJSON ''I18n
@ -90,10 +101,14 @@ derivePersistFieldJSON ''I18n
renderMessageI18n :: RenderMessage site msg renderMessageI18n :: RenderMessage site msg
=> [Lang] -> site -> msg -> I18nText => [Lang] -> site -> msg -> I18nText
renderMessageI18n ls app msg = I18n renderMessageI18n ls app msg = I18n{..}
{ i18nFallback = renderMessage app ls msg where
, i18nTranslations = Map.fromList . flip map ls $ \l -> (l, ) $ renderMessage app (l : filter (/= l) ls) msg 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 i18nMessageFor :: ( MonadHandler m
, RenderMessage (HandlerSite m) msg , RenderMessage (HandlerSite m) msg
@ -101,6 +116,33 @@ i18nMessageFor :: ( MonadHandler m
=> [Lang] -> msg -> m I18nText => [Lang] -> msg -> m I18nText
i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg 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' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do i18nWidgetFilesAvailable' basename = do

7
src/Utils/Lens.hs
View File

@ -251,6 +251,13 @@ makeLenses_ ''WorkflowDefinitionInstanceDescription
makeLenses_ ''WorkflowScope makeLenses_ ''WorkflowScope
makeLenses_ ''WorkflowInstance makeLenses_ ''WorkflowInstance
makeLenses_ ''WorkflowInstanceDescription makeLenses_ ''WorkflowInstanceDescription
makeLenses_ ''WorkflowWorkflow
makeLenses_ ''WorkflowGraph
makeLenses_ ''WorkflowGraphNode
makeLenses_ ''WorkflowGraphEdge
makePrisms ''WorkflowGraphEdge
makeWrapped ''Textarea makeWrapped ''Textarea

48
src/Utils/Workflow.hs Normal file
View 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)

7
templates/widgets/massinput/workflow-payload-field-multiple/add.hamlet Normal file
View File

@ -0,0 +1,7 @@
$newline never
<td>
#{csrf}
$forall fv <- fvs
^{fvWidget fv}
<td style="vertical-align: bottom">
^{fvWidget btn}

5
templates/widgets/massinput/workflow-payload-field-multiple/cell.hamlet Normal file
View File

@ -0,0 +1,5 @@
$newline never
<td>
#{csrf}
$forall fv <- fvs
^{fvWidget fv}

19
templates/widgets/massinput/workflow-payload-field-multiple/layout.hamlet Normal file
View File

@ -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}

2
templates/widgets/occurrence/form/except-layout.hamlet
View File

@ -8,7 +8,7 @@ $newline never
^{fvWidget (delButtons ! coord)} ^{fvWidget (delButtons ! coord)}
$if null (review liveCoords lLength) $if null (review liveCoords lLength)
<tr> <tr>
<td colspan=3 style="font-weight: 600; font-size: 0.9rem; color: var(--color-fontsec);"> <td colspan=3 .note>
_{MsgOccurrenceNoneExceptions} _{MsgOccurrenceNoneExceptions}
<td colspan=3> <td colspan=3>
<div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);"> <div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">

2
templates/widgets/occurrence/form/scheduled-layout.hamlet
View File

@ -8,7 +8,7 @@ $newline never
^{fvWidget (delButtons ! coord)} ^{fvWidget (delButtons ! coord)}
$if null (review liveCoords lLength) $if null (review liveCoords lLength)
<tr> <tr>
<td colspan=3 style="font-weight: 600; font-size: 0.9rem; color: var(--color-fontsec);"> <td colspan=3 .note>
_{MsgOccurrenceNoneScheduled} _{MsgOccurrenceNoneScheduled}
<td colspan=3> <td colspan=3>
<div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);"> <div style="height:1px; width:90%; margin: 0.5em auto; background-color: var(--color-grey);">

6
templates/workflows/instance-initiate.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
$maybe desc <- workflowInstanceDescriptionDescription =<< mDesc
<section>
#{desc}
<section>
^{edgeView}

19
templates/workflows/instances.hamlet Normal file
View 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}

54
test/Database/Fill.hs
View File

@ -31,6 +31,8 @@ import Data.List (genericLength)
import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.Combinators as C
import qualified Data.Yaml as Yaml
testdataDir :: FilePath testdataDir :: FilePath
testdataDir = "testdata" testdataDir = "testdata"
@ -1282,3 +1284,55 @@ fillDb = do
_other -> return mempty _other -> return mempty
liftIO . LBS.writeFile (testdataDir </> "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities 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
View 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
View 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: {}