diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index f3476fae4..2dbf35ae6 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -8,10 +8,10 @@ module Foundation.Authorization , wouldHaveReadAccessTo, wouldHaveWriteAccessTo , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff , AuthContext(..), getAuthContext - , isDryRun + , isDryRun, isDryRunDB , maybeBearerToken, requireBearerToken , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions - , BearerAuthSite + , BearerAuthSite, MonadAP , routeAuthTags , orAR, andAR, notAR, trueAR, falseAR , evalWorkflowRoleFor, evalWorkflowRoleFor' @@ -60,6 +60,9 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Binary as Binary +import GHC.TypeLits (TypeError) +import qualified GHC.TypeLits as TypeError (ErrorMessage(..)) + type BearerAuthSite site = ( MonadCrypto (HandlerFor site) @@ -101,8 +104,17 @@ data AccessPredicate class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult -instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where - evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of +type family DisabledMonadAPInstance t err :: Constraint where + DisabledMonadAPInstance t err + = TypeError ( 'TypeError.Text "Used dangerous MonadAP instance for: " 'TypeError.:<>: 'TypeError.ShowType t + 'TypeError.:$$: 'TypeError.Text "This instance is currently disabled via TypeError because: " 'TypeError.:<>: err + 'TypeError.:$$: 'TypeError.Text "Please consider removing the usage triggering this error message before re-enabling or removing the instance." + ) + +instance ( BearerAuthSite UniWorX + -- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections") + ) => MonadAP (HandlerFor UniWorX) where + evalAccessPred aPred contCtx cont aid r w = case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w (APDB p) -> runDBRead' callStack $ p contCtx cont aid r w @@ -113,6 +125,9 @@ instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuth Left p' -> evalAccessPred p' contCtx cont aid r w (APBindDB p) -> evalAccessPred (APBind $ \aid' r' w' -> runDBRead' callStack $ p aid' r' w') contCtx cont aid r w +instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where + evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w + instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer @@ -238,23 +253,32 @@ getAuthContext = liftHandler $ do return authCtx -isDryRun :: forall m. - ( HasCallStack - , MonadHandler m, HandlerSite m ~ UniWorX +newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +isDryRun :: ( HasCallStack , BearerAuthSite UniWorX ) - => m Bool -isDryRun = $cachedHere . liftHandler $ orM + => HandlerFor UniWorX Bool +isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB + +isDryRunDB :: forall m. + ( HasCallStack + , MonadAP m, MonadCatch m + , BearerAuthSite UniWorX + ) + => m Bool +isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM [ hasGlobalPostParam PostDryRun , hasGlobalGetParam GetDryRun , and2M bearerDryRun bearerRequired ] where bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value - bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do - mAuthId <- defaultMaybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute + bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do + mAuthId <- liftHandler defaultMaybeAuthId + currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute + isWrite <- liftHandler $ isWriteRequest currentRoute let noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar @@ -1894,7 +1918,7 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro evalWorkflowRoleFor' :: forall m backend. ( HasCallStack - , MonadAP m + , MonadAP (ReaderT backend m), MonadIO m , BackendCompatible SqlReadBackend backend ) => (forall m'. MonadAP m' => AuthTagsEval m') @@ -1941,7 +1965,7 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite evalWorkflowRoleFor :: ( HasCallStack - , MonadAP m + , MonadAP (ReaderT backend m), MonadIO m , BackendCompatible SqlReadBackend backend ) => Maybe UserId @@ -1964,8 +1988,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do return result hasWorkflowRole :: ( HasCallStack - , MonadAP m + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend + , MonadHandler m, HandlerSite m ~ UniWorX ) => Maybe WorkflowWorkflowId -> WorkflowRole UserId @@ -1978,10 +2003,12 @@ hasWorkflowRole mwwId wRole route isWrite = do mayViewWorkflowAction' :: forall backend m fileid. ( HasCallStack - , MonadAP m + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCatch m + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadUnliftIO m ) => (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe UserId @@ -1991,7 +2018,7 @@ mayViewWorkflowAction' :: forall backend m fileid. mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do WorkflowWorkflow{..} <- MaybeT . lift $ get wwId rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope - cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId + cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False @@ -2007,10 +2034,12 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT mayViewWorkflowAction :: forall backend m fileid. ( HasCallStack - , MonadAP m + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCatch m + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadUnliftIO m ) => Maybe UserId -> WorkflowWorkflowId diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 6070c9a44..5a997f8e4 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -107,7 +107,7 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized = evalAccess + isAuthorized r w = runDBRead $ evalAccess r w addStaticContent = UniWorX.addStaticContent diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 506bbf8c5..1c0cf98cc 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -15,6 +15,7 @@ module Foundation.Navigation , navAccess , navQuick , evalAccessCorrector + , breadcrumb ) where import Import.NoFoundation hiding (runDB) @@ -48,11 +49,14 @@ import qualified Data.Set as Set import Data.List (inits) +type Breadcrumb = (Text, Maybe (Route UniWorX)) + -- Define breadcrumbs. -i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m) +i18nCrumb :: forall msg m. + (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX) => msg - -> Maybe (Route (HandlerSite m)) - -> m (Text, Maybe (Route (HandlerSite m))) + -> Maybe (Route UniWorX) + -> m Breadcrumb i18nCrumb msg mbR = do mr <- getMessageRender return (mr msg, mbR) @@ -65,359 +69,361 @@ i18nCrumb msg mbR = do -- Keep in mind that Breadcrumbs are also shown by the 403-Handler, -- i.e. information might be leaked by not performing permission checks if the -- breadcrumb value depends on sensitive content (like an user's name). -instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where - breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR - breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing - breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing - breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing - breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing +breadcrumb :: BearerAuthSite UniWorX + => Route UniWorX + -> ReaderT SqlReadBackend (HandlerFor UniWorX) Breadcrumb +breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR +breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing +breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing +breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing +breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing - breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing - breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR - breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR - breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do - guardM . lift . hasReadAccessTo $ AdminUserR cID - uid <- decrypt cID - User{..} <- MaybeT . runDBRead $ get uid - return (userDisplayName, Just UsersR) - breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID - breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID - breadcrumb (UserNotificationR cID) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR - breadcrumb (UserPasswordR cID) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgMenuUserPassword $ Just ProfileR - breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR - breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing +breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing +breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR +breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR +breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do + guardM . lift . hasReadAccessTo $ AdminUserR cID + uid <- decrypt cID + User{..} <- MaybeT $ get uid + return (userDisplayName, Just UsersR) +breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID +breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID +breadcrumb (UserNotificationR cID) = do + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR +breadcrumb (UserPasswordR cID) = do + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserPassword $ Just ProfileR +breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR +breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing - breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing - breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR - breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR - breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR - breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR - breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR +breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing +breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR +breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR +breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR +breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR +breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR - breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR - breadcrumb (SchoolR ssh sRoute) = case sRoute of - SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do - School{..} <- MaybeT . runDBRead $ get ssh - isAdmin <- lift $ hasReadAccessTo SchoolListR - return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) +breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR +breadcrumb (SchoolR ssh sRoute) = case sRoute of + SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do + School{..} <- MaybeT $ get ssh + isAdmin <- lift $ 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 -> do - mayList <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR - desc <- runDBRead . runMaybeT $ do - guard mayList - wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh - MaybeT $ selectWorkflowInstanceDescription wiId - let bRoute = SchoolR ssh SchoolWorkflowInstanceListR - case desc of - Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute - Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute - 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 - breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing - - breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing - breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR - breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR - breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR - breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR - breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR - - - breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing - - - breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing - breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing - - breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing - breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR - breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR - breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR - breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR - breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR - - breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing - - breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR - breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR - breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR - breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid - breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDBRead $ isJust <$> get tid - i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR - - breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDBRead $ - (&&) <$> fmap isJust (get ssh) - <*> fmap isJust (get tid) - return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) - - breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR - breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of - AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do - mr <- getMessageRender - Entity _ Allocation{allocationName} <- MaybeT . runDBRead . getBy $ TermSchoolAllocationShort tid ssh ash - return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) - ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR - AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do - cid <- decrypt cID - Course{..} <- hoist runDBRead $ do - aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash - guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] - MaybeT $ get cid - return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) - AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR - APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR - AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR - AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR - AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR - - breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR - breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR - breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR - - breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing - breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR - breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do - guardM . lift . runDBRead . existsBy $ TermSchoolCourseShort tid ssh csh - return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) - breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR - breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do - guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID - uid <- decrypt cID - User{userDisplayName} <- MaybeT . runDBRead $ get uid - return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) - breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR - breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR - breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of - CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR - CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR - CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR - CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR - CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR - - breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of - CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR - CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR - - breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR - - breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of - CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do - guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR - appId <- decrypt cID - User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser - return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) - CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR - - breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of - EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do - guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR - return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) - EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR - EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR - EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR - EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR - ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR - EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR - ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR - ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR - - breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of - TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do - guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR - return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR - TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR - TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR - TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR - TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR - - breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of - SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do - guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR - return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) - SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR - SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR - SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR - SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR - SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR - SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR - SubmissionR cid sRoute' -> case sRoute' of - SubShowR -> do - mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR - if - | mayList - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR - | otherwise - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR - CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR - SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR - SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR - SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR - SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR - SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR - SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR - - breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR - breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of - MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do - guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) - MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR - MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR - MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR - MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR - MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR - - breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR - - breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing - breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR - breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR - breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR - breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR - - breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing - - breadcrumb (MessageR _) = do - mayList <- (== Authorized) <$> evalAccess MessageListR False - if - | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR - | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR - breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR - breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID - - breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR - - breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing - breadcrumb EExamNewR = do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of - EEShowR -> do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do - guardM . lift . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR - i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR - EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR - EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR - EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR - EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR - - breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR - breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR - breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of - AWDEditR -> do - MsgRenderer mr <- getMsgRenderer - i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR - AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR - AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR - breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR - breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR - breadcrumb (AdminWorkflowInstanceR _cID sRoute) = case sRoute of - AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR - breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR - breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR - - breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing - breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR - breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of - GWIEditR -> do - mayList <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR - desc <- runDBRead . runMaybeT $ do - guard mayList - wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal + SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR + SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR + SchoolWorkflowInstanceR win sRoute' -> case sRoute' of + SWIEditR -> do + desc <- runMaybeT $ do + guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR + wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh MaybeT $ selectWorkflowInstanceDescription wiId + let bRoute = SchoolR ssh SchoolWorkflowInstanceListR case desc of - Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR - Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR - GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR - GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR - GWIInitiateR -> do - mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR - i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if - | mayEdit -> GlobalWorkflowInstanceR win GWIEditR - | otherwise -> GlobalWorkflowInstanceListR - breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR - breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of - 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 + Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute + Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute + 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 TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing - breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR +breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing +breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR +breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR +breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing + +breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing +breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR +breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR +breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR +breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR +breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR + + +breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing + + +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing + +breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing +breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR +breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR +breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR +breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR +breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR + +breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing + +breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR +breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR +breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR +breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid +breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs + guardM . lift $ isJust <$> get tid + i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR + +breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs + guardM . lift $ + (&&) <$> fmap isJust (get ssh) + <*> fmap isJust (get tid) + return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) + +breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR +breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of + AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do + mr <- getMessageRender + Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) + ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR + AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do + cid <- decrypt cID + Course{..} <- do + aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash + guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] + MaybeT $ get cid + return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR + APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR + AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR + AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR + AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR + +breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR +breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR +breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR + +breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing +breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR +breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do + guardM . lift . existsBy $ TermSchoolCourseShort tid ssh csh + return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) +breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR +breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do + guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID + uid <- decrypt cID + User{userDisplayName} <- MaybeT $ get uid + return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) +breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR +breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR +breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR + +breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of + CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR + CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR + CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR + CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR + CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR + +breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of + CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR + CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR + +breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR + +breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR + +breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of + CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do + guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR + appId <- decrypt cID + User{..} <- MaybeT (get appId) >>= MaybeT . get . courseApplicationUser + return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) + CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR + +breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of + EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do + guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR + return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) + EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR + EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR + EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR + EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR + ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR + EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR + ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR + ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR + +breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of + TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do + guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR + return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR + TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR + TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR + TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR + TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR + +breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of + SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do + guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR + return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR + SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR + SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR + SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR + SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR + SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR + SubmissionR cid sRoute' -> case sRoute' of + SubShowR -> do + mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR + if + | mayList + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR + | otherwise + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR + CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR + SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR + SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR + SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR + SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR + SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR + SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR + +breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR +breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of + MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do + guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR + return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR + MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR + MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR + MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR + MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR + +breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR + +breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing +breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR +breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR +breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR +breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR + +breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing + +breadcrumb (MessageR _) = do + mayList <- hasReadAccessTo MessageListR + if + | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR + | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR +breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR +breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID + +breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR + +breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing +breadcrumb EExamNewR = do + isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR + i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR +breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of + EEShowR -> do + (isEO, mayShow) <- (,) + <$> hasReadAccessTo (ExamOfficeR EOExamsR) + <*> hasReadAccessTo (EExamR tid ssh coursen examn EEShowR) + maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do + guard mayShow + i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR + EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR + EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR + EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR + EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR + +breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR +breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR +breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of + AWDEditR -> do + MsgRenderer mr <- getMsgRenderer + i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR + AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR + AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR +breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR +breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR +breadcrumb (AdminWorkflowInstanceR _cID sRoute) = case sRoute of + AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR +breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR +breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR + +breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing +breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR +breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of + GWIEditR -> do + desc <- runMaybeT $ do + guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR + wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal + MaybeT $ selectWorkflowInstanceDescription wiId + case desc of + Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR + Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR + GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR + GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR + GWIInitiateR -> do + mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR + i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if + | mayEdit -> GlobalWorkflowInstanceR win GWIEditR + | otherwise -> GlobalWorkflowInstanceListR +breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR +breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of + 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 @@ -449,10 +455,14 @@ data NavLevel = NavLevelTop | NavLevelInner data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +data NavAccess = NavAccessDB (ReaderT SqlReadBackend Handler Bool) + | NavAccessHandler (Handler Bool) + | NavAccessTrue + data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink { navLabel :: msg , navRoute :: route - , navAccess' :: Handler Bool + , navAccess' :: NavAccess , navType :: NavType , navQuick' :: NavQuickView -> Any , navForceActive :: Bool @@ -522,7 +532,7 @@ deriving anyclass instance Hashable (AuthId UniWorX) => Hashable NavigationCache deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey -navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX, MonadUnliftIO m) => Nav -> MaybeT m Nav +navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav navAccess = execStateT $ do guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess @@ -530,16 +540,19 @@ navAccess = execStateT $ do whenM (hasn't _navLink <$> use id) $ guardM $ not . null <$> use _navChildren -navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX, MonadUnliftIO m) => NavLink -> m Bool -navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute +navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool +navLinkAccess NavLink{..} = case navAccess' of + NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck (liftHandler . runDBRead) navType navRoute + NavAccessDB naDb -> handle shortCircuit . liftHandler . runDBRead $ naDb `and2M` accessCheck id navType navRoute + NavAccessTrue -> accessCheck (liftHandler . runDBRead) navType navRoute where shortCircuit :: HandlerContents -> m Bool shortCircuit _ = return False - accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool - accessCheck nt (urlRoute -> route) = do + accessCheck :: forall route m'. (HasRoute UniWorX route, MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m') => (forall a. ReaderT SqlReadBackend Handler a -> m' a) -> NavType -> route -> m' Bool + accessCheck liftDb nt (urlRoute -> route) = do authCtx <- getAuthContext - memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) $ + memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . liftDb $ bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route defaultLinks :: ( MonadHandler m @@ -554,7 +567,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogout , navRoute = AuthR LogoutR - , navAccess' = is _Just <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -566,7 +579,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogin , navRoute = AuthR LoginR - , navAccess' = is _Nothing <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Nothing <$> maybeAuthId , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -578,7 +591,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuProfile , navRoute = ProfileR - , navAccess' = is _Just <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -592,7 +605,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the let navChildren = flip map (toList appLanguages) $ \lang -> NavLink { navLabel = MsgLanguage lang , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeButton { navMethod = POST , navData = [(toPathPiece PostLanguage, lang)] @@ -618,7 +631,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuHelp , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -627,7 +640,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuDataProt , navRoute = LegalR :#: ("data-protection" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -635,7 +648,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuTermsUse , navRoute = LegalR :#: ("terms-of-use" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -643,7 +656,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuCopyright , navRoute = LegalR :#: ("copyright" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -651,7 +664,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuImprint , navRoute = LegalR :#: ("imprint" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -659,7 +672,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuInformation , navRoute = InfoR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -667,7 +680,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -675,7 +688,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -686,7 +699,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuNews , navRoute = NewsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -698,7 +711,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCourseList , navRoute = CourseListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -710,7 +723,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -722,7 +735,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuExamOfficeExams , navRoute = ExamOfficeR EOExamsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -740,7 +753,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowInstanceList , navRoute = TopWorkflowInstanceListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -752,7 +765,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowListHeader , navRoute = TopWorkflowWorkflowListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -767,7 +780,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuUsers , navRoute = UsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -775,7 +788,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuSchoolList , navRoute = SchoolListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -783,7 +796,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgAdminFeaturesHeading , navRoute = AdminFeaturesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -791,7 +804,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuMessageList , navRoute = MessageListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -799,7 +812,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminErrMsg , navRoute = AdminErrMsgR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -807,7 +820,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTokens , navRoute = AdminTokensR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -815,7 +828,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminWorkflowDefinitionList , navRoute = AdminWorkflowDefinitionListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -823,7 +836,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminCrontab , navRoute = AdminCrontabR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -831,7 +844,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTest , navRoute = AdminTestR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -846,7 +859,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -854,7 +867,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuExternalExamList , navRoute = EExamListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -862,7 +875,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuTermShow , navRoute = TermShowR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -870,7 +883,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -878,7 +891,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -900,7 +913,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenCourses , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -911,7 +924,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenAllocations , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -941,7 +954,7 @@ pageActions (CourseR tid ssh csh CShowR) = do return NavLink { navLabel = examn , navRoute = CExamR tid ssh csh examn EShowR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -953,7 +966,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = + , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -963,7 +976,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive void $ courseWhere course mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR - in runDBRead $ mayRegister `or2M` hasParticipants + in mayRegister `or2M` hasParticipants , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -977,7 +990,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuMaterialList , navRoute = CourseR tid ssh csh MaterialListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents existsVisible = do @@ -988,7 +1001,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ material E.^. MaterialName anyM matNames (materialAccess . E.unValue) - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -999,7 +1012,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetList , navRoute = CourseR tid ssh csh SheetListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents existsVisible = do @@ -1010,7 +1023,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ sheet E.^. SheetName anyM sheetNames $ sheetAccess . E.unValue - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -1021,7 +1034,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuTutorialList , navRoute = CourseR tid ssh csh CTutorialListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -1032,7 +1045,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuExamList , navRoute = CourseR tid ssh csh CExamListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR existsVisible = do @@ -1043,7 +1056,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ exam E.^. ExamName anyM examNames $ examAccess . E.unValue - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList , navForceActive = False @@ -1056,7 +1069,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseCommunication , navRoute = CourseR tid ssh csh CCommR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -1067,13 +1080,12 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseExamOffice , navRoute = CourseR tid ssh csh CExamOfficeR - , navAccess' = do + , navAccess' = NavAccessDB $ do uid <- requireAuthId - runDBRead $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - E.selectExists $ do - (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) - E.where_ $ E.not_ isForced + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + E.selectExists $ do + (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) + E.where_ $ E.not_ isForced , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1083,7 +1095,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseEdit , navRoute = CourseR tid ssh csh CEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1095,7 +1107,7 @@ pageActions (CourseR tid ssh csh CShowR) = do , navRoute = ( CourseNewR , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] ) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1105,7 +1117,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseDelete , navRoute = CourseR tid ssh csh CDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1117,7 +1129,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeFields , navRoute = ExamOfficeR EOFieldsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1128,7 +1140,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeUsers , navRoute = ExamOfficeR EOUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1141,7 +1153,7 @@ pageActions SchoolListR = return { navLink = NavLink { navLabel = MsgMenuSchoolNew , navRoute = SchoolNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1154,7 +1166,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuLecturerInvite , navRoute = AdminNewFunctionaryInviteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1165,7 +1177,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuUserAdd , navRoute = AdminUserAddR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1178,7 +1190,7 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserNotifications , navRoute = UserNotificationR cID - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1189,9 +1201,9 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserPassword , navRoute = UserPasswordR cID - , navAccess' = do + , navAccess' = NavAccessDB $ do uid <- decrypt cID - User{userAuthentication} <- runDBRead $ get404 uid + User{userAuthentication} <- get404 uid return $ is _AuthPWHash userAuthentication , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1205,7 +1217,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1216,7 +1228,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1227,7 +1239,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1238,7 +1250,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1251,7 +1263,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1262,7 +1274,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1273,7 +1285,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1284,7 +1296,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1297,7 +1309,7 @@ pageActions HealthR = return { navLink = NavLink { navLabel = MsgMenuInstance , navRoute = InstanceR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1310,7 +1322,7 @@ pageActions InstanceR = return { navLink = NavLink { navLabel = MsgMenuHealth , navRoute = HealthR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1323,7 +1335,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1334,7 +1346,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1350,7 +1362,7 @@ pageActions HelpR = return return NavLink { navLabel , navRoute = InfoLecturerR :#: section - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1360,7 +1372,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1373,7 +1385,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ProfileDataR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1384,7 +1396,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuAuthPreds , navRoute = AuthPredsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1395,7 +1407,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1410,7 +1422,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuTermCreate , navRoute = TermEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1421,7 +1433,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1434,7 +1446,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationInfo , navRoute = InfoAllocationR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1445,7 +1457,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationUsers , navRoute = AllocationR tid ssh ash AUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1456,7 +1468,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1469,7 +1481,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationPriorities , navRoute = AllocationR tid ssh ash APriosR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1480,7 +1492,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1491,7 +1503,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationAddUser , navRoute = AllocationR tid ssh ash AAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1506,7 +1518,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1517,7 +1529,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1528,7 +1540,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1541,7 +1553,7 @@ pageActions CourseNewR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1554,7 +1566,7 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CourseR tid ssh csh CAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1570,12 +1582,12 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return , ("corrections-course", toPathPiece csh) ] ) - , navAccess' = do + , navAccess' = NavAccessDB $ do muid <- maybeAuthId case muid of Nothing -> return False (Just uid) -> do - runDBRead . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -1597,7 +1609,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CourseR tid ssh csh CCorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1611,10 +1623,9 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetCurrent , navRoute = CourseR tid ssh csh SheetCurrentR - , navAccess' = - runDBRead . maybeT (return False) $ do - void . MaybeT $ sheetCurrent tid ssh csh - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + void . MaybeT $ sheetCurrent tid ssh csh + return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1625,10 +1636,9 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetOldUnassigned , navRoute = CourseR tid ssh csh SheetOldUnassignedR - , navAccess' = - runDBRead . maybeT (return False) $ do - void . MaybeT $ sheetOldUnassigned tid ssh csh - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + void . MaybeT $ sheetOldUnassigned tid ssh csh + return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1641,7 +1651,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetNew , navRoute = CourseR tid ssh csh SheetNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1654,7 +1664,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1665,7 +1675,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return { navLink = NavLink { navLabel = MsgMenuCourseApplications , navRoute = CourseR tid ssh csh CApplicationsR - , navAccess' = + , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -1679,7 +1689,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse void $ courseWhere course - in runDBRead $ courseAllocation `or2M` courseApplications `or2M` existsApplications + in courseAllocation `or2M` courseApplications `or2M` existsApplications , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1692,7 +1702,7 @@ pageActions (CourseR tid ssh csh MaterialListR) = return { navLink = NavLink { navLabel = MsgMenuMaterialNew , navRoute = CourseR tid ssh csh MaterialNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1705,7 +1715,7 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialEdit , navRoute = CMaterialR tid ssh csh mnm MEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1716,7 +1726,7 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialDelete , navRoute = CMaterialR tid ssh csh mnm MDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1728,7 +1738,7 @@ pageActions (CourseR tid ssh csh CTutorialListR) = return { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1741,7 +1751,7 @@ pageActions (CTutorialR tid ssh csh tutn TEditR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1753,7 +1763,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialComm , navRoute = CTutorialR tid ssh csh tutn TCommR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1764,7 +1774,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialEdit , navRoute = CTutorialR tid ssh csh tutn TEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1775,7 +1785,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1787,7 +1797,7 @@ pageActions (CourseR tid ssh csh CExamListR) = return { navLink = NavLink { navLabel = MsgMenuExamNew , navRoute = CourseR tid ssh csh CExamNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1803,7 +1813,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1814,7 +1824,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1825,7 +1835,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1836,7 +1846,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1849,7 +1859,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1860,7 +1870,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1871,7 +1881,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1883,7 +1893,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamAddMembers , navRoute = CExamR tid ssh csh examn EAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1894,7 +1904,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1905,7 +1915,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1918,7 +1928,7 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1929,7 +1939,7 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1944,7 +1954,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CSheetR tid ssh csh shn SSubsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1958,12 +1968,11 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissionOwn , navRoute = CSheetR tid ssh csh shn SubmissionOwnR - , navAccess' = - runDBRead . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard . not $ null submissions - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + submissions <- lift $ submissionList tid csh shn uid + guard . not $ null submissions + return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1976,7 +1985,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetPersonalisedFiles , navRoute = CSheetR tid ssh csh shn SPersonalFilesR - , navAccess' = + , navAccess' = NavAccessDB $ let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_$ sheet E.^. SheetName E.==. E.val shn @@ -1991,7 +2000,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - in runDBRead $ or2M onlyPersonalised hasPersonalised + in or2M onlyPersonalised hasPersonalised , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2002,7 +2011,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetEdit , navRoute = CSheetR tid ssh csh shn SEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2013,7 +2022,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetClone , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2023,7 +2032,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetDelete , navRoute = CSheetR tid ssh csh shn SDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2035,14 +2044,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionNew , navRoute = CSheetR tid ssh csh shn SubmissionNewR - , navAccess' = + , navAccess' = NavAccessDB $ let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR hasNoSubmission = maybeT (return False) $ do uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True - in runDBRead $ hasNoSubmission `or2M` submissionAccess + in hasNoSubmission `or2M` submissionAccess , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2059,7 +2068,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return , ("corrections-sheet", toPathPiece shn) ] ) - , navAccess' = (== Authorized) <$> evalAccessCorrector tid ssh csh + , navAccess' = NavAccessDB $ (== Authorized) <$> evalAccessCorrector tid ssh csh , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2070,7 +2079,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CSheetR tid ssh csh shn SAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2083,7 +2092,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuCorrection , navRoute = CSubmissionR tid ssh csh shn cid CorrectionR - , navAccess' = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + , navAccess' = NavAccessDB . hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2094,7 +2103,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2105,7 +2114,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2117,7 +2126,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2128,7 +2137,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2140,7 +2149,7 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { navLink = NavLink { navLabel = MsgMenuCourseApplicationsFiles , navRoute = CourseR tid ssh csh CAppsFilesR - , navAccess' = + , navAccess' = NavAccessDB $ let appAccess (E.Value appId) = do cID <- encrypt appId hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR @@ -2152,7 +2161,7 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return E.where_ . E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId return $ courseApplication E.^. CourseApplicationId - in runDBRead . runConduit $ appSource .| anyMC appAccess + in runConduit $ appSource .| anyMC appAccess , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2163,10 +2172,9 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = - runDBRead $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - exists [ CourseParticipantCourse ==. cid ] + , navAccess' = NavAccessDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + exists [ CourseParticipantCourse ==. cid ] , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2179,7 +2187,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsDownload , navRoute = CorrectionsDownloadR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2190,7 +2198,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsUpload , navRoute = CorrectionsUploadR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2201,7 +2209,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsCreate , navRoute = CorrectionsCreateR - , navAccess' = runDBRead . maybeT (return False) $ do + , navAccess' = NavAccessDB . maybeT (return False) $ do uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -2225,7 +2233,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsGrade , navRoute = CorrectionsGradeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2240,7 +2248,7 @@ pageActions CorrectionsGradeR = do { navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2253,7 +2261,7 @@ pageActions EExamListR = return { navLink = NavLink { navLabel = MsgMenuExternalExamNew , navRoute = EExamNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2266,7 +2274,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2277,7 +2285,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2288,7 +2296,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2299,7 +2307,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2312,7 +2320,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2323,7 +2331,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2334,7 +2342,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2347,7 +2355,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2358,7 +2366,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2369,7 +2377,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2382,7 +2390,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2393,7 +2401,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2404,7 +2412,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2417,7 +2425,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2429,7 +2437,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgMenuParticipantsIntersect , navRoute = ParticipantsIntersectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False} , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2442,7 +2450,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionNew , navRoute = AdminWorkflowDefinitionNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2453,7 +2461,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceList , navRoute = AdminWorkflowInstanceListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2466,7 +2474,7 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionDelete , navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2476,7 +2484,7 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionInstantiate , navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2489,7 +2497,7 @@ pageActions AdminWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceNew , navRoute = AdminWorkflowInstanceNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2502,7 +2510,7 @@ pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowSc { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowList , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - , navAccess' = runDBRead $ haveWorkflowWorkflows rScope + , navAccess' = NavAccessDB $ haveWorkflowWorkflows rScope , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2515,7 +2523,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2525,7 +2533,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceWorkflows , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2536,7 +2544,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceInitiate , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2549,7 +2557,7 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowEdit , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2559,7 +2567,7 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2571,7 +2579,7 @@ pageActions TopWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowList , navRoute = TopWorkflowWorkflowListR - , navAccess' = runDBRead haveTopWorkflowWorkflows + , navAccess' = NavAccessDB haveTopWorkflowWorkflows , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2611,9 +2619,7 @@ pageQuickActions qView route = do filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick') -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector - :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) - => TermId -> SchoolId -> CourseShorthand -> m AuthResult +evalAccessCorrector :: (MonadAP m, MonadThrow m) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False @@ -2682,6 +2688,7 @@ haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlR runConduit $ transPipe lift getInstances .| C.foldMapM instanceRoles let + evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool evalRole ((rScope, win), role) = do let route = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) is _Authorized <$> hasWorkflowRole Nothing role route False @@ -2715,6 +2722,7 @@ haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlR runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles let + evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool evalRole ((wwId, cID, rScope), role) = do let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) is _Authorized <$> hasWorkflowRole (Just wwId) role route False diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index f12782fbb..95e32abf9 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -89,24 +89,6 @@ siteLayout' overrideHeading widget = do currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest) - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - let - breadcrumbs' mcRoute = do - mr <- getMessageRender - case mcRoute of - Nothing -> return (mr MsgErrorResponseTitleNotFound, []) - Just cRoute -> do - (title, next) <- breadcrumb cRoute - crumbs <- go [] next - return (title, crumbs) - where - go crumbs Nothing = return crumbs - go crumbs (Just cRoute) = do - hasAccess <- hasReadAccessTo cRoute - (title, next) <- breadcrumb cRoute - go ((cRoute, title, hasAccess) : crumbs) next - (title, parents) <- breadcrumbs' mcurrentRoute - -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) @@ -114,11 +96,12 @@ siteLayout' overrideHeading widget = do now <- liftIO getCurrentTime - -- Lookup Favourites & Theme if possible - (favourites', maxFavouriteTerms, currentTheme) <- do - muid <- maybeAuthPair + -- Lookup Favourites, Breadcrumbs, & Theme if possible + (favourites', (title, parents), maxFavouriteTerms, currentTheme) <- do + muid <- maybeAuthPair - favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + (favCourses, breadcrumbs'') <- runDBRead $ do + favCourses'' <- E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) @@ -174,10 +157,30 @@ siteLayout' overrideHeading widget = do let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView) - return ( favCourses - , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid - , maybe userDefaultTheme userTheme $ view _2 <$> muid - ) + breadcrumbs'' + <- let breadcrumbs' mcRoute = do + mr <- getMessageRender + case mcRoute of + Nothing -> return (mr MsgErrorResponseTitleNotFound, []) + Just cRoute -> do + (title, next) <- breadcrumb cRoute + crumbs <- go [] next + return (title, crumbs) + where + go crumbs Nothing = return crumbs + go crumbs (Just cRoute) = do + hasAccess <- hasReadAccessTo cRoute + (title, next) <- breadcrumb cRoute + go ((cRoute, title, hasAccess) : crumbs) next + in breadcrumbs' mcurrentRoute + + return (favCourses, breadcrumbs'') + + return ( favCourses + , breadcrumbs'' + , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid + , maybe userDefaultTheme userTheme $ view _2 <$> muid + ) let favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites' @@ -454,7 +457,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) guard $ not systemMessageNewsOnly cID <- encrypt smId - void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + guardM . lift . hasReadAccessTo $ MessageR cID now <- liftIO getCurrentTime guard $ NTop systemMessageFrom <= NTop (Just now) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 181392774..bc7647387 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -11,6 +11,7 @@ import Foundation.I18n import Foundation.Authorization import Foundation.SiteLayout import Foundation.Routes +import Foundation.DB import qualified Data.Aeson as JSON import qualified Data.Text as Text @@ -30,7 +31,7 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do let shouldEncrypt' = getsYesod $ view _appEncryptErrors - canDecrypt' = is _Authorized <$> evalAccess AdminErrMsgR True + canDecrypt' = runDBRead $ hasWriteAccessTo AdminErrMsgR decrypted' <- runMaybeT $ do internalErrorContent <- hoistMaybe $ err ^? _InternalError exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 650236778..3a9294f02 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -59,7 +59,7 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar case route of -- update Course Favourites here CourseR tid ssh csh _ -> do void . lift . runDB . runMaybeT $ do - guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False + guardM . lift . hasReadAccessTo $ CourseR tid ssh csh CShowR lift . updateFavourites $ Just (tid, ssh, csh) _other -> return () normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 6c9a06864..e9f2374a2 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -31,10 +31,10 @@ runDB' :: ( YesodPersistBackend UniWorX ~ SqlBackend => CallStack -> YesodDB UniWorX a -> HandlerFor UniWorX a runDB' lbl action = do $logDebugS "YesodPersist" "runDB" - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action + let action' = do + dryRun <- isDryRunDB + if | dryRun -> action <* transactionUndo + | otherwise -> action flip (runSqlPoolRetry' action') lbl . appConnPool =<< getYesod @@ -73,10 +73,10 @@ getDBRunner' lbl = do return . (, cleanup) $ DBRunner (\action -> do - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action + let action' = do + dryRun <- isDryRunDB + if | dryRun -> action <* transactionUndo + | otherwise -> action $logDebugS "YesodPersist" "runDBRunner" runDBRunner action' ) diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index 38a3e19d4..aa2876349 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -107,7 +107,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip fRequired = True -validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FormValidator ExternalExamForm m () +validateExternalExam :: (MonadThrow m, MonadAP m) => FormValidator ExternalExamForm m () validateExternalExam = do State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool) diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 18fdf5a59..1153f81f3 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -106,9 +106,8 @@ getGlossaryR = mkI18nWidgetEnum "FAQ" "faq" mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal" -faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX +faqsWidget :: ( MonadAP m , MonadThrow m - , MonadUnliftIO m ) => Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool) faqsWidget mLimit route = do @@ -156,9 +155,8 @@ getFaqR = fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing -showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX +showFAQ :: ( MonadAP m , MonadThrow m - , MonadUnliftIO m ) => Route UniWorX -> FAQItem -> m Bool showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 6c8aae995..12ee98805 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -70,12 +70,12 @@ warnTermDays tid timeNames = do -- | return a value only if the current user ist authorized for a given route -guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h, MonadUnliftIO h - , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)) +guardAuthorizedFor :: ( MonadThrow m + , MonadTrans t, MonadPlus (t (ReaderT SqlBackend m)) + , MonadAP (ReaderT SqlBackend m) ) - => Route UniWorX -> a -> m (ReaderT SqlBackend h) a -guardAuthorizedFor link val = - val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) + => Route UniWorX -> a -> t (ReaderT SqlBackend m) a +guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link runAppLoggingT :: UniWorX -> LoggingT m a -> m a diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 15676222f..3ab5595b8 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -86,6 +86,7 @@ sourceWorkflowActionInfos , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCatch m, MonadUnliftIO m + , MonadAP (ReaderT backend m) ) => WorkflowWorkflowId -> WorkflowState FileReference UserId diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7ca1dcaaa..8491e2f60 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -23,6 +23,7 @@ import ClassyPrelude.Yesod as Import , defaultYesodMiddleware , authorizationCheck , mkMessage, mkMessageFor, mkMessageVariant + , YesodBreadcrumbs(..) ) import UnliftIO.Async.Utils as Import