{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} -- for `ChildrenNavChildren` {-# LANGUAGE DuplicateRecordFields #-} -- for `navLabel` module Foundation.Navigation ( NavQuickView(..), NavType(..), NavLevel(..), NavHeaderRole(..), NavLink(..), Nav(..), NavChildren , _navModal, _navMethod, _navData, _navLabel, _navType, _navForceActive, _navHeaderRole, _navIcon, _navLink, _navChildren , _NavHeader, _NavHeaderContainer, _NavPageActionPrimary, _NavPageActionSecondary, _NavFooter , NavigationCacheKey(..) , navBaseRoute, navLinkRoute , pageActions , pageQuickActions , defaultLinks , navAccess , navQuick , evalAccessCorrector , breadcrumb ) where import Import.NoFoundation hiding (runDB) import Foundation.Type import Foundation.Routes import Foundation.I18n import Foundation.Authorization import Handler.Utils.Memcached import Handler.Utils.ExamOffice.Course import Utils.Sheet import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) import Yesod.Core.Types (HandlerContents) type Breadcrumb = (Text, Maybe (Route UniWorX)) -- Define breadcrumbs. i18nCrumb :: forall msg m. (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX) => msg -> Maybe (Route UniWorX) -> m Breadcrumb i18nCrumb msg mbR = do mr <- getMessageRender return (mr msg, mbR) -- `breadcrumb` _really_ needs to be total for _all_ routes -- -- Even if routes are POST only or don't usually use `siteLayout` they will if -- an error occurs. -- -- 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). breadcrumb :: ( BearerAuthSite UniWorX , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , MonadHandler m, HandlerSite m ~ UniWorX ) => Route UniWorX -> m 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 UploadR = i18nCrumb MsgBreadcrumbUpload Nothing breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR breadcrumb (AdminUserR cID) = useRunDB . 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) = useRunDB $ do mayList <- hasReadAccessTo UsersR if | mayList -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID | otherwise -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR breadcrumb (UserPasswordR cID) = useRunDB $ 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 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 -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do School{..} <- MaybeT $ get ssh isAdmin <- lift $ hasReadAccessTo SchoolListR return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) 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 StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb LmsR = i18nCrumb MsgMenuLms Nothing breadcrumb LmsUserlistR = i18nCrumb MsgMenuLmsUserlist $ Just LmsR breadcrumb LmsResultR = i18nCrumb MsgMenuLmsResult $ Just LmsR 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) = useRunDB . 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) = useRunDB . 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 AllocationNewR = i18nCrumb MsgBreadcrumbAllocationNew $ Just AllocationListR breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of AShowR -> useRunDB . 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) AEditR -> i18nCrumb MsgBreadcrumbAllocationEdit . Just $ AllocationR tid ssh ash AShowR AMatchingListR -> i18nCrumb MsgBreadcrumbAllocationMatchings . Just $ AllocationR tid ssh ash AShowR AMatchingR _ AMLogR -> i18nCrumb MsgBreadcrumbAllocationMatchingLog . Just $ AllocationR tid ssh ash AMatchingListR ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR AApplyR cID -> useRunDB . 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 AEditUserR cID -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbAllocationEditUser . Just $ AllocationR tid ssh ash AUsersR) $ do guardM . lift . hasReadAccessTo . AllocationR tid ssh ash $ AEditUserR cID uid <- decrypt cID User{..} <- MaybeT $ get uid return (userDisplayName, Just $ AllocationR tid ssh ash AUsersR) ADelUserR cID -> i18nCrumb MsgBreadcrumbAllocationDelUser . Just $ AllocationR tid ssh ash (AEditUserR cID) 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) = useRunDB . 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)) = useRunDB . 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 -> useRunDB . 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 -> useRunDB . 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 -> useRunDB . 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 -> useRunDB . 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 -> useRunDB $ do mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR return ( toPathPiece cid , Just . CSheetR tid ssh csh shn $ bool SShowR SSubsR mayList ) 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 SubAuthorshipStatementsR -> i18nCrumb MsgBreadcrumbSubmissionAuthorshipStatements . 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 -> useRunDB . 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 <- useRunDB $ 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 <- useRunDB . 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) <- useRunDB $ (,) <$> 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 data NavQuickView = NavQuickViewFavourite | NavQuickViewPageActionSecondary deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Universe, Finite) navQuick :: NavQuickView -> (NavQuickView -> Any) navQuick x x' = Any $ x == x' data NavType = NavTypeLink { navModal :: Bool } | NavTypeButton { navMethod :: StdMethod , navData :: [(Text, Text)] } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (Hashable, Binary) makeLenses_ ''NavType makePrisms ''NavType data NavLevel = NavLevelTop | NavLevelInner deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) 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' :: NavAccess , navType :: NavType , navQuick' :: NavQuickView -> Any , navForceActive :: Bool } makeLenses_ ''NavLink -- instance HasRoute UniWorX NavLink where -- urlRoute NavLink{..} = urlRoute navRoute -- instance RedirectUrl UniWorX NavLink where -- toTextUrl NavLink{..} = toTextUrl navRoute instance RenderMessage UniWorX NavLink where renderMessage app ls NavLink{..} = renderMessage app ls navLabel navBaseRoute :: NavLink -> Route UniWorX navBaseRoute NavLink{navRoute} = urlRoute navRoute navLinkRoute :: Applicative m => NavLink -> m (SomeRoute UniWorX) navLinkRoute NavLink{..} = pure $ SomeRoute navRoute data Nav = NavHeader { navHeaderRole :: NavHeaderRole , navIcon :: Icon , navLink :: NavLink } | NavHeaderContainer { navHeaderRole :: NavHeaderRole , navLabel :: SomeMessage UniWorX , navIcon :: Icon , navChildren :: [NavLink] } | NavPageActionPrimary { navLink :: NavLink , navChildren :: [NavLink] } | NavPageActionSecondary { navLink :: NavLink } | NavFooter { navLink :: NavLink } deriving (Generic, Typeable) makeLenses_ ''Nav makePrisms ''Nav data NavChildren type instance Children NavChildren a = ChildrenNavChildren a type family ChildrenNavChildren a where ChildrenNavChildren (SomeMessage UniWorX) = '[] ChildrenNavChildren a = Children ChGeneric a data NavigationCacheKey = NavCacheRouteAccess AuthContext NavType (Route UniWorX) deriving (Generic, Typeable) deriving stock instance Eq (AuthId UniWorX) => Eq NavigationCacheKey deriving stock instance Ord (AuthId UniWorX) => Ord NavigationCacheKey deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read NavigationCacheKey deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show NavigationCacheKey deriving anyclass instance Hashable (AuthId UniWorX) => Hashable NavigationCacheKey deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav navAccess = execStateT $ do guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess _navChildren <~ (filterM (lift . lift . navLinkAccess) =<< use _navChildren) whenM (hasn't _navLink <$> use id) $ guardM $ not . null <$> use _navChildren navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => NavLink -> m Bool navLinkAccess NavLink{..} = case navAccess' of NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck navType navRoute NavAccessDB naDb -> handle shortCircuit . useRunDB $ naDb `and2M` accessCheck navType navRoute NavAccessTrue -> accessCheck navType navRoute where shortCircuit :: HandlerContents -> m Bool shortCircuit _ = return False accessCheck :: forall m' route. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m', WithRunDB SqlReadBackend (HandlerFor UniWorX) m', HasRoute UniWorX route) => NavType -> route -> m' Bool accessCheck nt (urlRoute -> route) = do authCtx <- getAuthContext memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . useRunDB $ bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route defaultLinks :: ( MonadHandler m , HandlerSite m ~ UniWorX -- , MonadThrow m -- , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX ) => m [Nav] defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. [ return NavHeader { navHeaderRole = NavHeaderSecondary , navIcon = IconMenuLogout , navLink = NavLink { navLabel = MsgMenuLogout , navRoute = AuthR LogoutR , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderSecondary , navIcon = IconMenuLogin , navLink = NavLink { navLabel = MsgMenuLogin , navRoute = AuthR LoginR , navAccess' = NavAccessHandler $ is _Nothing <$> maybeAuthId , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderSecondary , navIcon = IconMenuProfile , navLink = NavLink { navLabel = MsgMenuProfile , navRoute = ProfileR , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , do mCurrentRoute <- getCurrentRoute activeLang <- selectLanguage appLanguages let navChildren = flip map (toList appLanguages) $ \lang -> NavLink { navLabel = MsgLanguageEndonym lang , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) , navAccess' = NavAccessTrue , navType = NavTypeButton { navMethod = POST , navData = [(toPathPiece PostLanguage, lang)] } , navQuick' = mempty , navForceActive = lang == activeLang } guard $ length navChildren > 1 return NavHeaderContainer { navHeaderRole = NavHeaderSecondary , navLabel = SomeMessage MsgMenuLanguage , navIcon = IconLanguage , navChildren } , do mCurrentRoute <- getCurrentRoute return NavHeader { navHeaderRole = NavHeaderSecondary , navIcon = IconMenuHelp , navLink = NavLink { navLabel = MsgMenuHelp , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } } , return $ NavFooter NavLink { navLabel = MsgMenuDataProt , navRoute = LegalR :#: ("data-protection" :: Text) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuTermsUse , navRoute = LegalR :#: ("terms-of-use" :: Text) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuCopyright , navRoute = LegalR :#: ("copyright" :: Text) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuImprint , navRoute = LegalR :#: ("imprint" :: Text) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuInformation , navRoute = InfoR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuFaq , navRoute = FaqR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return $ NavFooter NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuNews , navLink = NavLink { navLabel = MsgMenuNews , navRoute = NewsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuCourseList , navLink = NavLink { navLabel = MsgMenuCourseList , navRoute = CourseListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuCorrections , navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuExams , navLink = NavLink { navLabel = MsgMenuExamOfficeExams , navRoute = ExamOfficeR EOExamsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeaderContainer { navHeaderRole = NavHeaderPrimary , navLabel = SomeMessage MsgMenuAdminHeading , navIcon = IconMenuAdmin , navChildren = [ NavLink { navLabel = MsgMenuUsers , navRoute = UsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuSchoolList , navRoute = SchoolListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuMessageList , navRoute = MessageListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuAdminErrMsg , navRoute = AdminErrMsgR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuAdminTokens , navRoute = AdminTokensR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuAdminCrontab , navRoute = AdminCrontabR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuAdminTest , navRoute = AdminTestR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } ] } , return NavHeaderContainer { navHeaderRole = NavHeaderPrimary , navLabel = SomeMessage (mempty :: Text) , navIcon = IconMenuExtra , navChildren = [ NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuExternalExamList , navRoute = EExamListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuTermShow , navRoute = TermShowR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } ] } ] pageActions :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX , MonadUnliftIO m ) => Route UniWorX -> m [Nav] pageActions NewsR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuOpenCourses , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuOpenAllocations , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (CourseR tid ssh csh CShowR) = do materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR let examListBound :: Num a => a examListBound = 4 -- guaranteed random; chosen by fair dice roll examListExams <- useRunDB $ do examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.limit $ succ examListBound return $ exam E.^. ExamName return $ do E.Value examn <- examNames return NavLink { navLabel = examn , navRoute = CExamR tid ssh csh examn EShowR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } let showExamList = length examListExams <= examListBound let navMembers = NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive void $ courseWhere course mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR in mayRegister `or2M` hasParticipants , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = membersSecondary } showMembers <- maybeT (return False) $ True <$ navAccess navMembers return $ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialList , navRoute = CourseR tid ssh csh MaterialListR , 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 matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return $ material E.^. MaterialName anyM matNames (materialAccess . E.unValue) in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = materialListSecondary } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetList , navRoute = CourseR tid ssh csh SheetListR , 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 sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return $ sheet E.^. SheetName anyM sheetNames $ sheetAccess . E.unValue in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = sheetListSecondary } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialList , navRoute = CourseR tid ssh csh CTutorialListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = tutorialListSecondary } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamList , navRoute = CourseR tid ssh csh CExamListR , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR existsVisible = do examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return $ exam E.^. ExamName anyM examNames $ examAccess . E.unValue in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList , navForceActive = False } , navChildren = examListSecondary ++ guardOnM showExamList examListExams } , navMembers ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseCommunication , navRoute = CourseR tid ssh csh CCommR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuCourseExamOffice , navRoute = CourseR tid ssh csh CExamOfficeR , navAccess' = NavAccessDB $ do uid <- requireAuthId 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 } } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuCourseEdit , navRoute = CourseR tid ssh csh CEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuCourseClone , navRoute = ( CourseNewR , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] ) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuCourseDelete , navRoute = CourseR tid ssh csh CDeleteR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (ExamOfficeR EOExamsR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamOfficeFields , navRoute = ExamOfficeR EOFieldsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamOfficeUsers , navRoute = ExamOfficeR EOUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions SchoolListR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSchoolNew , navRoute = SchoolNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions UsersR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuLecturerInvite , navRoute = AdminNewFunctionaryInviteR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuUserAdd , navRoute = AdminUserAddR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (AdminUserR cID) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuUserNotifications , navRoute = UserNotificationR cID , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuUserPassword , navRoute = UserPasswordR cID , navAccess' = NavAccessDB $ do uid <- decrypt cID User{userAuthentication} <- get404 uid return $ is _AuthPWHash userAuthentication , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions InfoR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions VersionR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions HealthR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuInstance , navRoute = InstanceR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions InstanceR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuHealth , navRoute = HealthR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions HelpR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = do (section, navLabel) <- [ ("courses", MsgMenuInfoLecturerCourses) , ("exercises", MsgMenuInfoLecturerExercises) , ("tutorials", MsgMenuInfoLecturerTutorials) , ("exams", MsgMenuInfoLecturerExams) , ("allocations", MsgMenuInfoLecturerAllocations) ] :: [(Text, UniWorXNavigationMessage)] return NavLink { navLabel , navRoute = InfoLecturerR :#: section , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions ProfileR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ProfileDataR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAuthPreds , navRoute = AuthPredsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCsvOptions , navRoute = CsvOptionsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions TermShowR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTermCreate , navRoute = TermEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = participantsSecondary } ] pageActions AllocationListR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationNew , navRoute = AllocationNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (AllocationR tid ssh ash AShowR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationInfo , navRoute = InfoAllocationR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationUsers , navRoute = AllocationR tid ssh ash AUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuAllocationEdit , navRoute = AllocationR tid ssh ash AEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuAllocationMatchings , navRoute = AllocationR tid ssh ash AMatchingListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } } ] pageActions (AllocationR tid ssh ash AUsersR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationPriorities , navRoute = AllocationR tid ssh ash APriosR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationAddUser , navRoute = AllocationR tid ssh ash AAddUserR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (AllocationR tid ssh ash (AEditUserR cID)) = return [ NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuAllocationDelUser , navRoute = AllocationR tid ssh ash $ ADelUserR cID , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } } ] pageActions CourseListR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = participantsSecondary } ] pageActions CourseNewR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (CourseR tid ssh csh CCorrectionsR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CourseR tid ssh csh CAssignR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsOwn , navRoute = ( CorrectionsR , [ ("corrections-term", toPathPiece tid) , ("corrections-school", toPathPiece ssh) , ("corrections-course", toPathPiece csh) ] ) , navAccess' = NavAccessDB $ do muid <- maybeAuthId case muid of Nothing -> return False (Just uid) -> 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) E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions (CourseR tid ssh csh SheetListR) = do correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR let navCorrections = NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CourseR tid ssh csh CCorrectionsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = correctionsSecondary } showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections return $ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetCurrent , navRoute = CourseR tid ssh csh SheetCurrentR , 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 } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetOldUnassigned , navRoute = CourseR tid ssh csh SheetOldUnassignedR , 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 } , navChildren = [] } , navCorrections ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetNew , navRoute = CourseR tid ssh csh SheetNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = [] } ] pageActions (CourseR tid ssh csh CUsersR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseApplications , navRoute = CourseR tid ssh csh CApplicationsR , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse void $ courseWhere course courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do void $ courseWhere course return $ course E.^. CourseApplicationsRequired courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse void $ courseWhere course in courseAllocation `or2M` courseApplications `or2M` existsApplications , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False } , navChildren = [] } ] pageActions (CourseR tid ssh csh MaterialListR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialNew , navRoute = CourseR tid ssh csh MaterialNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions (CMaterialR tid ssh csh mnm MShowR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuMaterialEdit , navRoute = CMaterialR tid ssh csh mnm MEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuMaterialDelete , navRoute = CMaterialR tid ssh csh mnm MDelR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } } ] pageActions (CourseR tid ssh csh CTutorialListR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions (CTutorialR tid ssh csh tutn TEditR) = return [ NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CTutorialR tid ssh csh tutn TUsersR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialComm , navRoute = CTutorialR tid ssh csh tutn TCommR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuTutorialEdit , navRoute = CTutorialR tid ssh csh tutn TEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CourseR tid ssh csh CExamListR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamNew , navRoute = CourseR tid ssh csh CExamNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions (CExamR tid ssh csh examn EShowR) = do usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = usersSecondary } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (CExamR tid ssh csh examn ECorrectR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CExamR tid ssh csh examn EUsersR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamAddMembers , navRoute = CExamR tid ssh csh examn EAddUserR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (CExamR tid ssh csh examn EGradesR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (CSheetR tid ssh csh shn SShowR) = do subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR let navSubmissions = NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CSheetR tid ssh csh shn SSubsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = subsSecondary } showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions return $ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSubmissionOwn , navRoute = CSheetR tid ssh csh shn SubmissionOwnR , 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 } , navChildren = [] } , navSubmissions ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++ [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetPersonalisedFiles , navRoute = CSheetR tid ssh csh shn SPersonalFilesR , 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 E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return $ sheet E.^. SheetAllowNonPersonalisedSubmission hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_$ sheet E.^. SheetName E.==. E.val shn 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 or2M onlyPersonalised hasPersonalised , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSheetEdit , navRoute = CSheetR tid ssh csh shn SEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuSheetClone , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuSheetDelete , navRoute = CSheetR tid ssh csh shn SDelR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CSheetR tid ssh csh shn SSubsR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSubmissionNew , navRoute = CSheetR tid ssh csh shn SubmissionNewR , 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 hasNoSubmission `or2M` submissionAccess , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsOwn , navRoute = ( CorrectionsR , [ ("corrections-term", toPathPiece tid) , ("corrections-school", toPathPiece ssh) , ("corrections-course", toPathPiece csh) , ("corrections-sheet", toPathPiece shn) ] ) , navAccess' = NavAccessDB $ (== Authorized) <$> evalAccessCorrector tid ssh csh , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CSheetR tid ssh csh shn SAssignR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrection , navRoute = 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 } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } ] pageActions (CourseR tid ssh csh CApplicationsR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseApplicationsFiles , navRoute = CourseR tid ssh csh CAppsFilesR , navAccess' = NavAccessDB $ let appAccess (E.Value appId) = do cID <- encrypt appId hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.where_ . E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId return $ courseApplication E.^. CourseApplicationId in runConduit $ appSource .| anyMC appAccess , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR , navAccess' = NavAccessDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh exists [ CourseParticipantCourse ==. cid ] , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions CorrectionsR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsDownload , navRoute = CorrectionsDownloadR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsUpload , navRoute = CorrectionsUploadR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsCreate , navRoute = CorrectionsCreateR , 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 let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ isCorrector' E.||. isLecturer return $ sheet E.^. SheetSubmissionMode return $ orOf (traverse . _Value . _submissionModeCorrector) sheets , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrectionsGrade , navRoute = CorrectionsGradeR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions CorrectionsGradeR = do correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = correctionsSecondary } ] pageActions EExamListR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamNew , navRoute = EExamNewR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (EExamR tid ssh coursen examn EEShowR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (EExamR tid ssh coursen examn EEGradesR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (EExamR tid ssh coursen examn EECorrectR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions (EExamR tid ssh coursen examn EEUsersR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions ParticipantsListR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCsvOptions , navRoute = CsvOptionsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuParticipantsIntersect , navRoute = ParticipantsIntersectR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False} , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False } , navChildren = [] } ] pageActions _ = return [] submissionList :: ( MonadIO m , BackendCompatible SqlReadBackend backend ) => TermId -> CourseShorthand -> SheetName -> UserId -> ReaderT backend m [E.Value SubmissionId] submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseTerm E.==. E.val tid return $ submission E.^. SubmissionId pageQuickActions :: ( MonadCatch m, MonadUnliftIO m , MonadHandler m , HandlerSite m ~ UniWorX , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX ) => NavQuickView -> Route UniWorX -> m [NavLink] pageQuickActions qView route = do items'' <- pageActions route items' <- catMaybes <$> mapM (runMaybeT . navAccess) items'' 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 :: (MonadAP m, MonadThrow m) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False