feat(workflows): wire up ws-school

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
+MenuGlobalWorkflowInstanceList: Systemweite Workflows
-MenuGlobalWorkflowWorkflowList: Laufende 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
+BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows
-BreadcrumbGlobalWorkflowWorkflowList: Laufende 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
 

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

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"

routes

@@ -69,20 +69,23 @@
 /admin/workflows/workflows    AdminWorkflowWorkflowListR GET
 /admin/workflows/workflows/new AdminWorkflowWorkflowNewR GET POST
 
-/workflow-instances           GlobalWorkflowInstanceListR GET !¬empty
+/global-workflows/instances           GlobalWorkflowInstanceListR GET !free
-/workflow-instances/new       GlobalWorkflowInstanceNewR GET POST
+/global-workflows/instances/new       GlobalWorkflowInstanceNewR GET POST
-/workflow-instances/#WorkflowInstanceName GlobalWorkflowInstanceR:
+/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
+/global-workflows             GlobalWorkflowWorkflowListR GET  !free
-/workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
+!/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

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
+tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
-  let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do
+  -> let workflowInstanceWorkflowsEmpty rScope win = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
-        scope <- fromRouteWorkflowScope rScope
+           scope <- fromRouteWorkflowScope rScope
-        
+           let dbScope = scope ^. _DBWorkflowScope
-        let checkAccess (Entity _ WorkflowInstance{..})
+               getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
-              = fmap (is _Authorized) . flip (evalAccessFor mAuthId) True $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
+                 E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
-            getInstances = E.selectSource . E.from $ \workflowInstance -> do
+                 E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
-              E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
+                      E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope
-              return workflowInstance
+                 return ( workflowWorkflow E.^. WorkflowWorkflowId
-
+                        , workflowWorkflow E.^. WorkflowWorkflowScope
-        guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getInstances .| C.mapM checkAccess .| C.or
+                        )
-        return Authorized
+               checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do
-
+                 cID <- encrypt wwId
-      wWorkflows rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
+                 rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope
-        scope <- fromRouteWorkflowScope rScope
+                 guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
-  
+                 return True
-        let checkAccess (E.Value wwId) = do
+           guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
-              cID <- encrypt wwId
+           return Authorized
-              fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+      in case route of
-            getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
+           r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute
-              E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
+               -> workflowInstanceWorkflowsEmpty rScope win
-              return $ workflowWorkflow E.^. WorkflowWorkflowId
+           EExamListR -> exceptT return return $ do
-
+             authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-        guardM . lift . fmap not . $cachedHereBinary scope . runConduit $ getWorkflows .| C.mapM checkAccess .| C.or
+             hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
-        return Authorized
+               E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
-
+               E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
-  case route of
+                 E.||. E.exists (E.from $ \externalExamResult ->
-    _ | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute -> wInstances rScope
+                     E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
-    _ | Just (rScope, WorkflowWorkflowListR) <- route ^? _WorkflowScopeRoute -> wWorkflows rScope
+                          E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
-    EExamListR -> exceptT return return $ do
+                   )
-      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+             guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
-      hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
+             return Authorized
-        E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
+           CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-        E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
+             -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-          E.||. E.exists (E.from $ \externalExamResult ->
+             cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-              E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
+             assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
-                   E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
+             assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
-            )
+               E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
-      guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
+               E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-      return Authorized
+             return Authorized
-    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
+           r -> $unsupportedAuthPredicate AuthEmpty r
-      -- 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

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
+    WSTerm{..} -> mr . ShortTermIdentifier $ unTermKey wisTerm
-    WSSchool{..} -> mr   wisSchool
+    WSSchool{..} -> mr $ unSchoolKey wisSchool
-    WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool (TermKey wisTerm) (SchoolKey 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

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
+  breadcrumb (SchoolR ssh sRoute) = case sRoute of
-    School{..} <- MaybeT . runDBRead $ get ssh
+    SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
-    return (CI.original schoolName, Just SchoolListR)
+      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
+  , do
-      { navHeaderRole = NavHeaderPrimary
+      (haveInstances, haveWorkflows) <- liftHandler . runDB $ (,)
-      , navIcon       = IconMenuWorkflows
+        <$> haveTopWorkflowInstances
-      , navLink       = NavLink
+        <*> haveTopWorkflowWorkflows
-        { navLabel       = MsgMenuGlobalWorkflowInstanceList
+
-        , navRoute       = GlobalWorkflowInstanceListR
+      if | haveInstances -> return NavHeader
-        , navAccess'     = return True
+             { navHeaderRole = NavHeaderPrimary
-        , navType        = NavTypeLink { navModal = False }
+             , navIcon       = IconMenuWorkflows
-        , navQuick'      = mempty
+             , navLink       = NavLink
-        , navForceActive = False
+               { 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
+      { navLabel       = MsgMenuWorkflowWorkflowList
-      , navRoute       = GlobalWorkflowWorkflowListR
+      , navRoute       = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
-      , navAccess'     = return True
+      , 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

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

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`

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

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
+          = let maxLength' = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
-                padSuff cs = replicate (maxLength - length cs) minAlpha ++ cs
+                padSuff cs = replicate (maxLength' - length cs) minAlpha ++ cs
              in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
           | otherwise
           = res

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

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"

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"

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

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)
+        eScope <- traverseOf _wisCourse encrypt scope :: DB (WorkflowScope TermId SchoolId CryptoUUIDCourse)
-        wScope <- forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
+        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 ->
+              , sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope . re _DBWorkflowScope) $
-                  sqlCell . fmap i18n . forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
+                  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)

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"

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"

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"

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
+      <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}
+    |]

src/Handler/Workflow/Workflow/Workflow.hs

@@ -1,6 +1,6 @@
 module Handler.Workflow.Workflow.Workflow
-  ( getGWWWorkflowR, postGWWWorkflowR
+  ( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
-  , getGWWFilesR
+  , getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
   , workflowR
   ) where
 
@@ -61,10 +61,21 @@ makePrisms ''WorkflowHistoryItemActor
 
 getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
 getGWWWorkflowR = postGWWWorkflowR
-postGWWWorkflowR cID = do
+postGWWWorkflowR cID = workflowR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
-  wId <- 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
+getWorkflowFilesR :: WorkflowWorkflowId -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
-getGWWFilesR wwCID wpl stCID = do
+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

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

src/Utils/Workflow.hs

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

templates/workflows/top-instances.hamlet

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

test/Database/Fill.hs

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

test/Database/Persist/Sql/Types/TestInstances.hs

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

test/FoundationSpec.hs

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

test/Handler/Utils/Workflow/CanonicalRouteSpec.hs

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

test/Model/Types/WorkflowSpec.hs

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

test/Model/TypesSpec.hs

@@ -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
+  arbitrary = genericArbitrary
-  shrink = map TermKey . shrink . unTermKey
+  shrink = genericShrink
+instance CoArbitrary TermId
+instance Function TermId
 
+deriving instance Generic SchoolId
 instance Arbitrary SchoolId where
-  arbitrary = SchoolKey <$> arbitrary
+  arbitrary = genericArbitrary
-  shrink = map SchoolKey . shrink . unSchoolKey
+  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 $

test/ModelSpec.hs

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

test/TestImport.hs

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