-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# 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.DateTime import Handler.Utils.Memcached import Handler.Utils.ExamOffice.Course import Utils.Sheet import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Experimental as Ex 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 AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just AdminTestR breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed 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 InfoSupervisorR = i18nCrumb MsgInfoSupervisorTitle $ Just InfoR breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR breadcrumb ImprintR = i18nCrumb MsgMenuImprint $ Just LegalR breadcrumb DataProtectionR = i18nCrumb MsgMenuDataProt $ Just LegalR breadcrumb TermsOfUseR = i18nCrumb MsgMenuTermsUse $ Just LegalR breadcrumb PaymentsR = i18nCrumb MsgMenuPayments $ Just LegalR 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 QualificationAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh return (CI.original $ unSchoolKey ssh, Just QualificationAllR) breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ QualificationSchoolR ssh) breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just QualificationAllR -- never displayed breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh return (CI.original $ unSchoolKey ssh, Just LmsAllR) breadcrumb (LmsR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ LmsSchoolR ssh) $ do guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb ForProfileR{} = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR breadcrumb (ForProfileDataR cID) = i18nCrumb MsgMenuProfileData $ Just (ForProfileR cID) 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 breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing breadcrumb ApiDocsR = i18nCrumb MsgBreadcrumbApiDocs Nothing breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger $ Just ApiDocsR breadcrumb SwaggerJsonR = breadcrumb SwaggerR 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 -- | NavLink default with most common settings defNavLink :: (RenderMessage UniWorX msg, HasRoute UniWorX route) => msg -> route -> NavLink defNavLink navLabel navRoute = NavLink {..} where navAccess' = NavAccessTrue navType = NavTypeLink { navModal = False} navQuick' = mempty navForceActive = False 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 = DataProtectionR , 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 = ImprintR , 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 $ NavFooter NavLink { navLabel = MsgMenuApiDocs , navRoute = ApiDocsR , 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 NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuLms , navLink = NavLink { navLabel = MsgMenuQualifications , navRoute = LmsAllR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconPrintCenter , navLink = NavLink { navLabel = MsgMenuApc , navRoute = PrintCenterR , 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 } , NavLink { navLabel = MsgMenuAvs , navRoute = AdminAvsR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink { navLabel = MsgMenuLdap , navRoute = AdminLdapR , 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 (ForProfileR cID) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ForProfileDataR cID , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , 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 (LmsR sid qsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh , navChildren = [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh , navChildren = [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh , navChildren = [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh ] } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh } ] pageActions ApiDocsR = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuSwagger , navRoute = SwaggerR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , navChildren = [] } ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob let pjDay = E.day $ pj Ex.^. PrintJobCreated Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) Ex.orderBy [ Ex.asc pjDay ] pure (pjDay, pj Ex.^. PrintJobId) let dayMap = Map.fromListWith (<>) (openDays <&> (\(Ex.unValue -> pjDay, Ex.unValue -> pjId) -> (pjDay, Set.singleton pjId))) toDayAck (d, pjIds) = do dtxt <- formatTime SelFormatDate d let n = Set.size pjIds h = hash pjIds msg = "#" <> tshow n <> ", " <> dtxt return NavPageActionPrimary { navLink = NavLink { navLabel = SomeMessage msg , navRoute = PrintAckR d n h , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False } , navChildren = [] } manualSend = NavPageActionSecondary { navLink = NavLink { navLabel = MsgMenuPrintSend , navRoute = PrintSendR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } } dayLinks <- mapM toDayAck $ Map.toAscList dayMap return $ manualSend : take 9 dayLinks 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