diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 9fb87c738..e751e1d2e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 8814dabf3..63fcf266b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -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 diff --git a/package.yaml b/package.yaml index 6328dde4f..37f3c6ee7 100644 --- a/package.yaml +++ b/package.yaml @@ -321,6 +321,7 @@ tests: - yesod-persistent - quickcheck-io - network-arbitrary + - lens-properties ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/routes b/routes index e76b6eb4b..9058f6ae6 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 109b967a4..07f140c86 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 2ebf6e554..079a02fb8 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 60e384ad5..2e1c25092 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index f76730a78..59b6ac117 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 9f151bca7..6c39decf0 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -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` diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index f24a7ea85..a8ee44100 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -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 diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index e8e4590ff..5b8b48635 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -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 diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index f188416c5..6e5082fd7 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -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 diff --git a/src/Handler/Workflow/Instance/Delete.hs b/src/Handler/Workflow/Instance/Delete.hs index 154b32a3d..cff14a90a 100644 --- a/src/Handler/Workflow/Instance/Delete.hs +++ b/src/Handler/Workflow/Instance/Delete.hs @@ -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" diff --git a/src/Handler/Workflow/Instance/Edit.hs b/src/Handler/Workflow/Instance/Edit.hs index 189a16dc1..0626d81bb 100644 --- a/src/Handler/Workflow/Instance/Edit.hs +++ b/src/Handler/Workflow/Instance/Edit.hs @@ -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" diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index 88226eec1..4817ab9ff 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -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 diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index f134ff9ac..ecf191265 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -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) diff --git a/src/Handler/Workflow/Instance/New.hs b/src/Handler/Workflow/Instance/New.hs index 1104ae997..e3ce88b6f 100644 --- a/src/Handler/Workflow/Instance/New.hs +++ b/src/Handler/Workflow/Instance/New.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/Delete.hs b/src/Handler/Workflow/Workflow/Delete.hs index 09ae5370d..acb8e7282 100644 --- a/src/Handler/Workflow/Workflow/Delete.hs +++ b/src/Handler/Workflow/Workflow/Delete.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/Edit.hs b/src/Handler/Workflow/Workflow/Edit.hs index 10b1c3d5d..673c49511 100644 --- a/src/Handler/Workflow/Workflow/Edit.hs +++ b/src/Handler/Workflow/Workflow/Edit.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 5445c4013..6b1fde4a6 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -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 +