2796 lines
114 KiB
Haskell
2796 lines
114 KiB
Haskell
{-# 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
|
|
, navBaseRoute, navLinkRoute
|
|
, pageActions
|
|
, pageQuickActions
|
|
, defaultLinks
|
|
, navAccess
|
|
, navQuick
|
|
, evalAccessCorrector
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Foundation.Type
|
|
import Foundation.Routes
|
|
import Foundation.I18n
|
|
import Foundation.Authorization
|
|
import Foundation.DB
|
|
|
|
import Handler.Utils.Memcached
|
|
import Handler.Utils.ExamOffice.Course
|
|
import Handler.Utils.Download
|
|
import Utils.Sheet
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Control.Monad.Trans.State (execStateT)
|
|
|
|
import Yesod.Core.Types (HandlerContents)
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import Utils.Workflow
|
|
import Handler.Utils.Workflow.CanonicalRoute
|
|
|
|
|
|
-- Define breadcrumbs.
|
|
i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
|
|
=> msg
|
|
-> Maybe (Route (HandlerSite m))
|
|
-> m (Text, Maybe (Route (HandlerSite m)))
|
|
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).
|
|
instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
|
breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR
|
|
breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing
|
|
breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing
|
|
breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing
|
|
|
|
breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing
|
|
breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR
|
|
breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR
|
|
breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
|
|
guardM . hasReadAccessTo $ AdminUserR cID
|
|
uid <- decrypt cID
|
|
User{..} <- MaybeT . runDBRead $ get uid
|
|
return (userDisplayName, Just UsersR)
|
|
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
|
|
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
|
|
breadcrumb (UserNotificationR cID) = do
|
|
mayList <- hasReadAccessTo UsersR
|
|
if
|
|
| mayList
|
|
-> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
|
|
| otherwise
|
|
-> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
|
|
breadcrumb (UserPasswordR cID) = do
|
|
mayList <- hasReadAccessTo UsersR
|
|
if
|
|
| mayList
|
|
-> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID
|
|
| otherwise
|
|
-> i18nCrumb MsgMenuUserPassword $ Just ProfileR
|
|
breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
|
|
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
|
|
|
|
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
|
breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
|
|
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
|
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
|
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
|
|
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
|
|
|
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
|
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
|
SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
|
School{..} <- MaybeT . runDBRead $ get ssh
|
|
isAdmin <- hasReadAccessTo SchoolListR
|
|
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
|
|
|
|
SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
|
|
SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
|
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
|
|
SWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
|
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
|
SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
|
SWIInitiateR -> do
|
|
mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
|
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
|
|
| mayEdit -> SchoolWorkflowInstanceR win SWIEditR
|
|
| otherwise -> SchoolWorkflowInstanceListR
|
|
SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
|
SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of
|
|
SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR
|
|
SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
|
SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
|
SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
|
breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR
|
|
|
|
breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing
|
|
breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR
|
|
breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR
|
|
breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing
|
|
|
|
breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing
|
|
breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
|
|
breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR
|
|
breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR
|
|
breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR
|
|
breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR
|
|
|
|
|
|
breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
|
|
|
|
|
|
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
|
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
|
|
|
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
|
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
|
breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR
|
|
breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR
|
|
breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR
|
|
breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR
|
|
|
|
breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing
|
|
|
|
breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR
|
|
breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
|
|
breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR
|
|
breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid
|
|
breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs
|
|
guardM . lift . runDBRead $ isJust <$> get tid
|
|
i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR
|
|
|
|
breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs
|
|
guardM . lift . runDBRead $
|
|
(&&) <$> fmap isJust (get ssh)
|
|
<*> fmap isJust (get tid)
|
|
return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
|
|
|
breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR
|
|
breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
|
|
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
|
mr <- getMessageRender
|
|
Entity _ Allocation{allocationName} <- MaybeT . runDBRead . getBy $ TermSchoolAllocationShort tid ssh ash
|
|
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
|
|
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
|
|
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
|
cid <- decrypt cID
|
|
Course{..} <- hoist runDBRead $ do
|
|
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
|
guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
|
|
MaybeT $ get cid
|
|
return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
|
|
AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR
|
|
APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR
|
|
AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
|
|
AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR
|
|
AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR
|
|
|
|
breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
|
|
breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR
|
|
breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR
|
|
|
|
breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing
|
|
breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR
|
|
breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
|
|
guardM . lift . runDBRead . existsBy $ TermSchoolCourseShort tid ssh csh
|
|
return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
|
|
breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
|
|
breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
|
|
guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
|
|
uid <- decrypt cID
|
|
User{userDisplayName} <- MaybeT . runDBRead $ get uid
|
|
return (userDisplayName, Just $ CourseR tid ssh csh CUsersR)
|
|
breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR
|
|
breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR
|
|
breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR
|
|
breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR
|
|
breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR
|
|
breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of
|
|
CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR
|
|
CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR
|
|
CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR
|
|
CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR
|
|
CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of
|
|
CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR
|
|
CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR
|
|
|
|
breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR
|
|
|
|
breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
|
|
CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
|
|
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
|
appId <- decrypt cID
|
|
User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
|
|
return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR)
|
|
CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR
|
|
|
|
breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
|
|
EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
|
|
guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
|
|
return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
|
|
EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
|
|
EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
|
|
EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR
|
|
EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR
|
|
ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR
|
|
EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR
|
|
ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
|
|
ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
|
|
EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
|
|
ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
|
|
TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
|
|
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
|
|
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
|
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
|
|
TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
|
|
TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
|
|
TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR
|
|
TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR
|
|
|
|
breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
|
|
SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
|
|
guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
|
|
return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
|
|
SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
|
|
SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
|
|
SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR
|
|
SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR
|
|
SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR
|
|
SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
|
|
SubmissionR cid sRoute' -> case sRoute' of
|
|
SubShowR -> do
|
|
mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
|
|
if
|
|
| mayList
|
|
-> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR
|
|
| otherwise
|
|
-> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR
|
|
CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR
|
|
SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
|
|
SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR
|
|
SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
|
|
SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR
|
|
SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR
|
|
SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR
|
|
SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
|
|
breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
|
|
breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
|
|
MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
|
|
guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
|
|
return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
|
|
MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
|
|
MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
|
|
MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
|
|
MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR
|
|
MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR
|
|
|
|
breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR
|
|
|
|
breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing
|
|
breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR
|
|
breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR
|
|
breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR
|
|
breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR
|
|
|
|
breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
|
|
|
|
breadcrumb (MessageR _) = do
|
|
mayList <- (== Authorized) <$> evalAccess MessageListR False
|
|
if
|
|
| mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
|
|
| otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
|
|
breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
|
|
breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID
|
|
|
|
breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
|
|
|
|
breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
|
|
breadcrumb EExamNewR = do
|
|
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
|
i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
|
|
| isEO -> ExamOfficeR EOExamsR
|
|
| otherwise -> EExamListR
|
|
breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
|
|
EEShowR -> do
|
|
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
|
maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
|
|
guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR
|
|
i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if
|
|
| isEO -> ExamOfficeR EOExamsR
|
|
| otherwise -> EExamListR
|
|
EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR
|
|
EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR
|
|
EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR
|
|
EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
|
|
EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR
|
|
|
|
breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR
|
|
breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR
|
|
breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of
|
|
AWDEditR -> do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR
|
|
AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR
|
|
AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR
|
|
breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR
|
|
breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR
|
|
breadcrumb (AdminWorkflowInstanceR _cID sRoute) = case sRoute of
|
|
AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR
|
|
breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR
|
|
breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR
|
|
|
|
breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing
|
|
breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
|
|
breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
|
GWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
|
|
GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
|
|
GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
|
|
GWIInitiateR -> do
|
|
mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
|
|
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
|
|
| mayEdit -> GlobalWorkflowInstanceR win GWIEditR
|
|
| otherwise -> GlobalWorkflowInstanceListR
|
|
breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
|
|
breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
|
|
GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR
|
|
GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
|
GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
|
GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
|
|
|
breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing
|
|
breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR
|
|
|
|
|
|
data NavQuickView
|
|
= NavQuickViewFavourite
|
|
| NavQuickViewPageActionSecondary
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
deriving (Universe, Finite)
|
|
|
|
navQuick :: NavQuickView -> (NavQuickView -> Any)
|
|
navQuick x x' = Any $ x == x'
|
|
|
|
data NavType
|
|
= NavTypeLink
|
|
{ navModal :: Bool
|
|
}
|
|
| NavTypeButton
|
|
{ navMethod :: StdMethod
|
|
, navData :: [(Text, Text)]
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Binary)
|
|
|
|
makeLenses_ ''NavType
|
|
makePrisms ''NavType
|
|
|
|
data NavLevel = NavLevelTop | NavLevelInner
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink
|
|
{ navLabel :: msg
|
|
, navRoute :: route
|
|
, navDownload :: Maybe (Maybe (ConduitT () (Either FileReference DBFile) Handler ()))
|
|
, navAccess' :: Handler Bool
|
|
, navType :: NavType
|
|
, navQuick' :: NavQuickView -> Any
|
|
, navForceActive :: Bool
|
|
}
|
|
|
|
makeLenses_ ''NavLink
|
|
|
|
-- instance HasRoute UniWorX NavLink where
|
|
-- urlRoute NavLink{..} = urlRoute navRoute
|
|
-- instance RedirectUrl UniWorX NavLink where
|
|
-- toTextUrl NavLink{..} = toTextUrl navRoute
|
|
instance RenderMessage UniWorX NavLink where
|
|
renderMessage app ls NavLink{..} = renderMessage app ls navLabel
|
|
|
|
navBaseRoute :: NavLink -> Route UniWorX
|
|
navBaseRoute NavLink{navRoute} = urlRoute navRoute
|
|
|
|
navLinkRoute :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadCrypto m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
|
)
|
|
=> NavLink -> m (SomeRoute UniWorX)
|
|
navLinkRoute NavLink{..} = case navDownload of
|
|
Nothing -> return $ SomeRoute navRoute
|
|
Just mSource -> withFileDownloadTokenMaybe' (transPipe liftHandler <$> mSource) navRoute
|
|
|
|
data Nav
|
|
= NavHeader
|
|
{ navHeaderRole :: NavHeaderRole
|
|
, navIcon :: Icon
|
|
, navLink :: NavLink
|
|
}
|
|
| NavHeaderContainer
|
|
{ navHeaderRole :: NavHeaderRole
|
|
, navLabel :: SomeMessage UniWorX
|
|
, navIcon :: Icon
|
|
, navChildren :: [NavLink]
|
|
}
|
|
| NavPageActionPrimary
|
|
{ navLink :: NavLink
|
|
, navChildren :: [NavLink]
|
|
}
|
|
| NavPageActionSecondary
|
|
{ navLink :: NavLink
|
|
}
|
|
| NavFooter
|
|
{ navLink :: NavLink
|
|
} deriving (Generic, Typeable)
|
|
|
|
makeLenses_ ''Nav
|
|
makePrisms ''Nav
|
|
|
|
data NavChildren
|
|
type instance Children NavChildren a = ChildrenNavChildren a
|
|
type family ChildrenNavChildren a where
|
|
ChildrenNavChildren (SomeMessage UniWorX) = '[]
|
|
|
|
ChildrenNavChildren a = Children ChGeneric a
|
|
|
|
navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav
|
|
navAccess = execStateT $ do
|
|
guardM $ preuse _navLink >>= maybe (return True) navLinkAccess
|
|
|
|
_navChildren <~ (filterM navLinkAccess =<< use _navChildren)
|
|
whenM (hasn't _navLink <$> use id) $
|
|
guardM $ not . null <$> use _navChildren
|
|
|
|
navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool
|
|
navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute
|
|
where
|
|
shortCircuit :: HandlerContents -> m Bool
|
|
shortCircuit _ = return False
|
|
|
|
accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
|
|
accessCheck nt (urlRoute -> route) = do
|
|
authCtx <- getAuthContext
|
|
$memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
|
|
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
|
|
|
|
defaultLinks :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
|
) => m [Nav]
|
|
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
|
|
[ return NavHeader
|
|
{ navHeaderRole = NavHeaderSecondary
|
|
, navIcon = IconMenuLogout
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuLogout
|
|
, navRoute = AuthR LogoutR
|
|
, navDownload = Nothing
|
|
, navAccess' = is _Just <$> maybeAuthId
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderSecondary
|
|
, navIcon = IconMenuLogin
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuLogin
|
|
, navRoute = AuthR LoginR
|
|
, navDownload = Nothing
|
|
, navAccess' = is _Nothing <$> maybeAuthId
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderSecondary
|
|
, navIcon = IconMenuProfile
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuProfile
|
|
, navRoute = ProfileR
|
|
, navDownload = Nothing
|
|
, navAccess' = 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 = MsgLanguage lang
|
|
, navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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 ])
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuDataProt
|
|
, navRoute = LegalR :#: ("data-protection" :: Text)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuTermsUse
|
|
, navRoute = LegalR :#: ("terms-of-use" :: Text)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuCopyright
|
|
, navRoute = LegalR :#: ("copyright" :: Text)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuImprint
|
|
, navRoute = LegalR :#: ("imprint" :: Text)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuInformation
|
|
, navRoute = InfoR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuFaq
|
|
, navRoute = FaqR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return $ NavFooter NavLink
|
|
{ navLabel = MsgMenuGlossary
|
|
, navRoute = GlossaryR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuNews
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuNews
|
|
, navRoute = NewsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuCourseList
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuCourseList
|
|
, navRoute = CourseListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuCorrections
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuCorrections
|
|
, navRoute = CorrectionsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuExams
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuExamOfficeExams
|
|
, navRoute = ExamOfficeR EOExamsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, do
|
|
(haveInstances, haveWorkflows) <- liftHandler . runDB $ (,)
|
|
<$> haveTopWorkflowInstances
|
|
<*> haveTopWorkflowWorkflows
|
|
|
|
if | haveInstances -> return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuWorkflows
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuTopWorkflowInstanceList
|
|
, navRoute = TopWorkflowInstanceListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
| haveWorkflows -> return NavHeader
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navIcon = IconMenuWorkflows
|
|
, navLink = NavLink
|
|
{ navLabel = MsgMenuTopWorkflowWorkflowListHeader
|
|
, navRoute = TopWorkflowWorkflowListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
| otherwise -> mzero
|
|
, return NavHeaderContainer
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navLabel = SomeMessage MsgAdminHeading
|
|
, navIcon = IconMenuAdmin
|
|
, navChildren =
|
|
[ NavLink
|
|
{ navLabel = MsgMenuUsers
|
|
, navRoute = UsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuSchoolList
|
|
, navRoute = SchoolListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgAdminFeaturesHeading
|
|
, navRoute = AdminFeaturesR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuMessageList
|
|
, navRoute = MessageListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAdminErrMsg
|
|
, navRoute = AdminErrMsgR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAdminTokens
|
|
, navRoute = AdminTokensR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowDefinitionList
|
|
, navRoute = AdminWorkflowDefinitionListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAdminCrontab
|
|
, navRoute = AdminCrontabR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAdminTest
|
|
, navRoute = AdminTestR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
]
|
|
}
|
|
, return NavHeaderContainer
|
|
{ navHeaderRole = NavHeaderPrimary
|
|
, navLabel = SomeMessage (mempty :: Text)
|
|
, navIcon = IconMenuExtra
|
|
, navChildren =
|
|
[ NavLink
|
|
{ navLabel = MsgMenuCourseNew
|
|
, navRoute = CourseNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuExternalExamList
|
|
, navRoute = EExamListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuTermShow
|
|
, navRoute = TermShowR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgMenuAllocationList
|
|
, navRoute = AllocationListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, NavLink
|
|
{ navLabel = MsgInfoLecturerTitle
|
|
, navRoute = InfoLecturerR
|
|
, navDownload = Nothing
|
|
, navAccess' = hasWriteAccessTo CourseNewR
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
]
|
|
}
|
|
]
|
|
|
|
pageActions :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, BearerAuthSite UniWorX
|
|
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
|
)
|
|
=> Route UniWorX -> m [Nav]
|
|
pageActions NewsR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuOpenCourses
|
|
, navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)])
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuOpenAllocations
|
|
, navRoute = (AllocationListR, [("allocations-active", toPathPiece True)])
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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 <- liftHandler . runDBRead $ 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
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 runDBRead $ 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
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 runDBRead $ 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
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 runDBRead $ 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewFavourite
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = tutorialListSecondary
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamList
|
|
, navRoute = CourseR tid ssh csh CExamListR
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
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 runDBRead $ 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewFavourite
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseExamOffice
|
|
, navRoute = CourseR tid ssh csh CExamOfficeR
|
|
, navDownload = Nothing
|
|
, navAccess' = do
|
|
uid <- requireAuthId
|
|
runDBRead $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
E.selectExists $ do
|
|
(_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
|
|
E.where_ $ E.not_ isForced
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseEdit
|
|
, navRoute = CourseR tid ssh csh CEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseClone
|
|
, navRoute = ( CourseNewR
|
|
, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]
|
|
)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseDelete
|
|
, navRoute = CourseR tid ssh csh CDeleteR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
]
|
|
pageActions (ExamOfficeR EOExamsR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamOfficeFields
|
|
, navRoute = ExamOfficeR EOFieldsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamOfficeUsers
|
|
, navRoute = ExamOfficeR EOUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions SchoolListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSchoolNew
|
|
, navRoute = SchoolNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions UsersR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuLecturerInvite
|
|
, navRoute = AdminNewFunctionaryInviteR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuUserAdd
|
|
, navRoute = AdminUserAddR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions (AdminUserR cID) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuUserNotifications
|
|
, navRoute = UserNotificationR cID
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuUserPassword
|
|
, navRoute = UserPasswordR cID
|
|
, navDownload = Nothing
|
|
, navAccess' = do
|
|
uid <- decrypt cID
|
|
User{userAuthentication} <- runDBRead $ get404 uid
|
|
return $ is _AuthPWHash userAuthentication
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions InfoR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgInfoLecturerTitle
|
|
, navRoute = InfoLecturerR
|
|
, navDownload = Nothing
|
|
, navAccess' = hasWriteAccessTo CourseNewR
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuLegal
|
|
, navRoute = LegalR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuFaq
|
|
, navRoute = FaqR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuGlossary
|
|
, navRoute = GlossaryR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions VersionR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgInfoLecturerTitle
|
|
, navRoute = InfoLecturerR
|
|
, navDownload = Nothing
|
|
, navAccess' = hasWriteAccessTo CourseNewR
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuLegal
|
|
, navRoute = LegalR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuFaq
|
|
, navRoute = FaqR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuGlossary
|
|
, navRoute = GlossaryR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions HealthR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuInstance
|
|
, navRoute = InstanceR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions InstanceR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuHealth
|
|
, navRoute = HealthR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions HelpR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuFaq
|
|
, navRoute = FaqR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgInfoLecturerTitle
|
|
, navRoute = InfoLecturerR
|
|
, navDownload = Nothing
|
|
, navAccess' = hasWriteAccessTo CourseNewR
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = do
|
|
(section, navLabel) <-
|
|
[ ("courses", MsgInfoLecturerCourses)
|
|
, ("exercises", MsgInfoLecturerExercises)
|
|
, ("tutorials", MsgInfoLecturerTutorials)
|
|
, ("exams", MsgInfoLecturerExams)
|
|
, ("allocations", MsgInfoLecturerAllocations)
|
|
] :: [(Text, UniWorXMessage)]
|
|
return NavLink
|
|
{ navLabel
|
|
, navRoute = InfoLecturerR :#: section
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuGlossary
|
|
, navRoute = GlossaryR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions ProfileR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuProfileData
|
|
, navRoute = ProfileDataR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAuthPreds
|
|
, navRoute = AuthPredsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgCsvOptions
|
|
, navRoute = CsvOptionsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions TermShowR = do
|
|
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
|
return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTermCreate
|
|
, navRoute = TermEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuParticipantsList
|
|
, navRoute = ParticipantsListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = participantsSecondary
|
|
}
|
|
]
|
|
pageActions (AllocationR tid ssh ash AShowR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationInfo
|
|
, navRoute = InfoAllocationR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationUsers
|
|
, navRoute = AllocationR tid ssh ash AUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationCompute
|
|
, navRoute = AllocationR tid ssh ash AComputeR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions (AllocationR tid ssh ash AUsersR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationPriorities
|
|
, navRoute = AllocationR tid ssh ash APriosR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationCompute
|
|
, navRoute = AllocationR tid ssh ash AComputeR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationAddUser
|
|
, navRoute = AllocationR tid ssh ash AAddUserR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions CourseListR = do
|
|
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
|
return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseNew
|
|
, navRoute = CourseNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAllocationList
|
|
, navRoute = AllocationListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuParticipantsList
|
|
, navRoute = ParticipantsListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = participantsSecondary
|
|
}
|
|
]
|
|
pageActions CourseNewR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgInfoLecturerTitle
|
|
, navRoute = InfoLecturerR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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)
|
|
]
|
|
)
|
|
, navDownload = Nothing
|
|
, navAccess' = do
|
|
muid <- maybeAuthId
|
|
case muid of
|
|
Nothing -> return False
|
|
(Just uid) -> do
|
|
runDBRead . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
|
E.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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
runDBRead . 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
runDBRead . 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseApplications
|
|
, navRoute = CourseR tid ssh csh CApplicationsR
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
let courseWhere course = course <$ do
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
void $ courseWhere course
|
|
courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
|
|
void $ courseWhere course
|
|
return $ course E.^. CourseApplicationsRequired
|
|
courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
|
void $ courseWhere course
|
|
in runDBRead $ courseAllocation `or2M` courseApplications `or2M` existsApplications
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh MaterialListR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuMaterialNew
|
|
, navRoute = CourseR tid ssh csh MaterialNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuMaterialDelete
|
|
, navRoute = CMaterialR tid ssh csh mnm MDelR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
]
|
|
pageActions (CTutorialR tid ssh csh tutn TUsersR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTutorialComm
|
|
, navRoute = CTutorialR tid ssh csh tutn TCommR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTutorialEdit
|
|
, navRoute = CTutorialR tid ssh csh tutn TEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTutorialDelete
|
|
, navRoute = CTutorialR tid ssh csh tutn TDeleteR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamUsers
|
|
, navRoute = CExamR tid ssh csh examn EUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = usersSecondary
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamGrades
|
|
, navRoute = CExamR tid ssh csh examn EGradesR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamCorrect
|
|
, navRoute = CExamR tid ssh csh examn ECorrectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamGrades
|
|
, navRoute = CExamR tid ssh csh examn EGradesR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamEdit
|
|
, navRoute = CExamR tid ssh csh examn EEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamGrades
|
|
, navRoute = CExamR tid ssh csh examn EGradesR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamCorrect
|
|
, navRoute = CExamR tid ssh csh examn ECorrectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExamCorrect
|
|
, navRoute = CExamR tid ssh csh examn ECorrectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
runDBRead . 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
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 runDBRead $ or2M onlyPersonalised hasPersonalised
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSheetEdit
|
|
, navRoute = CSheetR tid ssh csh shn SEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSheetClone
|
|
, navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSheetDelete
|
|
, navRoute = CSheetR tid ssh csh shn SDelR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR
|
|
hasNoSubmission = maybeT (return False) $ do
|
|
uid <- MaybeT $ liftHandler maybeAuthId
|
|
submissions <- lift $ submissionList tid csh shn uid
|
|
guard $ null submissions
|
|
return True
|
|
in runDBRead $ hasNoSubmission `or2M` submissionAccess
|
|
, 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)
|
|
]
|
|
)
|
|
, navDownload = Nothing
|
|
, navAccess' = (== 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgCorrectorAssignTitle
|
|
, navRoute = CSubmissionR tid ssh csh shn cid SubAssignR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSubmissionDelete
|
|
, navRoute = CSubmissionR tid ssh csh shn cid SubDelR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
]
|
|
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgCorrectorAssignTitle
|
|
, navRoute = CSubmissionR tid ssh csh shn cid SubAssignR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuSubmissionDelete
|
|
, navRoute = CSubmissionR tid ssh csh shn cid SubDelR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CApplicationsR) = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseApplicationsFiles
|
|
, navRoute = CourseR tid ssh csh CAppsFilesR
|
|
, navDownload = Just Nothing -- If `navAccess'` is True, we definitely have either exactly one generated file or more than one file
|
|
, navAccess' =
|
|
let appAccess (E.Value appId) = do
|
|
cID <- encrypt appId
|
|
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
|
appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.where_ . E.exists . E.from $ \courseApplicationFile ->
|
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
|
|
return $ courseApplication E.^. CourseApplicationId
|
|
in runDBRead . runConduit $ appSource .| anyMC appAccess
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCourseMembers
|
|
, navRoute = CourseR tid ssh csh CUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' =
|
|
runDBRead $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
exists [ CourseParticipantCourse ==. cid ]
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions CorrectionsR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCorrectionsDownload
|
|
, navRoute = CorrectionsDownloadR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCorrectionsUpload
|
|
, navRoute = CorrectionsUploadR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCorrectionsCreate
|
|
, navRoute = CorrectionsCreateR
|
|
, navDownload = Nothing
|
|
, navAccess' = runDBRead . 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions CorrectionsGradeR = do
|
|
correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR
|
|
return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuCorrections
|
|
, navRoute = CorrectionsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = correctionsSecondary
|
|
}
|
|
]
|
|
pageActions EExamListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamNew
|
|
, navRoute = EExamNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamUsers
|
|
, navRoute = EExamR tid ssh coursen examn EEUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamGrades
|
|
, navRoute = EExamR tid ssh coursen examn EEGradesR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamCorrect
|
|
, navRoute = EExamR tid ssh coursen examn EECorrectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamUsers
|
|
, navRoute = EExamR tid ssh coursen examn EEUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamEdit
|
|
, navRoute = EExamR tid ssh coursen examn EEEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamUsers
|
|
, navRoute = EExamR tid ssh coursen examn EEUsersR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamEdit
|
|
, navRoute = EExamR tid ssh coursen examn EEEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, 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
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamCorrect
|
|
, navRoute = EExamR tid ssh coursen examn EECorrectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuExternalExamEdit
|
|
, navRoute = EExamR tid ssh coursen examn EEEditR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions ParticipantsListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgCsvOptions
|
|
, navRoute = CsvOptionsR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuParticipantsIntersect
|
|
, navRoute = ParticipantsIntersectR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False}
|
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions AdminWorkflowDefinitionListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowDefinitionNew
|
|
, navRoute = AdminWorkflowDefinitionNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowInstanceList
|
|
, navRoute = AdminWorkflowInstanceListR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return
|
|
[ NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowDefinitionDelete
|
|
, navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowDefinitionInstantiate
|
|
, navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = True }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions AdminWorkflowInstanceListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuAdminWorkflowInstanceNew
|
|
, navRoute = AdminWorkflowInstanceNewR
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowWorkflowList
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
|
|
, navDownload = Nothing
|
|
, navAccess' = runDB $ haveWorkflowWorkflows rScope
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _WorkflowScopeRoute = return
|
|
[ NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowInstanceDelete
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowInstanceWorkflows
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
, NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowInstanceInitiate
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute = return
|
|
[ NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowWorkflowEdit
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
, NavPageActionSecondary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuWorkflowWorkflowDelete
|
|
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR)
|
|
, navDownload = Nothing
|
|
, navAccess' = return True
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
}
|
|
]
|
|
pageActions TopWorkflowInstanceListR = return
|
|
[ NavPageActionPrimary
|
|
{ navLink = NavLink
|
|
{ navLabel = MsgMenuTopWorkflowWorkflowList
|
|
, navRoute = TopWorkflowWorkflowListR
|
|
, navDownload = Nothing
|
|
, navAccess' = runDB haveTopWorkflowWorkflows
|
|
, navType = NavTypeLink { navModal = False }
|
|
, navQuick' = mempty
|
|
, navForceActive = False
|
|
}
|
|
, navChildren = []
|
|
}
|
|
]
|
|
pageActions _ = return []
|
|
|
|
submissionList :: ( MonadIO m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> TermId -> CourseShorthand -> SheetName -> UserId -> ReaderT backend m [E.Value SubmissionId]
|
|
submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
|
|
return $ submission E.^. SubmissionId
|
|
|
|
|
|
pageQuickActions :: ( MonadCatch m
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
, BackendCompatible SqlReadBackend (YesodPersistBackend 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
|
|
:: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
|
|
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult
|
|
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
|
|
|
|
|
|
_haveWorkflowInstances, haveWorkflowWorkflows
|
|
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlReadBackend backend
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> RouteWorkflowScope
|
|
-> ReaderT backend m Bool
|
|
_haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
|
scope <- fromRouteWorkflowScope rScope
|
|
|
|
let checkAccess (Entity _ WorkflowInstance{..})
|
|
= hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
|
getInstances = E.selectSource . E.from $ \workflowInstance -> do
|
|
E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
|
return workflowInstance
|
|
|
|
$cachedHereBinary scope . runConduit $ transPipe lift getInstances .| C.mapM checkAccess .| C.or
|
|
haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
|
scope <- fromRouteWorkflowScope rScope
|
|
|
|
let checkAccess (E.Value wwId) = do
|
|
cID <- lift . lift $ encrypt wwId
|
|
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
|
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
|
|
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
|
return $ workflowWorkflow E.^. WorkflowWorkflowId
|
|
|
|
$cachedHereBinary scope . runConduit $ transPipe lift getWorkflows .| C.mapM checkAccess .| C.or
|
|
|
|
haveTopWorkflowInstances, haveTopWorkflowWorkflows
|
|
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlReadBackend backend
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> ReaderT backend m Bool
|
|
haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
|
|
let checkAccess (Entity _ WorkflowInstance{..}) = do
|
|
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
|
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
|
getInstances = selectSource [] []
|
|
isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope
|
|
in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or
|
|
haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
|
|
let checkAccess (Entity wwId WorkflowWorkflow{..}) = do
|
|
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
|
cID <- lift . lift $ encrypt wwId
|
|
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
|
getWorkflows = selectSource [] []
|
|
isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope
|
|
in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or
|