Steffen
4df8bd2fa5
new routes /mail and /mail/show/UUID to eventually display all sent emails by the system
2524 lines
102 KiB
Haskell
2524 lines
102 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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 AdminJobsR = i18nCrumb MsgBreadcrumbAdminJobs $ Just AdminCrontabR
|
|
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
|
|
breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR
|
|
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
|
|
breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR
|
|
breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR
|
|
breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR
|
|
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR
|
|
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
|
|
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR
|
|
|
|
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
|
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
|
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
|
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
|
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
|
|
|
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 MsgMenuPrintAck $ Just PrintCenterR
|
|
breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR
|
|
|
|
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing
|
|
breadcrumb MailShowR{} = i18nCrumb MsgMenuMailShow $ Just MailCenterR
|
|
|
|
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 VersionR = i18nCrumb MsgMenuVersion $ Just InfoR
|
|
breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR
|
|
|
|
|
|
breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
|
|
|
|
|
|
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
|
breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR)
|
|
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
|
|
-- v2
|
|
breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh
|
|
breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent
|
|
breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh
|
|
breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh
|
|
breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed
|
|
--
|
|
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
|
|
breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh
|
|
breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
|
|
breadcrumb (LmsUserAllR _ ) = i18nCrumb MsgMenuLmsUserAll $ Just LmsAllR
|
|
-- 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 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 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 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 (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)
|
|
TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR
|
|
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)
|
|
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)
|
|
deriving anyclass (Hashable, Binary)
|
|
|
|
makeLenses_ ''NavType
|
|
makePrisms ''NavType
|
|
|
|
data NavLevel = NavLevelTop | NavLevelInner
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
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
|
|
|
|
defNavLinkModal :: (RenderMessage UniWorX msg, HasRoute UniWorX route) => msg -> route -> NavLink
|
|
defNavLinkModal navLabel navRoute = NavLink {..}
|
|
where
|
|
navAccess' = NavAccessTrue
|
|
navType = NavTypeLink { navModal = True}
|
|
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)
|
|
|
|
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)
|
|
|
|
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 = MsgMenuCourseIcon
|
|
, 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 = IconMenuQualification
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuQualifications
|
|
, navRoute = QualificationAllR
|
|
, navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuLms
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuLms
|
|
, navRoute = LmsAllR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconCompany
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuFirms
|
|
, navRoute = FirmAllR
|
|
, 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 = MsgProblemsHeading
|
|
, navRoute = AdminR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, 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 = MsgMenuCorrections
|
|
, navRoute = CorrectionsR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuExamOfficeExams
|
|
, navRoute = ExamOfficeR EOExamsR
|
|
, 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 = 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 = []
|
|
}
|
|
]
|
|
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 = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID
|
|
, 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 = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuHealthInterface
|
|
, navRoute = HealthInterfaceR []
|
|
, 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)
|
|
] :: [(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 (ForProfileDataR cID) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
|
|
, 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 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 = 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 = []
|
|
}
|
|
]
|
|
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) = do
|
|
membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR
|
|
return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTutorialAddMembers
|
|
, navRoute = CTutorialR tid ssh csh tutn TAddUserR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseMembers
|
|
, navRoute = CourseR tid ssh csh CUsersR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = membersSecondary
|
|
}
|
|
, 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 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 MsgMenuLmsLearners $ LmsLearnersR sid qsh
|
|
, navChildren =
|
|
[ defNavLink MsgMenuLmsDirectDownload $ LmsLearnersDirectR sid qsh
|
|
]
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = defNavLink MsgMenuLmsReport $ LmsReportR sid qsh
|
|
, navChildren =
|
|
[ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh
|
|
, defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR 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 (FirmUsersR fsh) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions (FirmSupersR fsh) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh
|
|
, 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
|
|
}
|
|
}
|
|
printLog = NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuPrintLog
|
|
, navRoute = PrintLogR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
printAck = NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuPrintAck
|
|
, navRoute = PrintAckDirectR
|
|
, navAccess' = NavAccessTrue
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
|
return $ manualSend : printLog : printAck : take 9 dayLinks
|
|
|
|
pageActions AdminCrontabR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = defNavLink MsgMenuAdminJobs AdminJobsR
|
|
, 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
|