feat(workflows): wire up ws-school
This commit is contained in:
Gregor Kleen
parent
f2fb7d8c26
commit
82b3a6364c
@ -456,7 +456,7 @@ MaterialVideoDownload: Herunterladen
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
||||
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
||||
UnauthorizedNot r@Text: (NICHT #{r})
|
||||
UnauthorizedNot r@Text: #{r}
|
||||
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
|
||||
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
|
||||
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
|
||||
@ -1428,10 +1428,13 @@ MenuWorkflowInstanceDelete: Löschen
|
||||
MenuWorkflowInstanceWorkflows: Laufende Workflows
|
||||
MenuWorkflowInstanceInitiate: Workflow starten
|
||||
MenuWorkflowInstanceEdit: Bearbeiten
|
||||
MenuWorkflowWorkflowList: Laufende Workflows
|
||||
MenuWorkflowWorkflowEdit: Editieren
|
||||
MenuWorkflowWorkflowDelete: Löschen
|
||||
MenuGlobalWorkflowInstanceList: Workflows
|
||||
MenuGlobalWorkflowWorkflowList: Laufende Workflows
|
||||
MenuGlobalWorkflowInstanceList: Systemweite Workflows
|
||||
MenuTopWorkflowInstanceList: Workflows
|
||||
MenuTopWorkflowWorkflowList: Laufende Workflows
|
||||
MenuTopWorkflowWorkflowListHeader: Workflows
|
||||
|
||||
BreadcrumbSubmissionFile: Datei
|
||||
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
|
||||
@ -1524,12 +1527,14 @@ BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows
|
||||
BreadcrumbWorkflowInstanceInitiate: Workflow starten
|
||||
BreadcrumbWorkflowInstanceList: Workflows
|
||||
BreadcrumbWorkflowInstanceNew: Neuer Workflow
|
||||
BreadcrumbWorkflowWorkflowList: Laufende Workflows
|
||||
BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow: #{toPathPiece workflow}
|
||||
BreadcrumbWorkflowWorkflowFiles: Dateien
|
||||
BreadcrumbWorkflowWorkflowEdit: Editieren
|
||||
BreadcrumbWorkflowWorkflowDelete: Löschen
|
||||
BreadcrumbGlobalWorkflowInstanceList: Workflows
|
||||
BreadcrumbGlobalWorkflowWorkflowList: Laufende Workflows
|
||||
BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows
|
||||
BreadcrumbTopWorkflowInstanceList: Workflows
|
||||
BreadcrumbTopWorkflowWorkflowList: Laufende Workflows
|
||||
|
||||
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
|
||||
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
|
||||
@ -1571,7 +1576,7 @@ AuthTagParticipant: Nutzer ist mit Kurs assoziiert
|
||||
AuthTagApplicant: Nutzer ist mit Bewerber zum Kurs
|
||||
AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
|
||||
AuthTagCapacity: Kapazität ist ausreichend
|
||||
AuthTagEmpty: Kurs hat keine Teilnehmer
|
||||
AuthTagEmpty: Ressource ist „leer“
|
||||
AuthTagMaterials: Kursmaterialien sind freigegeben
|
||||
AuthTagOwner: Nutzer ist Besitzer
|
||||
AuthTagPersonalisedSheetFiles: Nutzer verfügt über personalisierte Übungsblatt-Dateien
|
||||
@ -3039,6 +3044,12 @@ GlobalWorkflowInstancesTitle: Workflows (Systemweit)
|
||||
GlobalWorkflowInstanceInitiateHeading workflowInstanceTitle@Text: Worklow initiieren: #{workflowInstanceTitle}
|
||||
GlobalWorkflowInstanceInitiateTitle: Worklow initiieren
|
||||
|
||||
SchoolWorkflowInstancesHeading ssh@SchoolId: Workflows (#{ssh})
|
||||
SchoolWorkflowInstancesTitle ssh@SchoolId: Workflows (#{ssh})
|
||||
|
||||
SchoolWorkflowInstanceInitiateHeading ssh@SchoolId workflowInstanceTitle@Text: Worklow initiieren: #{ssh}, #{workflowInstanceTitle}
|
||||
SchoolWorkflowInstanceInitiateTitle ssh@SchoolId: Worklow initiieren: #{ssh}
|
||||
|
||||
WorkflowEdgeNumberedVariant edgeLabel@Text i@Natural: #{edgeLabel} (Variante #{i})
|
||||
WorkflowEdgeFormEdge: Aktion
|
||||
WorkflowEdgeFormHiddenPayload i@Natural: Versteckter Datensatz #{i}
|
||||
@ -3075,9 +3086,15 @@ WorkflowPayloadBoolTrue: Ja
|
||||
WorkflowPayloadBoolFalse: Nein
|
||||
WorkflowPayloadUserGone: Gelöschter Benutzer
|
||||
|
||||
TopWorkflowInstancesHeading: Workflows
|
||||
TopWorkflowInstancesTitle: Workflows
|
||||
|
||||
GlobalWorkflowWorkflowWorkflowHeading workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId}
|
||||
GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId}
|
||||
|
||||
SchoolWorkflowWorkflowWorkflowHeading ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
SchoolWorkflowWorkflowWorkflowTitle ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
|
||||
ChangelogItemFeature: Feature
|
||||
ChangelogItemBugfix: Bugfix
|
||||
|
||||
|
||||
@ -1532,7 +1532,7 @@ AuthTagParticipant: User participates in course
|
||||
AuthTagApplicant: User is applicant for course
|
||||
AuthTagRegisterGroup: User is not participant in any tutorial of the same registration group
|
||||
AuthTagCapacity: Capacity is sufficient
|
||||
AuthTagEmpty: Course is empty
|
||||
AuthTagEmpty: Resource is “empty”
|
||||
AuthTagMaterials: Course material is publicly accessable
|
||||
AuthTagOwner: User is owner
|
||||
AuthTagPersonalisedSheetFiles: User has been assigned personalised sheet files
|
||||
|
||||
@ -321,6 +321,7 @@ tests:
|
||||
- yesod-persistent
|
||||
- quickcheck-io
|
||||
- network-arbitrary
|
||||
- lens-properties
|
||||
ghc-options:
|
||||
- -fno-warn-orphans
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T"
|
||||
|
||||
29
routes
29
routes
@ -69,20 +69,23 @@
|
||||
/admin/workflows/workflows AdminWorkflowWorkflowListR GET
|
||||
/admin/workflows/workflows/new AdminWorkflowWorkflowNewR GET POST
|
||||
|
||||
/workflow-instances GlobalWorkflowInstanceListR GET !¬empty
|
||||
/workflow-instances/new GlobalWorkflowInstanceNewR GET POST
|
||||
/workflow-instances/#WorkflowInstanceName GlobalWorkflowInstanceR:
|
||||
/global-workflows/instances GlobalWorkflowInstanceListR GET !free
|
||||
/global-workflows/instances/new GlobalWorkflowInstanceNewR GET POST
|
||||
/global-workflows/instances/#WorkflowInstanceName GlobalWorkflowInstanceR:
|
||||
/edit GWIEditR GET POST
|
||||
/delete GWIDeleteR GET POST
|
||||
/workflows GWIWorkflowsR GET
|
||||
/workflows GWIWorkflowsR GET !¬empty
|
||||
/initiate GWIInitiateR GET POST !workflow
|
||||
/workflows GlobalWorkflowWorkflowListR GET !¬empty
|
||||
/workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
|
||||
/global-workflows GlobalWorkflowWorkflowListR GET !free
|
||||
!/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
|
||||
/ GWWWorkflowR GET POST !workflow
|
||||
/files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow
|
||||
/edit GWWEditR GET POST
|
||||
/delete GWWDeleteR GET POST
|
||||
|
||||
/workflow-instances TopWorkflowInstanceListR GET !free
|
||||
/workflows TopWorkflowWorkflowListR GET !free
|
||||
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
@ -132,6 +135,20 @@
|
||||
/school/#SchoolId SchoolR:
|
||||
/ SchoolEditR GET POST
|
||||
|
||||
/workflows/instances SchoolWorkflowInstanceListR GET !free
|
||||
/workflows/instances/new SchoolWorkflowInstanceNewR GET POST
|
||||
/workflows/instances/#WorkflowInstanceName SchoolWorkflowInstanceR:
|
||||
/edit SWIEditR GET POST
|
||||
/delete SWIDeleteR GET POST
|
||||
/workflows SWIWorkflowsR GET !¬empty
|
||||
/initiate SWIInitiateR GET POST !workflow
|
||||
/workflows SchoolWorkflowWorkflowListR GET !free
|
||||
!/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR:
|
||||
/ SWWWorkflowR GET POST !workflow
|
||||
/files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex SWWFilesR GET !workflow
|
||||
/edit SWWEditR GET POST
|
||||
/delete SWWDeleteR GET POST
|
||||
|
||||
/allocation/ AllocationListR GET !free
|
||||
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
||||
/ AShowR GET POST !free
|
||||
|
||||
@ -1199,55 +1199,47 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route o
|
||||
guard $ not hasOther
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRegisterGroup r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _ -> do
|
||||
let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let checkAccess (Entity _ WorkflowInstance{..})
|
||||
= fmap (is _Authorized) . flip (evalAccessFor mAuthId) True $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
getInstances = E.selectSource . E.from $ \workflowInstance -> do
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return workflowInstance
|
||||
|
||||
guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getInstances .| C.mapM checkAccess .| C.or
|
||||
return Authorized
|
||||
|
||||
wWorkflows rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let checkAccess (E.Value wwId) = do
|
||||
cID <- encrypt wwId
|
||||
fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
|
||||
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return $ workflowWorkflow E.^. WorkflowWorkflowId
|
||||
|
||||
guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getWorkflows .| C.mapM checkAccess .| C.or
|
||||
return Authorized
|
||||
|
||||
case route of
|
||||
_ | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute -> wInstances rScope
|
||||
_ | Just (rScope, WorkflowWorkflowListR) <- route ^? _WorkflowScopeRoute -> wWorkflows rScope
|
||||
EExamListR -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
|
||||
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
|
||||
E.||. E.exists (E.from $ \externalExamResult ->
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
|
||||
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
|
||||
)
|
||||
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
|
||||
-> let workflowInstanceWorkflowsEmpty rScope win = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
let dbScope = scope ^. _DBWorkflowScope
|
||||
getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
|
||||
E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
|
||||
E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope
|
||||
return ( workflowWorkflow E.^. WorkflowWorkflowId
|
||||
, workflowWorkflow E.^. WorkflowWorkflowScope
|
||||
)
|
||||
checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do
|
||||
cID <- encrypt wwId
|
||||
rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope
|
||||
guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
|
||||
return True
|
||||
guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
|
||||
return Authorized
|
||||
in case route of
|
||||
r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute
|
||||
-> workflowInstanceWorkflowsEmpty rScope win
|
||||
EExamListR -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
|
||||
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
|
||||
E.||. E.exists (E.from $ \externalExamResult ->
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
|
||||
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
|
||||
)
|
||||
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
@ -421,12 +421,12 @@ instance RenderMessage UniWorX ShortWeekDay where
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
||||
|
||||
instance RenderMessage UniWorX (WorkflowScope TermIdentifier SchoolShorthand (TermId, SchoolId, CourseShorthand)) where
|
||||
instance RenderMessage UniWorX (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) where
|
||||
renderMessage foundation ls = \case
|
||||
WSGlobal -> mr MsgWorkflowScopeGlobal
|
||||
WSTerm{..} -> mr $ ShortTermIdentifier wisTerm
|
||||
WSSchool{..} -> mr wisSchool
|
||||
WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool (TermKey wisTerm) (SchoolKey wisSchool)
|
||||
WSTerm{..} -> mr . ShortTermIdentifier $ unTermKey wisTerm
|
||||
WSSchool{..} -> mr $ unSchoolKey wisSchool
|
||||
WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool wisTerm wisSchool
|
||||
WSCourse{ wisCourse = (tid, ssh, csh) } -> mr $ MsgWorkflowScopeCourse tid ssh csh
|
||||
where
|
||||
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
|
||||
@ -35,6 +35,11 @@ import Control.Monad.Trans.State (execStateT)
|
||||
|
||||
import Yesod.Core.Types (HandlerContents)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
|
||||
-- Define breadcrumbs.
|
||||
i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
|
||||
@ -94,9 +99,29 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
||||
School{..} <- MaybeT . runDBRead $ get ssh
|
||||
return (CI.original schoolName, Just SchoolListR)
|
||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
||||
School{..} <- MaybeT . runDBRead $ get ssh
|
||||
isAdmin <- hasReadAccessTo SchoolListR
|
||||
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
|
||||
|
||||
SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
|
||||
SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
|
||||
SWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIInitiateR -> do
|
||||
mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
|
||||
| mayEdit -> SchoolWorkflowInstanceR win SWIEditR
|
||||
| otherwise -> SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of
|
||||
SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR
|
||||
SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR
|
||||
|
||||
breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing
|
||||
@ -346,7 +371,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR
|
||||
breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR
|
||||
|
||||
breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbWorkflowInstanceList Nothing
|
||||
breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing
|
||||
breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
||||
GWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
|
||||
@ -357,13 +382,16 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
|
||||
| mayEdit -> GlobalWorkflowInstanceR win GWIEditR
|
||||
| otherwise -> GlobalWorkflowInstanceListR
|
||||
breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbGlobalWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
|
||||
GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowInstanceListR
|
||||
GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR
|
||||
GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
|
||||
breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing
|
||||
breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR
|
||||
|
||||
|
||||
data NavQuickView
|
||||
= NavQuickViewFavourite
|
||||
@ -465,7 +493,11 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
|
||||
$memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
|
||||
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
|
||||
|
||||
defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => m [Nav]
|
||||
defaultLinks :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
) => m [Nav]
|
||||
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
|
||||
[ return NavHeader
|
||||
{ navHeaderRole = NavHeaderSecondary
|
||||
@ -647,18 +679,36 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, return NavHeader
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navIcon = IconMenuWorkflows
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuGlobalWorkflowInstanceList
|
||||
, navRoute = GlobalWorkflowInstanceListR
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, do
|
||||
(haveInstances, haveWorkflows) <- liftHandler . runDB $ (,)
|
||||
<$> haveTopWorkflowInstances
|
||||
<*> haveTopWorkflowWorkflows
|
||||
|
||||
if | haveInstances -> return NavHeader
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navIcon = IconMenuWorkflows
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowInstanceList
|
||||
, navRoute = TopWorkflowInstanceListR
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
| haveWorkflows -> return NavHeader
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navIcon = IconMenuWorkflows
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowWorkflowListHeader
|
||||
, navRoute = TopWorkflowWorkflowListR
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
| otherwise -> mzero
|
||||
, return NavHeaderContainer
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navLabel = SomeMessage MsgAdminHeading
|
||||
@ -791,6 +841,7 @@ pageActions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> Route UniWorX -> m [Nav]
|
||||
pageActions NewsR = return
|
||||
@ -2395,12 +2446,12 @@ pageActions AdminWorkflowInstanceListR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions GlobalWorkflowInstanceListR = return
|
||||
pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuGlobalWorkflowWorkflowList
|
||||
, navRoute = GlobalWorkflowWorkflowListR
|
||||
, navAccess' = return True
|
||||
{ navLabel = MsgMenuWorkflowWorkflowList
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
|
||||
, navAccess' = runDB $ haveWorkflowWorkflows rScope
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
@ -2408,11 +2459,11 @@ pageActions GlobalWorkflowInstanceListR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions (GlobalWorkflowInstanceR win GWIEditR) = return
|
||||
pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceDelete
|
||||
, navRoute = GlobalWorkflowInstanceR win GWIDeleteR
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR)
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
@ -2422,7 +2473,7 @@ pageActions (GlobalWorkflowInstanceR win GWIEditR) = return
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceWorkflows
|
||||
, navRoute = GlobalWorkflowInstanceR win GWIWorkflowsR
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
@ -2433,7 +2484,7 @@ pageActions (GlobalWorkflowInstanceR win GWIEditR) = return
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceInitiate
|
||||
, navRoute = GlobalWorkflowInstanceR win GWIInitiateR
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
@ -2442,11 +2493,11 @@ pageActions (GlobalWorkflowInstanceR win GWIEditR) = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions (GlobalWorkflowWorkflowR cID GWWWorkflowR) = return
|
||||
pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowWorkflowEdit
|
||||
, navRoute = GlobalWorkflowWorkflowR cID GWWEditR
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR)
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
@ -2456,7 +2507,7 @@ pageActions (GlobalWorkflowWorkflowR cID GWWWorkflowR) = return
|
||||
, NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowWorkflowDelete
|
||||
, navRoute = GlobalWorkflowWorkflowR cID GWWDeleteR
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR)
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
@ -2464,6 +2515,19 @@ pageActions (GlobalWorkflowWorkflowR cID GWWWorkflowR) = return
|
||||
}
|
||||
}
|
||||
]
|
||||
pageActions TopWorkflowInstanceListR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowWorkflowList
|
||||
, navRoute = TopWorkflowWorkflowListR
|
||||
, navAccess' = runDB haveTopWorkflowWorkflows
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions _ = return []
|
||||
|
||||
submissionList :: ( MonadIO m
|
||||
@ -2487,6 +2551,7 @@ pageQuickActions :: ( MonadCatch m
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> NavQuickView -> Route UniWorX -> m [NavLink]
|
||||
pageQuickActions qView route = do
|
||||
@ -2499,3 +2564,55 @@ evalAccessCorrector
|
||||
:: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
|
||||
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult
|
||||
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
|
||||
|
||||
|
||||
_haveWorkflowInstances, haveWorkflowWorkflows
|
||||
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
|
||||
-> ReaderT backend m Bool
|
||||
_haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let checkAccess (Entity _ WorkflowInstance{..})
|
||||
= hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
getInstances = E.selectSource . E.from $ \workflowInstance -> do
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return workflowInstance
|
||||
|
||||
$cachedHereBinary scope . runConduit $ transPipe lift getInstances .| C.mapM checkAccess .| C.or
|
||||
haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let checkAccess (E.Value wwId) = do
|
||||
cID <- lift . lift $ encrypt wwId
|
||||
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
|
||||
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return $ workflowWorkflow E.^. WorkflowWorkflowId
|
||||
|
||||
$cachedHereBinary scope . runConduit $ transPipe lift getWorkflows .| C.mapM checkAccess .| C.or
|
||||
|
||||
haveTopWorkflowInstances, haveTopWorkflowWorkflows
|
||||
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> ReaderT backend m Bool
|
||||
haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
|
||||
let checkAccess (Entity _ WorkflowInstance{..}) = do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
getInstances = selectSource [] []
|
||||
isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope
|
||||
in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or
|
||||
haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
|
||||
let checkAccess (Entity wwId WorkflowWorkflow{..}) = do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- lift . lift $ encrypt wwId
|
||||
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
getWorkflows = selectSource [] []
|
||||
isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope
|
||||
in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or
|
||||
|
||||
@ -41,6 +41,8 @@ deriving instance Generic CourseEventR
|
||||
deriving instance Generic AdminWorkflowDefinitionR
|
||||
deriving instance Generic GlobalWorkflowInstanceR
|
||||
deriving instance Generic GlobalWorkflowWorkflowR
|
||||
deriving instance Generic SchoolWorkflowInstanceR
|
||||
deriving instance Generic SchoolWorkflowWorkflowR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
instance Ord (Route Auth) where
|
||||
@ -64,6 +66,8 @@ deriving instance Ord CourseEventR
|
||||
deriving instance Ord AdminWorkflowDefinitionR
|
||||
deriving instance Ord GlobalWorkflowInstanceR
|
||||
deriving instance Ord GlobalWorkflowWorkflowR
|
||||
deriving instance Ord SchoolWorkflowInstanceR
|
||||
deriving instance Ord SchoolWorkflowWorkflowR
|
||||
deriving instance Ord (Route UniWorX)
|
||||
|
||||
data RouteChildren
|
||||
|
||||
@ -53,15 +53,16 @@ data MemcachedLimitKeyFavourites
|
||||
deriving anyclass (Hashable, Binary)
|
||||
|
||||
|
||||
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg = siteLayout . i18n
|
||||
|
||||
{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
|
||||
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg' = siteLayoutMsg
|
||||
|
||||
siteLayout :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> WidgetFor UniWorX () -- ^ `pageHeading`
|
||||
@ -70,6 +71,7 @@ siteLayout = siteLayout' . Just
|
||||
|
||||
siteLayout' :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
|
||||
|
||||
@ -21,6 +21,7 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
||||
, BearerAuthSite UniWorX
|
||||
, Button UniWorX ButtonSubmit
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
||||
errorHandler err = do
|
||||
|
||||
@ -610,8 +610,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
pad res
|
||||
| ExamRoomMatriculation <- rule
|
||||
, Just minAlpha <- Set.lookupMin rangeAlphabet
|
||||
= let maxLength = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
|
||||
padSuff cs = replicate (maxLength - length cs) minAlpha ++ cs
|
||||
= let maxLength' = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
|
||||
padSuff cs = replicate (maxLength' - length cs) minAlpha ++ cs
|
||||
in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
|
||||
| otherwise
|
||||
= res
|
||||
|
||||
@ -44,6 +44,20 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
|
||||
WWFilesR wpl stCID -> GWWFilesR wpl stCID
|
||||
WWEditR -> GWWEditR
|
||||
WWDeleteR -> GWWDeleteR
|
||||
WSSchool ssh -> SchoolR ssh . \case
|
||||
WorkflowInstanceListR -> SchoolWorkflowInstanceListR
|
||||
WorkflowInstanceNewR -> SchoolWorkflowInstanceNewR
|
||||
WorkflowInstanceR win subRoute -> SchoolWorkflowInstanceR win $ case subRoute of
|
||||
WIEditR -> SWIEditR
|
||||
WIDeleteR -> SWIDeleteR
|
||||
WIWorkflowsR -> SWIWorkflowsR
|
||||
WIInitiateR -> SWIInitiateR
|
||||
WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR
|
||||
WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of
|
||||
WWWorkflowR -> SWWWorkflowR
|
||||
WWFilesR wpl stCID -> SWWFilesR wpl stCID
|
||||
WWEditR -> SWWEditR
|
||||
WWDeleteR -> SWWDeleteR
|
||||
other -> error $ "not implemented _WorkflowScopeRoute for: " <> show other
|
||||
toWorkflowScopeRoute = \case
|
||||
GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR )
|
||||
@ -59,4 +73,19 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
|
||||
GWWFilesR wpl stCID -> WWFilesR wpl stCID
|
||||
GWWEditR -> WWEditR
|
||||
GWWDeleteR -> WWDeleteR
|
||||
SchoolR ssh sRoute -> case sRoute of
|
||||
SchoolWorkflowInstanceListR -> Just ( WSSchool ssh, WorkflowInstanceListR )
|
||||
SchoolWorkflowInstanceNewR -> Just ( WSSchool ssh, WorkflowInstanceNewR )
|
||||
SchoolWorkflowInstanceR win subRoute -> Just . (WSSchool ssh, ) . WorkflowInstanceR win $ case subRoute of
|
||||
SWIEditR -> WIEditR
|
||||
SWIDeleteR -> WIDeleteR
|
||||
SWIWorkflowsR -> WIWorkflowsR
|
||||
SWIInitiateR -> WIInitiateR
|
||||
SchoolWorkflowWorkflowListR -> Just ( WSSchool ssh, WorkflowWorkflowListR )
|
||||
SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of
|
||||
SWWWorkflowR -> WWWorkflowR
|
||||
SWWFilesR wpl stCID -> WWFilesR wpl stCID
|
||||
SWWEditR -> WWEditR
|
||||
SWWDeleteR -> WWDeleteR
|
||||
_other -> Nothing
|
||||
_other -> Nothing
|
||||
|
||||
@ -1,15 +1,23 @@
|
||||
module Handler.Workflow.Instance.Delete
|
||||
( getGWIDeleteR, postGWIDeleteR
|
||||
, getSWIDeleteR, postSWIDeleteR
|
||||
, workflowInstanceDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWIDeleteR, postGWIDeleteR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIDeleteR = postGWIDeleteR
|
||||
postGWIDeleteR win
|
||||
= workflowInstanceDeleteR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
|
||||
|
||||
getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIDeleteR = postSWIDeleteR
|
||||
postSWIDeleteR ssh win
|
||||
= workflowInstanceDeleteR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
|
||||
|
||||
workflowInstanceDeleteR :: WorkflowInstanceId -> Handler Html
|
||||
workflowInstanceDeleteR = error "not implemented"
|
||||
|
||||
@ -1,15 +1,23 @@
|
||||
module Handler.Workflow.Instance.Edit
|
||||
( getGWIEditR, postGWIEditR
|
||||
, getSWIEditR, postSWIEditR
|
||||
, workflowInstanceEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWIEditR, postGWIEditR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIEditR = postGWIEditR
|
||||
postGWIEditR win
|
||||
= workflowInstanceEditR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
|
||||
|
||||
getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIEditR = postSWIEditR
|
||||
postSWIEditR ssh win
|
||||
= workflowInstanceEditR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
|
||||
|
||||
workflowInstanceEditR :: WorkflowInstanceId -> Handler Html
|
||||
workflowInstanceEditR = error "not implemented"
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Workflow.Instance.Initiate
|
||||
( getGWIInitiateR, postGWIInitiateR
|
||||
, getSWIInitiateR, postSWIInitiateR
|
||||
, workflowInstanceInitiateR
|
||||
) where
|
||||
|
||||
@ -22,6 +23,11 @@ getGWIInitiateR = postGWIInitiateR
|
||||
postGWIInitiateR win
|
||||
= workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
|
||||
|
||||
getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIInitiateR = postSWIInitiateR
|
||||
postSWIInitiateR ssh win
|
||||
= workflowInstanceInitiateR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
|
||||
|
||||
workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html
|
||||
workflowInstanceInitiateR wiId = do
|
||||
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), rScope, mDesc) <- runDB $ do
|
||||
@ -66,6 +72,7 @@ workflowInstanceInitiateR wiId = do
|
||||
|
||||
(heading, title) <- case rScope of
|
||||
WSGlobal -> return (MsgGlobalWorkflowInstanceInitiateHeading $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgGlobalWorkflowInstanceInitiateTitle)
|
||||
WSSchool ssh -> return (MsgSchoolWorkflowInstanceInitiateHeading ssh $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgSchoolWorkflowInstanceInitiateTitle ssh)
|
||||
_other -> error "not implemented"
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
|
||||
@ -3,7 +3,9 @@
|
||||
module Handler.Workflow.Instance.List
|
||||
( getAdminWorkflowInstanceListR
|
||||
, getGlobalWorkflowInstanceListR
|
||||
, getSchoolWorkflowInstanceListR
|
||||
, workflowInstanceListR
|
||||
, getTopWorkflowInstanceListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -19,6 +21,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance)
|
||||
|
||||
@ -51,11 +55,11 @@ getAdminWorkflowInstanceListR :: Handler Html
|
||||
getAdminWorkflowInstanceListR = do
|
||||
instancesTable <- runDB $ do
|
||||
scopeOptions <- do
|
||||
scopes <- fmap (map E.unValue) . E.select . E.from $ \workflowInstance ->
|
||||
scopes <- fmap (map $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
|
||||
return $ workflowInstance E.^. WorkflowInstanceScope
|
||||
fmap mkOptionList . for scopes $ \scope -> do
|
||||
eScope <- traverseOf _wisCourse (encrypt . (review _SqlKey :: SqlBackendKey -> CourseId)) scope :: DB (WorkflowScope TermIdentifier SchoolShorthand CryptoUUIDCourse)
|
||||
wScope <- forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
|
||||
eScope <- traverseOf _wisCourse encrypt scope :: DB (WorkflowScope TermId SchoolId CryptoUUIDCourse)
|
||||
wScope <- maybeT notFound $ toRouteWorkflowScope scope
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return Option
|
||||
{ optionDisplay = mr wScope
|
||||
@ -83,8 +87,8 @@ getAdminWorkflowInstanceListR = do
|
||||
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18nCell
|
||||
, sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope) $ \scope ->
|
||||
sqlCell . fmap i18n . forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
|
||||
, sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope . re _DBWorkflowScope) $
|
||||
sqlCell . maybeT (return mempty) . fmap i18n . toRouteWorkflowScope
|
||||
, sortable (Just "title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty i18nCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionTitle)
|
||||
, sortable (Just "workflows") (i18nCell MsgWorkflowInstanceWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
|
||||
, sortable (Just "description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionDescription . _Just)
|
||||
@ -124,6 +128,10 @@ getAdminWorkflowInstanceListR = do
|
||||
|
||||
getGlobalWorkflowInstanceListR :: Handler Html
|
||||
getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
|
||||
|
||||
getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
|
||||
|
||||
|
||||
workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html
|
||||
workflowInstanceListR rScope = do
|
||||
@ -154,6 +162,7 @@ workflowInstanceListR rScope = do
|
||||
|
||||
(heading, title) <- case rScope of
|
||||
WSGlobal -> return (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
|
||||
WSSchool ssh -> return (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
|
||||
_other -> error "not implemented"
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
@ -163,3 +172,46 @@ workflowInstanceListR rScope = do
|
||||
toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
||||
toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
|
||||
getTopWorkflowInstanceListR :: Handler Html
|
||||
getTopWorkflowInstanceListR = do
|
||||
gInstances <- runDB $ do
|
||||
wis <- selectList [] []
|
||||
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
|
||||
guard $ isTopWorkflowScope workflowInstanceScope
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
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' rScope workflowInstanceName
|
||||
mayEdit <- hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
|
||||
mayList <- hasReadAccessTo $ toListRoute' rScope workflowInstanceName
|
||||
guard $ mayInitiate || mayEdit || mayList
|
||||
return (rScope, [(wi, desc)])
|
||||
|
||||
let iSortProj (Entity _ WorkflowInstance{..}, mDesc)
|
||||
= ( NTop workflowInstanceCategory
|
||||
, workflowInstanceDescriptionTitle <$> mDesc
|
||||
, workflowInstanceName
|
||||
)
|
||||
return $ sortOn iSortProj <$> Map.fromListWith (<>) wis'
|
||||
|
||||
siteLayoutMsg MsgTopWorkflowInstancesHeading $ do
|
||||
setTitleI MsgTopWorkflowInstancesTitle
|
||||
let instanceList rScope instances = $(widgetFile "workflows/instances")
|
||||
where
|
||||
toInitiateRoute = toInitiateRoute' rScope
|
||||
toEditRoute = toEditRoute' rScope
|
||||
toListRoute = toListRoute' rScope
|
||||
showHeadings = Map.keys gInstances /= [WSGlobal]
|
||||
$(widgetFile "workflows/top-instances")
|
||||
|
||||
where
|
||||
toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
||||
toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
|
||||
@ -2,6 +2,7 @@ module Handler.Workflow.Instance.New
|
||||
( getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR
|
||||
, adminWorkflowInstanceNewR
|
||||
, getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR
|
||||
, getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR
|
||||
, workflowInstanceNewR
|
||||
) where
|
||||
|
||||
@ -72,5 +73,9 @@ getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR :: Handler Html
|
||||
getGlobalWorkflowInstanceNewR = postGlobalWorkflowInstanceNewR
|
||||
postGlobalWorkflowInstanceNewR = workflowInstanceNewR WSGlobal
|
||||
|
||||
getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR
|
||||
postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool
|
||||
|
||||
workflowInstanceNewR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
|
||||
workflowInstanceNewR = error "not implemented"
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Workflow.Workflow.Delete
|
||||
( getGWWDeleteR, postGWWDeleteR
|
||||
, getSWWDeleteR, postSWWDeleteR
|
||||
, workflowDeleteR
|
||||
) where
|
||||
|
||||
@ -13,5 +14,10 @@ getGWWDeleteR = postGWWDeleteR
|
||||
postGWWDeleteR cID
|
||||
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
|
||||
|
||||
getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWDeleteR = postSWWDeleteR
|
||||
postSWWDeleteR ssh cID
|
||||
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
|
||||
|
||||
workflowDeleteR :: WorkflowWorkflowId -> Handler Html
|
||||
workflowDeleteR = error "not implemented"
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Workflow.Workflow.Edit
|
||||
( getGWWEditR, postGWWEditR
|
||||
, getSWWEditR, postSWWEditR
|
||||
, workflowEditR
|
||||
) where
|
||||
|
||||
@ -13,5 +14,10 @@ getGWWEditR = postGWWEditR
|
||||
postGWWEditR cID
|
||||
= workflowEditR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
|
||||
|
||||
getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWEditR = postSWWEditR
|
||||
postSWWEditR ssh cID
|
||||
= workflowEditR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
|
||||
|
||||
workflowEditR :: WorkflowWorkflowId -> Handler Html
|
||||
workflowEditR = error "not implemented"
|
||||
|
||||
@ -1,28 +1,117 @@
|
||||
module Handler.Workflow.Workflow.List
|
||||
( getGlobalWorkflowWorkflowListR
|
||||
, getSchoolWorkflowWorkflowListR
|
||||
, workflowWorkflowListR
|
||||
, getGWIWorkflowsR
|
||||
, getSWIWorkflowsR
|
||||
, workflowInstanceWorkflowsR
|
||||
, getAdminWorkflowWorkflowListR
|
||||
, getTopWorkflowWorkflowListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
|
||||
getGlobalWorkflowWorkflowListR :: Handler Html
|
||||
getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
|
||||
|
||||
getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
|
||||
|
||||
workflowWorkflowListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
|
||||
workflowWorkflowListR = error "not implemented"
|
||||
workflowWorkflowListR scope = do -- not implemented; TODO: FIXME
|
||||
wfRoutes <- runDB $ do
|
||||
rScope <- maybeT notFound $ toRouteWorkflowScope scope
|
||||
wfs <- selectKeysList [ WorkflowWorkflowScope ==. view _DBWorkflowScope scope ] []
|
||||
flip mapMaybeM wfs $ \wfId -> do
|
||||
cID <- encrypt wfId
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
guardM $ hasReadAccessTo route
|
||||
return (cID, route)
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (cID, route) <- wfRoutes
|
||||
<li>
|
||||
<a href=@{route}>
|
||||
#{toPathPiece cID}
|
||||
|]
|
||||
|
||||
|
||||
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIWorkflowsR win
|
||||
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
|
||||
|
||||
getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIWorkflowsR ssh win
|
||||
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
|
||||
|
||||
workflowInstanceWorkflowsR :: WorkflowInstanceId -> Handler Html
|
||||
workflowInstanceWorkflowsR = error "not implemented"
|
||||
workflowInstanceWorkflowsR wiId = do -- not implemented; TODO: FIXME
|
||||
wfRoutes <- runDB $ do
|
||||
wfs <- selectList [ WorkflowWorkflowInstance ==. Just wiId ] []
|
||||
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- encrypt wfId
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
guardM $ hasReadAccessTo route
|
||||
return (cID, route)
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (cID, route) <- wfRoutes
|
||||
<li>
|
||||
<a href=@{route}>
|
||||
#{toPathPiece cID}
|
||||
|]
|
||||
|
||||
|
||||
getAdminWorkflowWorkflowListR :: Handler Html
|
||||
getAdminWorkflowWorkflowListR = error "not implemented"
|
||||
getAdminWorkflowWorkflowListR = do -- not implemented; TODO: FIXME
|
||||
wfRoutes <- runDB $ do
|
||||
wfs <- selectList [] []
|
||||
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- encrypt wfId
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
return (cID, route)
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (cID, route) <- wfRoutes
|
||||
<li>
|
||||
<a href=@{route}>
|
||||
#{toPathPiece cID}
|
||||
|]
|
||||
|
||||
|
||||
getTopWorkflowWorkflowListR :: Handler Html
|
||||
getTopWorkflowWorkflowListR = do -- not implemented; TODO: FIXME
|
||||
wfRoutes <- runDB $ do
|
||||
wfs <- selectList [] []
|
||||
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
|
||||
guard $ isTopWorkflowScope workflowWorkflowScope
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- encrypt wfId
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
guardM $ hasReadAccessTo route
|
||||
return (cID, route)
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (cID, route) <- wfRoutes
|
||||
<li>
|
||||
<a href=@{route}>
|
||||
#{toPathPiece cID}
|
||||
|]
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.Workflow.Workflow.Workflow
|
||||
( getGWWWorkflowR, postGWWWorkflowR
|
||||
, getGWWFilesR
|
||||
( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
|
||||
, getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
|
||||
, workflowR
|
||||
) where
|
||||
|
||||
@ -61,10 +61,21 @@ makePrisms ''WorkflowHistoryItemActor
|
||||
|
||||
getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWWorkflowR = postGWWWorkflowR
|
||||
postGWWWorkflowR cID = do
|
||||
wId <- runDB . maybeT notFound $ ensureScope WSGlobal cID
|
||||
postGWWWorkflowR cID = workflowR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
|
||||
|
||||
workflowR wId
|
||||
getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getGWWFilesR wwCID wpl stCID = do
|
||||
wId <- runDB . maybeT notFound $ ensureScope WSGlobal wwCID
|
||||
getWorkflowFilesR wId wpl stCID
|
||||
|
||||
getSWWWorkflowR, postSWWWorkflowR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWWorkflowR = postSWWWorkflowR
|
||||
postSWWWorkflowR ssh cID = workflowR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
|
||||
|
||||
getSWWFilesR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getSWWFilesR ssh wwCID wpl stCID = do
|
||||
wId <- runDB . maybeT notFound $ ensureScope (WSSchool ssh) wwCID
|
||||
getWorkflowFilesR wId wpl stCID
|
||||
|
||||
workflowR :: WorkflowWorkflowId -> Handler Html
|
||||
workflowR wwId = do
|
||||
@ -215,6 +226,7 @@ workflowR wwId = do
|
||||
|
||||
(heading, title) <- case rScope of
|
||||
WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
|
||||
WSSchool ssh -> return (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
|
||||
_other -> error "not implemented"
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
@ -246,10 +258,9 @@ workflowR wwId = do
|
||||
$(widgetFile "workflows/workflow")
|
||||
|
||||
|
||||
getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getGWWFilesR wwCID wpl stCID = do
|
||||
getWorkflowFilesR :: WorkflowWorkflowId -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getWorkflowFilesR wwId wpl stCID = do
|
||||
fRefs <- runDB $ do
|
||||
wwId <- decrypt wwCID
|
||||
WorkflowWorkflow{..} <- get404 wwId
|
||||
stIx <- decrypt stCID
|
||||
payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
|
||||
@ -261,6 +272,7 @@ getGWWFilesR wwCID wpl stCID = do
|
||||
when (null payloads'') notFound
|
||||
return payloads''
|
||||
|
||||
wwCID <- encrypt wwId
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgWorkflowWorkflowFilesArchiveName wwCID wpl stCID
|
||||
|
||||
serveSomeFiles archiveName $ yieldMany fRefs
|
||||
|
||||
23
src/Utils.hs
23
src/Utils.hs
@ -889,6 +889,29 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
|
||||
= let (MkFixed micro :: Micro) = realToFrac timeoutLength
|
||||
in fromInteger micro
|
||||
|
||||
--------------
|
||||
-- Foldable --
|
||||
--------------
|
||||
|
||||
minLength :: ( Integral n
|
||||
, MonoFoldable mono
|
||||
)
|
||||
=> n -> mono -> Bool
|
||||
-- ^ @minLegth n xs = length xs >= n@
|
||||
minLength l = go l . otoList
|
||||
where
|
||||
go l' _ | l' <= 0 = True
|
||||
go l' xs = case xs of
|
||||
_ : xs' -> go (pred l') xs'
|
||||
[] -> False
|
||||
|
||||
maxLength :: ( Integral n
|
||||
, MonoFoldable mono
|
||||
)
|
||||
=> n -> mono -> Bool
|
||||
-- ^ @maxLegth n xs = length xs <= n@
|
||||
maxLength l = not . minLength (succ l)
|
||||
|
||||
------------
|
||||
-- Writer --
|
||||
------------
|
||||
|
||||
@ -6,6 +6,7 @@ module Utils.Workflow
|
||||
, _DBWorkflowGraph
|
||||
, _DBWorkflowState
|
||||
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
|
||||
, isTopWorkflowScope
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -84,3 +85,7 @@ decryptWorkflowStateIndex :: ( MonadCrypto m
|
||||
decryptWorkflowStateIndex wwId cID = do
|
||||
cIDKey <- workflowStateIndexCryptoIDKey wwId
|
||||
$cachedHereBinary (wwId, cID) . flip runReaderT cIDKey $ I.decrypt cID
|
||||
|
||||
|
||||
isTopWorkflowScope :: WorkflowScope termid schoolid courseid -> Bool
|
||||
isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScope
|
||||
|
||||
8
templates/workflows/top-instances.hamlet
Normal file
8
templates/workflows/top-instances.hamlet
Normal file
@ -0,0 +1,8 @@
|
||||
$newline never
|
||||
$forall (rScope, instances) <- Map.toList gInstances
|
||||
<section>
|
||||
$if showHeadings
|
||||
<h2>
|
||||
<a href=@{review _WorkflowScopeRoute (rScope, WorkflowInstanceListR)}>
|
||||
_{rScope}
|
||||
^{instanceList rScope instances}
|
||||
@ -1302,7 +1302,7 @@ fillDb = do
|
||||
thesesWorkflowDef = WorkflowDefinition{..}
|
||||
where workflowDefinitionInstanceCategory = Just "theses"
|
||||
workflowDefinitionName = "theses"
|
||||
workflowDefinitionScope = WSGlobal' -- TODO
|
||||
workflowDefinitionScope = WSSchool'
|
||||
wdId <- insert thesesWorkflowDef
|
||||
insert_ WorkflowDefinitionDescription
|
||||
{ workflowDefinitionDescriptionDefinition = wdId
|
||||
@ -1320,7 +1320,7 @@ fillDb = do
|
||||
thesesWorkflowInst = WorkflowInstance{..}
|
||||
where workflowInstanceDefinition = Just wdId
|
||||
workflowInstanceGraph = workflowDefinitionGraph
|
||||
workflowInstanceScope = WSGlobal -- TODO
|
||||
workflowInstanceScope = WSSchool $ unSchoolKey ifi
|
||||
workflowInstanceName = workflowDefinitionName thesesWorkflowDef
|
||||
workflowInstanceCategory = workflowDefinitionInstanceCategory thesesWorkflowDef
|
||||
wiId <- insert thesesWorkflowInst
|
||||
@ -1345,4 +1345,3 @@ fillDb = do
|
||||
-> return ()
|
||||
Nothing
|
||||
-> insert_ $ ChangelogItemFirstSeen changelogItem firstSeen
|
||||
|
||||
|
||||
@ -5,8 +5,12 @@ module Database.Persist.Sql.Types.TestInstances
|
||||
import TestImport
|
||||
|
||||
import Database.Persist.Sql
|
||||
import Data.Binary (Binary)
|
||||
|
||||
|
||||
deriving newtype instance Arbitrary (BackendKey SqlBackend)
|
||||
deriving newtype instance Arbitrary (BackendKey SqlWriteBackend)
|
||||
deriving newtype instance Arbitrary (BackendKey SqlReadBackend)
|
||||
deriving newtype instance Binary (BackendKey SqlBackend)
|
||||
deriving newtype instance Binary (BackendKey SqlWriteBackend)
|
||||
deriving newtype instance Binary (BackendKey SqlReadBackend)
|
||||
|
||||
@ -94,6 +94,14 @@ instance Arbitrary GlobalWorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SchoolWorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SchoolWorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Route UniWorX) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
30
test/Handler/Utils/Workflow/CanonicalRouteSpec.hs
Normal file
30
test/Handler/Utils/Workflow/CanonicalRouteSpec.hs
Normal file
@ -0,0 +1,30 @@
|
||||
module Handler.Utils.Workflow.CanonicalRouteSpec where
|
||||
|
||||
import TestImport
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
import ModelSpec ()
|
||||
import FoundationSpec ()
|
||||
|
||||
|
||||
instance Arbitrary WorkflowScopeRoute where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowScopeRoute
|
||||
instance Function WorkflowScopeRoute
|
||||
|
||||
instance Arbitrary WorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowInstanceR
|
||||
instance Function WorkflowInstanceR
|
||||
|
||||
instance Arbitrary WorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowWorkflowR
|
||||
instance Function WorkflowWorkflowR
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "_WorkflowSpecRoute" $
|
||||
before_ (pendingWith "Missing routes") . it "is a prism" . property $ isPrism _WorkflowScopeRoute
|
||||
@ -24,6 +24,8 @@ import Utils.I18n
|
||||
instance Arbitrary WorkflowPayloadLabel where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowPayloadLabel
|
||||
instance Function WorkflowPayloadLabel
|
||||
|
||||
instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadSpec fileid userid) where
|
||||
arbitrary = oneof
|
||||
@ -115,8 +117,14 @@ instance (Arbitrary fileid, Arbitrary userid, Ord fileid, Typeable userid, Typea
|
||||
instance (Arbitrary payload, IsWorkflowFieldPayload' fileid userid payload) => Arbitrary (WorkflowFieldPayload fileid userid payload) where
|
||||
arbitrary = review _WorkflowFieldPayload <$> arbitrary
|
||||
|
||||
instance (Arbitrary termid, Arbitrary schoolid, Arbitrary courseid) => Arbitrary (WorkflowScope termid schoolid courseid) where
|
||||
arbitrary = genericArbitrary
|
||||
instance (CoArbitrary termid, CoArbitrary schoolid, CoArbitrary courseid) => CoArbitrary (WorkflowScope termid schoolid courseid)
|
||||
instance (Function termid, Function schoolid, Function courseid) => Function (WorkflowScope termid schoolid courseid)
|
||||
|
||||
instance Arbitrary WorkflowScope' where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
|
||||
@ -44,26 +44,38 @@ import Text.Blaze.TestInstances ()
|
||||
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
|
||||
|
||||
instance Arbitrary Season where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary Season
|
||||
instance Function Season
|
||||
|
||||
instance Arbitrary TermIdentifier where
|
||||
arbitrary = do
|
||||
season <- arbitrary
|
||||
year <- arbitrary `suchThat` (\y -> abs y >= 100)
|
||||
return $ TermIdentifier{..}
|
||||
shrink = genericShrink
|
||||
shrink = filter ((\y -> abs y >= 100) . year) . genericShrink
|
||||
instance CoArbitrary TermIdentifier
|
||||
instance Function TermIdentifier
|
||||
|
||||
deriving instance Generic TermId
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
shrink = map TermKey . shrink . unTermKey
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary TermId
|
||||
instance Function TermId
|
||||
|
||||
deriving instance Generic SchoolId
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
shrink = map SchoolKey . shrink . unSchoolKey
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary SchoolId
|
||||
instance Function SchoolId
|
||||
|
||||
instance Arbitrary Pseudonym where
|
||||
arbitrary = Pseudonym <$> arbitraryBoundedIntegral
|
||||
@ -216,10 +228,6 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r
|
||||
arbitrary = toSqlKey <$> arbitrary
|
||||
shrink = map toSqlKey . shrink . fromSqlKey
|
||||
|
||||
instance Arbitrary Html where
|
||||
arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
|
||||
shrink = map preEscapedToHtml . shrink . renderHtml
|
||||
|
||||
instance Arbitrary StoredMarkup where
|
||||
arbitrary = (`suchThat` (not . null . LT.strip . renderHtml . markupOutput)) $ oneof
|
||||
[ htmlToStoredMarkup <$> arbitrary
|
||||
@ -320,6 +328,7 @@ instance Arbitrary RoomReference' where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $ do
|
||||
@ -421,6 +430,8 @@ spec = do
|
||||
[ persistFieldLaws, jsonLaws, eqLaws, ordLaws ]
|
||||
lawsCheckHspec (Proxy @RoomReference')
|
||||
[ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
|
||||
lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey))
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
@ -172,6 +172,8 @@ instance {-# OVERLAPS #-} (HasCryptoID ns ct pt (ReaderT CryptoIDKey Catch), Arb
|
||||
arbitrary = arbitrary <&> \pt -> (pt, either (error . show) id . runCatch $ runReaderT (Implicit.encrypt pt) tmpKey)
|
||||
where
|
||||
tmpKey = unsafePerformIO genKey
|
||||
instance CoArbitrary ct => CoArbitrary (CryptoID ns ct)
|
||||
instance Function ct => Function (CryptoID ns ct)
|
||||
|
||||
instance Arbitrary VerpMode where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
@ -37,6 +37,7 @@ import Test.QuickCheck.Classes.Universe as X
|
||||
import Test.QuickCheck.Classes.Binary as X
|
||||
import Test.QuickCheck.Classes.Csv as X
|
||||
import Test.QuickCheck.IO as X
|
||||
import Control.Lens.Properties as X
|
||||
import Data.Proxy as X
|
||||
import Data.UUID as X (UUID)
|
||||
import System.IO as X (hPrint, hPutStrLn)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user