diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index a3677a07c..f8a3dc500 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -83,15 +83,6 @@ instance Yesod UniWorX where Nothing -> getApprootText guessApproot app req Just root -> root - urlParamRenderOverride app route params = do - rApproot <- case authoritiveApproot route of - ApprootDefault -> mzero - rApproot -> return rApproot - guard $ views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app - approotText <- app ^. _appRoot . to ($ rApproot) - let (ps, params') = renderRoute route - return . joinPath app approotText ps $ params ++ params' - makeSessionBackend = UniWorX.makeSessionBackend maximumContentLength app _ = app ^. _appMaximumContentLength diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 43bc50e86..4aaea7262 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -26,7 +26,6 @@ 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 @@ -447,7 +446,6 @@ data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary 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 @@ -466,15 +464,9 @@ instance RenderMessage UniWorX NavLink where 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 - ) +navLinkRoute :: Applicative m => NavLink -> m (SomeRoute UniWorX) -navLinkRoute NavLink{..} = case navDownload of - Nothing -> return $ SomeRoute navRoute - Just mSource -> withFileDownloadTokenMaybe' (transPipe liftHandler <$> mSource) navRoute +navLinkRoute NavLink{..} = pure $ SomeRoute navRoute data Nav = NavHeader @@ -541,7 +533,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogout , navRoute = AuthR LogoutR - , navDownload = Nothing , navAccess' = is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -554,7 +545,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogin , navRoute = AuthR LoginR - , navDownload = Nothing , navAccess' = is _Nothing <$> maybeAuthId , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -567,7 +557,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuProfile , navRoute = ProfileR - , navDownload = Nothing , navAccess' = is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -582,7 +571,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the let navChildren = flip map (toList appLanguages) $ \lang -> NavLink { navLabel = MsgLanguage lang , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeButton { navMethod = POST @@ -609,7 +597,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuHelp , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -619,7 +606,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuDataProt , navRoute = LegalR :#: ("data-protection" :: Text) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -628,7 +614,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuTermsUse , navRoute = LegalR :#: ("terms-of-use" :: Text) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -637,7 +622,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuCopyright , navRoute = LegalR :#: ("copyright" :: Text) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -646,7 +630,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuImprint , navRoute = LegalR :#: ("imprint" :: Text) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -655,7 +638,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuInformation , navRoute = InfoR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -664,7 +646,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -673,7 +654,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -685,7 +665,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuNews , navRoute = NewsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -698,7 +677,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCourseList , navRoute = CourseListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -711,7 +689,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -724,7 +701,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuExamOfficeExams , navRoute = ExamOfficeR EOExamsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -742,7 +718,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowInstanceList , navRoute = TopWorkflowInstanceListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -755,7 +730,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowListHeader , navRoute = TopWorkflowWorkflowListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -771,7 +745,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuUsers , navRoute = UsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -780,7 +753,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuSchoolList , navRoute = SchoolListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -789,7 +761,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgAdminFeaturesHeading , navRoute = AdminFeaturesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -798,7 +769,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuMessageList , navRoute = MessageListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -807,7 +777,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminErrMsg , navRoute = AdminErrMsgR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -816,7 +785,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTokens , navRoute = AdminTokensR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -825,7 +793,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminWorkflowDefinitionList , navRoute = AdminWorkflowDefinitionListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -834,7 +801,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminCrontab , navRoute = AdminCrontabR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -843,7 +809,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTest , navRoute = AdminTestR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -859,7 +824,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -868,7 +832,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuExternalExamList , navRoute = EExamListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -877,7 +840,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuTermShow , navRoute = TermShowR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -886,7 +848,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -895,7 +856,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -917,7 +877,6 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenCourses , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -929,7 +888,6 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenAllocations , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -960,7 +918,6 @@ pageActions (CourseR tid ssh csh CShowR) = do return NavLink { navLabel = examn , navRoute = CExamR tid ssh csh examn EShowR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite @@ -973,7 +930,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { 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 @@ -998,7 +954,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { 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 @@ -1021,7 +976,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { 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 @@ -1044,7 +998,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuTutorialList , navRoute = CourseR tid ssh csh CTutorialListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite @@ -1056,7 +1009,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { 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 @@ -1081,7 +1033,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseCommunication , navRoute = CourseR tid ssh csh CCommR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite @@ -1093,7 +1044,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseExamOffice , navRoute = CourseR tid ssh csh CExamOfficeR - , navDownload = Nothing , navAccess' = do uid <- requireAuthId runDBRead $ do @@ -1110,7 +1060,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseEdit , navRoute = CourseR tid ssh csh CEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1123,7 +1072,6 @@ pageActions (CourseR tid ssh csh CShowR) = do , navRoute = ( CourseNewR , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] ) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1134,7 +1082,6 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseDelete , navRoute = CourseR tid ssh csh CDeleteR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1147,7 +1094,6 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeFields , navRoute = ExamOfficeR EOFieldsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1159,7 +1105,6 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeUsers , navRoute = ExamOfficeR EOUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1173,7 +1118,6 @@ pageActions SchoolListR = return { navLink = NavLink { navLabel = MsgMenuSchoolNew , navRoute = SchoolNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1187,7 +1131,6 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuLecturerInvite , navRoute = AdminNewFunctionaryInviteR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1199,7 +1142,6 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuUserAdd , navRoute = AdminUserAddR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1213,7 +1155,6 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserNotifications , navRoute = UserNotificationR cID - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1225,7 +1166,6 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserPassword , navRoute = UserPasswordR cID - , navDownload = Nothing , navAccess' = do uid <- decrypt cID User{userAuthentication} <- runDBRead $ get404 uid @@ -1242,7 +1182,6 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1254,7 +1193,6 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1266,7 +1204,6 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1278,7 +1215,6 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1292,7 +1228,6 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1304,7 +1239,6 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1316,7 +1250,6 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1328,7 +1261,6 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1342,7 +1274,6 @@ pageActions HealthR = return { navLink = NavLink { navLabel = MsgMenuInstance , navRoute = InstanceR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1356,7 +1287,6 @@ pageActions InstanceR = return { navLink = NavLink { navLabel = MsgMenuHealth , navRoute = HealthR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1370,7 +1300,6 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1382,7 +1311,6 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1399,7 +1327,6 @@ pageActions HelpR = return return NavLink { navLabel , navRoute = InfoLecturerR :#: section - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1410,7 +1337,6 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1424,7 +1350,6 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ProfileDataR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1436,7 +1361,6 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuAuthPreds , navRoute = AuthPredsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1448,7 +1372,6 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1464,7 +1387,6 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuTermCreate , navRoute = TermEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1476,7 +1398,6 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1490,7 +1411,6 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationInfo , navRoute = InfoAllocationR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1502,7 +1422,6 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationUsers , navRoute = AllocationR tid ssh ash AUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1514,7 +1433,6 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1528,7 +1446,6 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationPriorities , navRoute = AllocationR tid ssh ash APriosR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1540,7 +1457,6 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1552,7 +1468,6 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationAddUser , navRoute = AllocationR tid ssh ash AAddUserR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1568,7 +1483,6 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1580,7 +1494,6 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1592,7 +1505,6 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1606,7 +1518,6 @@ pageActions CourseNewR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1620,7 +1531,6 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CourseR tid ssh csh CAssignR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite @@ -1637,7 +1547,6 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return , ("corrections-course", toPathPiece csh) ] ) - , navDownload = Nothing , navAccess' = do muid <- maybeAuthId case muid of @@ -1665,7 +1574,6 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CourseR tid ssh csh CCorrectionsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite @@ -1680,7 +1588,6 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetCurrent , navRoute = CourseR tid ssh csh SheetCurrentR - , navDownload = Nothing , navAccess' = runDBRead . maybeT (return False) $ do void . MaybeT $ sheetCurrent tid ssh csh @@ -1695,7 +1602,6 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetOldUnassigned , navRoute = CourseR tid ssh csh SheetOldUnassignedR - , navDownload = Nothing , navAccess' = runDBRead . maybeT (return False) $ do void . MaybeT $ sheetOldUnassigned tid ssh csh @@ -1712,7 +1618,6 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetNew , navRoute = CourseR tid ssh csh SheetNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite @@ -1726,7 +1631,6 @@ pageActions (CourseR tid ssh csh CUsersR) = return { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -1738,7 +1642,6 @@ pageActions (CourseR tid ssh csh CUsersR) = return { 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 @@ -1766,7 +1669,6 @@ pageActions (CourseR tid ssh csh MaterialListR) = return { navLink = NavLink { navLabel = MsgMenuMaterialNew , navRoute = CourseR tid ssh csh MaterialNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -1780,7 +1682,6 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialEdit , navRoute = CMaterialR tid ssh csh mnm MEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1792,7 +1693,6 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialDelete , navRoute = CMaterialR tid ssh csh mnm MDelR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1805,7 +1705,6 @@ pageActions (CourseR tid ssh csh CTutorialListR) = return { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -1819,7 +1718,6 @@ pageActions (CTutorialR tid ssh csh tutn TEditR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1832,7 +1730,6 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialComm , navRoute = CTutorialR tid ssh csh tutn TCommR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1844,7 +1741,6 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialEdit , navRoute = CTutorialR tid ssh csh tutn TEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1856,7 +1752,6 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1869,7 +1764,6 @@ pageActions (CourseR tid ssh csh CExamListR) = return { navLink = NavLink { navLabel = MsgMenuExamNew , navRoute = CourseR tid ssh csh CExamNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -1886,7 +1780,6 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1898,7 +1791,6 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1910,7 +1802,6 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1922,7 +1813,6 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1936,7 +1826,6 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1948,7 +1837,6 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1960,7 +1848,6 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1973,7 +1860,6 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamAddMembers , navRoute = CExamR tid ssh csh examn EAddUserR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -1985,7 +1871,6 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1997,7 +1882,6 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2011,7 +1895,6 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2023,7 +1906,6 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2039,7 +1921,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CSheetR tid ssh csh shn SSubsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2054,7 +1935,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissionOwn , navRoute = CSheetR tid ssh csh shn SubmissionOwnR - , navDownload = Nothing , navAccess' = runDBRead . maybeT (return False) $ do uid <- MaybeT $ liftHandler maybeAuthId @@ -2073,7 +1953,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { 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 @@ -2100,7 +1979,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetEdit , navRoute = CSheetR tid ssh csh shn SEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2112,7 +1990,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetClone , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2123,7 +2000,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetDelete , navRoute = CSheetR tid ssh csh shn SDelR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2136,7 +2012,6 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { 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 @@ -2161,7 +2036,6 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return , ("corrections-sheet", toPathPiece shn) ] ) - , navDownload = Nothing , navAccess' = (== Authorized) <$> evalAccessCorrector tid ssh csh , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2173,7 +2047,6 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CSheetR tid ssh csh shn SAssignR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2187,7 +2060,6 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { 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 @@ -2199,7 +2071,6 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2211,7 +2082,6 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2224,7 +2094,6 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2236,7 +2105,6 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2249,7 +2117,6 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { 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 @@ -2273,7 +2140,6 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR - , navDownload = Nothing , navAccess' = runDBRead $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh @@ -2290,7 +2156,6 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsDownload , navRoute = CorrectionsDownloadR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2302,7 +2167,6 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsUpload , navRoute = CorrectionsUploadR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2314,7 +2178,6 @@ pageActions CorrectionsR = return { 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 @@ -2339,7 +2202,6 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsGrade , navRoute = CorrectionsGradeR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2355,7 +2217,6 @@ pageActions CorrectionsGradeR = do { navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2369,7 +2230,6 @@ pageActions EExamListR = return { navLink = NavLink { navLabel = MsgMenuExternalExamNew , navRoute = EExamNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2383,7 +2243,6 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2395,7 +2254,6 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2407,7 +2265,6 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2419,7 +2276,6 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2433,7 +2289,6 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2445,7 +2300,6 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2457,7 +2311,6 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2471,7 +2324,6 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2483,7 +2335,6 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2495,7 +2346,6 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2509,7 +2359,6 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2521,7 +2370,6 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2533,7 +2381,6 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2547,7 +2394,6 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2560,7 +2406,6 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgMenuParticipantsIntersect , navRoute = ParticipantsIntersectR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False} , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2574,7 +2419,6 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionNew , navRoute = AdminWorkflowDefinitionNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2586,7 +2430,6 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceList , navRoute = AdminWorkflowInstanceListR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2600,7 +2443,6 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionDelete , navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2611,7 +2453,6 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionInstantiate , navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2625,7 +2466,6 @@ pageActions AdminWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceNew , navRoute = AdminWorkflowInstanceNewR - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2639,7 +2479,6 @@ pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowSc { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowList , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - , navDownload = Nothing , navAccess' = runDB $ haveWorkflowWorkflows rScope , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2653,7 +2492,6 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2664,7 +2502,6 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceWorkflows , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2676,7 +2513,6 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceInitiate , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2690,7 +2526,6 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowEdit , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2701,7 +2536,6 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR) - , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2714,7 +2548,6 @@ pageActions TopWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowList , navRoute = TopWorkflowWorkflowListR - , navDownload = Nothing , navAccess' = runDB haveTopWorkflowWorkflows , navType = NavTypeLink { navModal = False } , navQuick' = mempty diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 8061b6e13..8bb5bb35d 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -31,7 +31,7 @@ yesodMiddleware :: ( BearerAuthSite UniWorX , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) ) => HandlerFor UniWorX res -> HandlerFor UniWorX res -yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware +yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware . normalizeApprootMiddleware where dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a dryRunMiddleware handler = do @@ -135,6 +135,30 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar handler cacheControlMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a cacheControlMiddleware = (addHeader "Vary" "Accept, Accept-Language" *>) + normalizeApprootMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a + normalizeApprootMiddleware handler = maybeT handler $ do + route <- MaybeT getCurrentRoute + reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest + let rApproot = authoritiveApproot route + app <- getYesod + approotHost <- hoistMaybe $ approotScopeHost rApproot app + let doRedirect = do + url <- approotRender rApproot route + $logErrorS "normalizeApprootMiddleware" url + redirect url + if | approotHost /= reqHost + , rApproot /= ApprootUserGenerated + -> doRedirect + | approotHost /= reqHost -> do + resp <- try $ lift handler + $logErrorS "normalizeApprootMiddleware" $ tshow (is _Right resp, preview _Left resp) + case resp of + Right _ -> doRedirect + Left sc | is _HCRedirect sc -> throwM sc + Left _ -> doRedirect + | otherwise -> lift handler + + updateFavourites :: forall m backend. ( MonadHandler m, HandlerSite m ~ UniWorX @@ -175,8 +199,7 @@ routeNormalizers :: forall m backend. , BearerAuthSite UniWorX ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)] routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .) - [ normalizeApproot - , normalizeRender + [ normalizeRender , ncSchool , ncAllocation , ncCourse @@ -195,12 +218,6 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . , verifyMaterialVideo ] where - normalizeApproot route = (route <$) . runMaybeT $ do - reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest - approotHost <- MaybeT . getsYesod . approotScopeHost $ authoritiveApproot route - when (approotHost /= reqHost) $ - tell $ Any True - normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX) normalizeRender route = route <$ do YesodRequest{..} <- liftHandler getRequest diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index ea927ce9e..d740978c3 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/src/Handler/Allocation/AddUser.hs @@ -13,8 +13,6 @@ import qualified Data.Conduit.Combinators as C import qualified Database.Esqueleto as E -import Handler.Course.Show - data AllocationAddUserForm = AllocationAddUserForm { aauUser :: UserId @@ -121,7 +119,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor mApplicationTemplate <- runMaybeT $ do guard hasApplicationTemplate let Course{..} = course - liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR + toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing let appsRes = sequenceA $ view _1 <$> appsRes' appsViews = view _2 <$> appsRes' diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index f2c8bf5b7..2d3cba289 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -141,7 +141,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do hasFiles <- exists [ CourseApplicationFileApplication ==. appId ] appCID <- encrypt appId - appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR + appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR return (hasFiles, appFilesLink) let hasFiles = maybe False (view _1) appFilesInfo diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 9f0c454b0..c5fab129a 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -15,8 +15,6 @@ import Handler.Allocation.Application import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Handler.Course.Show - data NotifyNewCourseButton = BtnNotifyNewCourseForceOn @@ -178,7 +176,7 @@ postAShowR tid ssh ash = do Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR mApplicationTemplate <- runMaybeT $ do guard hasApplicationTemplate - liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR + toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR let mApplyFormView' = view _1 <$> mApplyFormView overrideVisible = not mayApply && is _Just mApp diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index f8982faeb..1a88bfc3c 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -104,7 +104,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do hasFiles <- exists [ CourseApplicationFileApplication ==. appId ] appCID <- encrypt appId - appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR + appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR return (hasFiles, appFilesLink) let hasFiles = maybe False (view _1) appFilesInfo filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index f4e76c66a..0e82bffba 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -25,8 +25,6 @@ import qualified Data.Conduit.List as C import Handler.Exam.List (mkExamTable) -import Handler.Course.News.Download - getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do @@ -80,7 +78,7 @@ getCShowR tid ssh csh = do E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid mApplicationTemplate <- runMaybeT $ do guard hasApplicationTemplate - lift . lift $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource tid ssh csh) $ CourseR tid ssh csh CRegisterTemplateR + lift . lift . toTextUrl $ CourseR tid ssh csh CRegisterTemplateR mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ] cTime <- NTop . Just <$> liftIO getCurrentTime @@ -98,8 +96,8 @@ getCShowR tid ssh csh = do mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR - files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl <=< withFileDownloadToken (cnFileSource nId fPath) . CNewsR tid ssh csh cID $ CNFileR fPath - archiveUrl <- lift . lift $ toTextUrl <=< withFileDownloadToken (cnArchiveSource nId) $ CNewsR tid ssh csh cID CNArchiveR + files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath + archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index dab8e610a..245ebcdb4 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -83,9 +83,8 @@ getMaterialListR tid ssh csh = do let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR - filesLink :: (MonadHandler m, HandlerSite m ~ UniWorX) - => MaterialName -> m (SomeRoute UniWorX) - filesLink mnm = liftHandler . runDB $ withFileDownloadToken (materialArchiveSource tid ssh csh mnm) . CourseR tid ssh csh $ MaterialR mnm MArchiveR + filesLink :: MaterialName -> SomeRoute UniWorX + filesLink mnm = SomeRoute . CourseR tid ssh csh $ MaterialR mnm MArchiveR materialModDateCell :: IsDBTable m a => Material -> DBCell m a materialModDateCell Material{materialVisibleFrom, materialLastEdit} @@ -124,7 +123,7 @@ getMaterialListR tid ssh csh = do , sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles)) $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if | fileNum == 0 -> mempty - | otherwise -> anchorCellM (filesLink materialName) iconFileDownload + | otherwise -> anchorCell (filesLink materialName) iconFileDownload , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) @@ -177,10 +176,10 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html getMVideoR tid ssh csh mnm cID = do mfId <- decrypt cID - mf@MaterialFile{..} <- runDB $ get404 mfId + MaterialFile{..} <- runDB $ get404 mfId let mimeType = mimeLookup $ pack materialFileTitle - mfile <- withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle - let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, mempty) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params) + mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle + let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, toPathPiece True) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params) mfileText <- toTextUrl mfile mfileDownloadText <- toTextUrl mfileDownload unless (mimeType `Set.member` videoTypes) $ @@ -206,7 +205,7 @@ getMShowR tid ssh csh mnm = do seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility (Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do - zipLink <- withFileDownloadToken (materialArchiveSource tid ssh csh mnm) $ CMaterialR tid ssh csh mnm MArchiveR + let zipLink = CMaterialR tid ssh csh mnm MArchiveR matEnt <- fetchMaterial tid ssh csh mnm let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) materialModDateCol = if seeAllModificationTimestamps @@ -220,12 +219,12 @@ getMShowR tid ssh csh mnm = do return matFile , dbtRowKey = (E.^. MaterialFileId) , dbtColonnade = widgetColonnade $ mconcat - [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..}) + [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId MaterialFile{..}) -> let matLink | isVideo - = SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId + = CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId | otherwise - = withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle + = pure . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle wgt = [whamlet| $newline never diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index f6776ebed..bd7afe47a 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -54,10 +54,10 @@ getSheetListR tid ssh csh = do [ icnCell & addIconFixedWidth | let existingSFTs = hasSFT existFiles , sft <- [minBound..maxBound] - , let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh sheetName muid sft) . CSheetR tid ssh csh sheetName $ SZipR sft + , let link = CSheetR tid ssh csh sheetName $ SZipR sft , let icn = toWgt $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs - then linkEitherCellM link (icn, [whamlet| |]) + then linkEitherCell link (icn, [whamlet| |]) else spacerCell ] id & cellAttrs <>~ [("class","list--inline list--space-separated")] , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index da586f4cf..dd84f8cce 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -50,14 +50,14 @@ getSShowR tid ssh csh shn = do ) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype, _) -> - let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh shn muid ftype) . CSheetR tid ssh csh shn $ SZipR ftype + let link = CSheetR tid ssh csh shn $ SZipR ftype in tellCell (Any True) $ - anchorCellM link [whamlet|#{sheetFile2markup ftype} _{ftype}|] + anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|] -- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) - , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,E.Value fMod,E.Value fType, E.Value fRef) -> anchorCellM - (withFileDownloadToken (yield $ FileReference fName fRef fMod) $ CSheetR tid ssh csh shn (SFileR fType fName)) + , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName, _, E.Value fType, _) -> anchorCell + (CSheetR tid ssh csh shn $ SFileR fType fName) (str2widget fName) , sortable (toNothing "visible") (i18nCell MsgVisibleFrom) $ \(_, _ , E.Value ftype, _) -> sftVisible ftype diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index c06eb0fd7..47d8c915e 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -17,8 +17,6 @@ import qualified Control.Monad.State.Class as State import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Handler.Submission.Download - correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do @@ -146,7 +144,7 @@ postCorrectionR tid ssh csh shn cid = do |] siteLayout headingWgt $ do setTitleI heading - urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource tid ssh csh shn cid SubmissionCorrected) . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected + urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound @@ -159,6 +157,6 @@ getCorrectionUserR tid ssh csh shn cid = do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment in defaultLayout $ do - urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource courseTerm courseSchool courseShorthand sheetName cid SubmissionCorrected) . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected + urlArchive <- toTextUrl . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected $(widgetFile "correction-user") _ -> notFound diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 30a2b3fca..d74316405 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -27,8 +27,6 @@ import Text.Blaze (Markup) import qualified Data.Aeson.Types as JSON import Data.Aeson.Lens - -import Handler.Submission.Download import Handler.Submission.SubmissionUserInvite @@ -491,12 +489,12 @@ submissionHelper tid ssh csh shn mcid = do corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr Just isFile = origIsFile <|> corrIsFile in if - | Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] + | Just True <- origIsFile -> anchorCell (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of Nothing -> cell mempty Just (Entity _ SubmissionFile{..}) - | isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget) + | isJust submissionFileContent -> anchorCell (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget) | otherwise -> i18nCell MsgCorrected , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let origTime = submissionFileModified . entityVal <$> mOrig @@ -504,8 +502,7 @@ submissionHelper tid ssh csh shn mcid = do Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in dateTimeCell fileTime ] - subDownloadLink :: _ -> _ -> _ -> WidgetFor UniWorX _ - subDownloadLink cid sft fileTitle' = liftHandler . runDB . withFileDownloadToken (subDownloadSource tid ssh csh shn cid sft fileTitle') . CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle' + subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle' submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle @@ -555,7 +552,7 @@ submissionHelper tid ssh csh shn mcid = do defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID - -> let mkUrl sft = toTextUrl <=< withFileDownloadToken' (subArchiveSource tid ssh csh shn cID sft) . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft + -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs index 2d1d4738d..ef971ba6d 100644 --- a/src/Handler/Utils/ContentDisposition.hs +++ b/src/Handler/Utils/ContentDisposition.hs @@ -18,6 +18,6 @@ downloadFiles = do setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Maybe FilePath -> m () setContentDisposition' mFileName = do - wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles + wantsDownload <- maybeT downloadFiles . MaybeT $ lookupGlobalGetParam GetDownload setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index f3b48a96c..40e2c78d2 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -1,6 +1,5 @@ module Handler.Utils.Download - ( withFileDownloadTokenMaybe', withFileDownloadToken, withFileDownloadToken' - , sendThisFile + ( sendThisFile , sendFileReference , serveOneFile , serveSomeFiles @@ -22,6 +21,8 @@ import Handler.Utils.Zip import Handler.Utils.ContentDisposition import Handler.Utils.Files +import qualified Network.Wai as W + data DownloadTokenRestriction = DownloadRestrictSingle { downloadRestrictReference :: FileContentReference } @@ -70,55 +71,90 @@ withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ encodedBearer <- lift $ encodeBearer bearer lift . setDownload $ SomeRoute @UniWorX route - & over (urlRouteParams $ Proxy @UniWorX) ((toPathPiece GetBearer, toPathPiece encodedBearer) :) + & over (urlRouteParams $ Proxy @UniWorX) (((toPathPiece GetBearer, toPathPiece encodedBearer) :) . filter (views _1 (maybe False (/= GetBearer) . fromPathPiece))) where setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX) setDownload route' = do wantsDownload <- downloadFiles + defWantsDownload <- getsYesod $ views _appUserDefaults userDefaultDownloadFiles + let + addDownload params + | anyOf (folded . _1) (== toPathPiece GetDownload) params = params + | otherwise = (toPathPiece GetDownload, toPathPiece wantsDownload) : params return $ route' - & over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload wantsDownload) - where - addDownload params | anyOf (folded . _1) (== toPathPiece GetDownload) params = params - | otherwise = (toPathPiece GetDownload, mempty) : params + & over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload $ wantsDownload /= defWantsDownload) -withFileDownloadToken' :: forall file url m. - ( HasFileReference file - , HasRoute UniWorX url - , MonadHandler m, HandlerSite m ~ UniWorX - , MonadCrypto m - , MonadCryptoKey m ~ CryptoIDKey - , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId - ) - => ConduitT () (Either file DBFile) m () - -> url - -> m (SomeRoute UniWorX) -withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1)) +-- withFileDownloadToken' :: forall file url m. +-- ( HasFileReference file +-- , HasRoute UniWorX url +-- , MonadHandler m, HandlerSite m ~ UniWorX +-- , MonadCrypto m +-- , MonadCryptoKey m ~ CryptoIDKey +-- , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId +-- ) +-- => ConduitT () (Either file DBFile) m () +-- -> url +-- -> m (SomeRoute UniWorX) +-- withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1)) -withFileDownloadToken :: forall file url m. - ( HasFileReference file - , HasRoute UniWorX url - , MonadHandler m, HandlerSite m ~ UniWorX - , MonadCrypto m - , MonadCryptoKey m ~ CryptoIDKey - , BearerAuthSite UniWorX - ) - => ConduitT () file m () - -> url - -> m (SomeRoute UniWorX) -withFileDownloadToken = withFileDownloadToken' . (.| C.map Left) +-- withFileDownloadToken :: forall file url m. +-- ( HasFileReference file +-- , HasRoute UniWorX url +-- , MonadHandler m, HandlerSite m ~ UniWorX +-- , MonadCrypto m +-- , MonadCryptoKey m ~ CryptoIDKey +-- , BearerAuthSite UniWorX +-- ) +-- => ConduitT () file m () +-- -> url +-- -> m (SomeRoute UniWorX) +-- withFileDownloadToken = withFileDownloadToken' . (.| C.map Left) + +ensureApprootUserGeneratedMaybe' + :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadCrypto m + , MonadCryptoKey m ~ CryptoIDKey + , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId + ) + => Maybe (ConduitT () (Either FileReference DBFile) m ()) + -> m () +ensureApprootUserGeneratedMaybe' source = maybeT (return ()) $ do + route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest + $logErrorS "ensureApproot" $ tshow route + rApproot <- hoistMaybe <=< lift . runMaybeT $ do + reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest + let rApproot = authoritiveApproot $ urlRoute route + guard $ rApproot == ApprootUserGenerated + approotHost <- MaybeT . getsYesod $ approotScopeHost rApproot + guard $ approotHost /= reqHost + return rApproot + $logErrorS "ensureApproot" $ tshow rApproot + route' <- lift $ withFileDownloadTokenMaybe' source route + url <- approotRender rApproot route' + $logErrorS "ensureApprootUserGenerated" url + redirect url + -- | Simply send a `File`-Value -sendThisFile :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId, YesodPersistRunner UniWorX) => DBFile -> HandlerFor UniWorX TypedContent -sendThisFile File{..} - | Just fileContent' <- fileContent = do - setCSPSandbox - setContentDisposition' . Just $ takeFileName fileTitle - let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8" - respondSourceDB cType $ - fileContent' .| C.map toFlushBuilder - | otherwise = sendResponseStatus noContent204 () +sendThisFile :: ( YesodAuthPersist UniWorX + , AuthEntity UniWorX ~ User + , AuthId UniWorX ~ UserId + , YesodPersistRunner UniWorX + , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey + ) => DBFile -> HandlerFor UniWorX TypedContent +sendThisFile File{..} = do + ensureApprootUserGeneratedMaybe' Nothing + if + | Just fileContent' <- fileContent -> do + setCSPSandbox + setContentDisposition' . Just $ takeFileName fileTitle + let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8" + respondSourceDB cType $ + fileContent' .| C.map toFlushBuilder + | otherwise -> sendResponseStatus noContent204 () sendFileReference :: forall file a. ( HasFileReference file @@ -128,6 +164,7 @@ sendFileReference :: forall file a. ) => file -> HandlerFor UniWorX a sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do + ensureApprootUserGeneratedMaybe' . Just . yield $ Left fRef whenIsJust fileReferenceContent $ \fRef' -> do dlRestr <- maybeCurrentBearerRestrictions case dlRestr of @@ -146,6 +183,7 @@ serveOneFile :: forall file. ) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent serveOneFile source = do results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below + ensureApprootUserGeneratedMaybe' . Just . yieldMany $ map (views (_FileReference . _1) Left) results case results of [file] -> sendFileReference file [] -> notFound @@ -172,6 +210,7 @@ serveSomeFiles' :: forall file. ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent serveSomeFiles' archiveName source = do (source', results) <- runDB $ runPeekN 2 source + ensureApprootUserGeneratedMaybe' . Just . yieldMany $ over (traverse . _Left) (view $ _FileReference . _1) results $logDebugS "serveSomeFiles" . tshow $ length results diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 50a4e8d5f..73b6cacae 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -25,7 +25,6 @@ import Handler.Utils.Form import Handler.Utils.Widgets import Handler.Utils.DateTime import Handler.Utils.StudyFeatures -import Handler.Utils.Download import qualified Data.CaseInsensitive as CI @@ -376,7 +375,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body | showLink -> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do cID <- encrypt appId - liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR + return $ CApplicationR tid ssh csh cID CAFilesR | otherwise -> mempty diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 28b4ac29a..a5fbaea8d 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -60,22 +60,6 @@ data WorkflowCurrentState = WorkflowCurrentState makePrisms ''WorkflowHistoryItemActor' -data OneOrMany a = None | One a | Many - deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable) - -instance Semigroup (OneOrMany a) where - None <> x = x - x <> None = x - _ <> _ = Many -instance Monoid (OneOrMany a) where - mempty = None - -oneOrMany :: b -> (a -> b) -> b -> OneOrMany a -> b -oneOrMany onNone onOne onMany = \case - None -> onNone - One x -> onOne x - Many -> onMany - getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html getGWWWorkflowR = postGWWWorkflowR @@ -198,13 +182,13 @@ workflowR rScope cID = do <> (compareUnicode `on` userDisplayName) uA uB <> comparing userIdent uA uB (WFPUser{}, _ ) -> GT - forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl <=< oneOrMany (return Nothing) (\fRef -> Just <$> withFileDownloadToken (yield fRef) fRoute) (Just <$> withFileDownloadTokenMaybe' Nothing fRoute)) <=< execWriterT @_ @(_, OneOrMany FileReference). forM_ payloads $ \case - WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t) - WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) - WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) - WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) - WorkflowFieldPayloadW (WFPFile fRef) -> tell (mempty, One fRef) - WorkflowFieldPayloadW (WFPUser uid ) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid) + forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any). forM_ payloads $ \case + WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t) + WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) + WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) + WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) + WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True) + WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid) payloadChanges <- State.state $ \oldPayload -> ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload diff --git a/src/Utils/Approot.hs b/src/Utils/Approot.hs index 751207819..7509efbec 100644 --- a/src/Utils/Approot.hs +++ b/src/Utils/Approot.hs @@ -1,18 +1,44 @@ module Utils.Approot - ( approotScopeHost + ( approotScopeHost, approotScopeBaseUrl, approotScopeHost' + , approotRender ) where -import ClassyPrelude +import ClassyPrelude.Yesod hiding (Proxy) import Settings +import Utils.Route + +import Network.URI (URI(URI), URIAuth(URIAuth)) import qualified Network.URI as URI import Control.Lens +import Data.Proxy -approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString -approotScopeHost rApproot app = do + +approotScopeHost' :: HasAppSettings site => (URI -> URIAuth -> a) -> ApprootScope -> site -> Maybe a +approotScopeHost' f rApproot app = do approotText <- views _appRoot ($ rApproot) app approotURI <- URI.parseURI $ unpack approotText approotAuthority <- URI.uriAuthority approotURI - return . encodeUtf8 . pack $ URI.uriRegName approotAuthority <> URI.uriPort approotAuthority + return $ f approotURI approotAuthority + +approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString +approotScopeHost = approotScopeHost' $ \_ URIAuth{..} + -> encodeUtf8 . pack $ uriRegName <> uriPort + +approotScopeBaseUrl :: HasAppSettings site => ApprootScope -> site -> Maybe Text +approotScopeBaseUrl = approotScopeHost' $ \URI{..} URIAuth{..} + -> pack $ uriScheme <> "//" <> uriRegName <> uriPort + +approotRender :: forall url m. + ( HasAppSettings (HandlerSite m) + , MonadHandler m + , Yesod (HandlerSite m) + , HasRoute (HandlerSite m) url + ) + => ApprootScope -> url -> m Text +approotRender rApproot route = do + app <- getYesod + approotHost <- maybe (getApprootText approot app <$> waiRequest) return $ approotScopeBaseUrl rApproot app + return . yesodRender app approotHost (urlRoute route) . withLens (urlRouteParams (Proxy @(HandlerSite m))) $ \g _ -> g route diff --git a/src/Utils/Route.hs b/src/Utils/Route.hs index 047687442..a9bf4487f 100644 --- a/src/Utils/Route.hs +++ b/src/Utils/Route.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE UndecidableInstances #-} + module Utils.Route where import Control.Lens -import ClassyPrelude.Yesod -- hiding (foldlM) +import ClassyPrelude.Yesod hiding (Proxy) import Data.Kind (Type) import qualified Data.Map as Map +import Data.Proxy class RedirectUrl site url => HasRoute site url where @@ -46,3 +49,5 @@ instance HasRoute site (SomeRoute site) where type RouteWithParams site (SomeRoute site) = SomeRoute site urlRoute (SomeRoute url) = urlRoute url urlRouteParams pSite = lens (\(SomeRoute url) -> withLens (urlRouteParams pSite) $ \g _ -> g url) (\(SomeRoute url) params -> SomeRoute (urlRoute url :: Route site, params)) +instance Eq (Route site) => Eq (SomeRoute site) where + (==) = (==) `on` (\(SomeRoute r) -> withLens (urlRouteParams $ Proxy @site) $ \g _ -> (urlRoute r :: Route site, sort $ g r))