diff --git a/config/settings.yml b/config/settings.yml index 9c4060e61..4cf98ef99 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -249,3 +249,5 @@ token-buckets: initial-value: 0 fallback-personalised-sheet-files-keys-expire: 2419200 + +download-token-expire: 14400 diff --git a/load/Load.hs b/load/Load.hs index 7c0020ca4..1f8bcb1e0 100644 --- a/load/Load.hs +++ b/load/Load.hs @@ -367,5 +367,5 @@ sheetZipURI :: ReaderT SimulationContext IO URI sheetZipURI = do LoadOptions{..} <- asks loadOptions let zipURI = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : zipPath } - where (zipPath, _) = renderRoute . CSheetR loadTerm loadSchool loadCourse loadSheet $ SZipR SheetExercise + where (zipPath, _) = renderRoute . CSheetR loadTerm loadSchool loadCourse loadSheet $ SZipR SheetExercise -- FIXME: Broken with ApprootUserGenerated return $ zipURI `relativeTo` loadBaseURI diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 7288730c6..50a124c2d 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -466,6 +466,7 @@ UnauthorizedTokenInvalidNoAuthority: Ihr Authorisierungs-Token nennt keine Nutze UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert. UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert. UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte. +UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer auszugeben, dies ist jedoch nicht allen Benutzern, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index e2ed32e5f..f7a9ef2c5 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -463,6 +463,7 @@ UnauthorizedTokenInvalidNoAuthority: Your authorisation-token does not list any UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore. UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore. UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted. +UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. diff --git a/src/Data/Universe/Instances/Reverse/JSON.hs b/src/Data/Universe/Instances/Reverse/JSON.hs index 8aed56f14..e4ce07a11 100644 --- a/src/Data/Universe/Instances/Reverse/JSON.hs +++ b/src/Data/Universe/Instances/Reverse/JSON.hs @@ -22,8 +22,11 @@ instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF] instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where - parseJSON val = do - vMap <- parseJSON val :: Parser (HashMap a b) - unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ - fail "Not all required keys found" - return (vMap !) + parseJSON val = asObject <|> asConst + where + asObject = do + vMap <- parseJSON val :: Parser (HashMap a b) + unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ + fail "Not all required keys found" + return (vMap !) + asConst = const <$> parseJSON val diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index ca773c059..55c83c173 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -17,6 +17,7 @@ module Foundation.Authorization , evalWorkflowRoleFor, evalWorkflowRoleFor' , hasWorkflowRole , mayViewWorkflowAction + , authoritiveApproot ) where import Import.NoFoundation hiding (Last(..)) @@ -218,15 +219,32 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val where validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do - guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) + iforM_ bearerRoutes $ \case + BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute + BearerTokenRouteAccess -> \routes -> maybeTMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidRoute) $ do + cRoute <- MaybeT getCurrentRoute + guard $ HashSet.member cRoute routes bearerAuthority' <- flip foldMapM bearerAuthority $ \case Left tVal - | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do - Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active - return $ Set.singleton userGroupMemberUser + | JSON.Success groupName <- JSON.fromJSON tVal -> do + Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active + case bearerImpersonate of + Nothing -> return . Set.singleton $ userGroupMemberUser primary + Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary + | otherwise -> do + unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $ + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation + return $ Set.singleton iuid | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue - Right uid -> return $ Set.singleton uid + Right uid -> case bearerImpersonate of + Just iuid | uid == iuid -> return $ Set.singleton uid + | otherwise -> do + cID <- encrypt iuid + unlessM (is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $ + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation + return $ Set.singleton iuid + Nothing -> return $ Set.singleton uid let -- Prevent infinite loops @@ -269,7 +287,7 @@ requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX => m (BearerToken UniWorX) requireBearerToken = liftHandler $ do bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe - mAuthId <- maybeAuthId + mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute isWrite <- isWriteRequest currentRoute guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer @@ -1726,3 +1744,19 @@ mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBack lift $ anyM wpvViewers evalWorkflowRole' ] return True + +authoritiveApproot :: Route UniWorX -> ApprootScope +authoritiveApproot = \case + CourseR _ _ _ (MaterialR _ (MFileR _)) -> ApprootUserGenerated + CourseR _ _ _ (MaterialR _ MArchiveR) -> ApprootUserGenerated + CourseR _ _ _ (SheetR _ (SFileR _ _)) -> ApprootUserGenerated + CourseR _ _ _ (SheetR _ (SZipR _)) -> ApprootUserGenerated + CourseR _ _ _ (SheetR _ (SubmissionR _ (SubDownloadR _ _))) -> ApprootUserGenerated + CourseR _ _ _ (SheetR _ (SubmissionR _ (SubArchiveR _))) -> ApprootUserGenerated + CourseR _ _ _ (CourseNewsR _ (CNFileR _)) -> ApprootUserGenerated + CourseR _ _ _ (CourseNewsR _ CNArchiveR) -> ApprootUserGenerated + CourseR _ _ _ CRegisterTemplateR -> ApprootUserGenerated + CourseR _ _ _ CAppsFilesR -> ApprootUserGenerated + CourseR _ _ _ (CourseApplicationR _ CAFilesR) -> ApprootUserGenerated + route | Just (_, WorkflowWorkflowR _ (WWFilesR _ _)) <- route ^? _WorkflowScopeRoute -> ApprootUserGenerated + _other -> ApprootDefault diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 362af9d60..8159bcb00 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -79,10 +79,19 @@ instance Yesod UniWorX where -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot approot = ApprootRequest $ \app req -> - case app ^. _appRoot of + case app ^. _appRoot . to ($ ApprootDefault) of 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 @@ -181,6 +190,11 @@ instance YesodAuth UniWorX where _other -> Auth.germanMessage where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls + maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId + where authIdFromBearer = do + BearerToken{..} <- MaybeT maybeBearerToken + hoistMaybe bearerImpersonate + instance YesodAuthPersist UniWorX where getAuthEntity = liftHandler . runDBRead . get diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 64f4a3466..42e7d3e56 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -7,6 +7,7 @@ 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 @@ -25,6 +26,7 @@ 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 @@ -427,6 +429,7 @@ 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 @@ -435,13 +438,26 @@ data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX ro makeLenses_ ''NavLink -instance HasRoute UniWorX NavLink where - urlRoute NavLink{..} = urlRoute navRoute -instance RedirectUrl UniWorX NavLink where - toTextUrl NavLink{..} = toTextUrl navRoute +-- 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 @@ -507,6 +523,7 @@ 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 @@ -519,6 +536,7 @@ 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 @@ -531,6 +549,7 @@ 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 @@ -545,6 +564,7 @@ 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 @@ -571,6 +591,7 @@ 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 @@ -580,6 +601,7 @@ 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 @@ -588,6 +610,7 @@ 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 @@ -596,6 +619,7 @@ 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 @@ -604,6 +628,7 @@ 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 @@ -612,6 +637,7 @@ 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 @@ -620,6 +646,7 @@ 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 @@ -628,6 +655,7 @@ 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 @@ -639,6 +667,7 @@ 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 @@ -651,6 +680,7 @@ 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 @@ -663,6 +693,7 @@ 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 @@ -675,6 +706,7 @@ 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 @@ -692,6 +724,7 @@ 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 @@ -704,6 +737,7 @@ 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 @@ -719,6 +753,7 @@ 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 @@ -727,6 +762,7 @@ 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 @@ -735,6 +771,7 @@ 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 @@ -743,6 +780,7 @@ 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 @@ -751,6 +789,7 @@ 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 @@ -759,6 +798,7 @@ 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 @@ -767,6 +807,7 @@ 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 @@ -775,6 +816,7 @@ 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 @@ -783,6 +825,7 @@ 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 @@ -798,6 +841,7 @@ 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 @@ -806,6 +850,7 @@ 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 @@ -814,6 +859,7 @@ 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 @@ -822,6 +868,7 @@ 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 @@ -830,6 +877,7 @@ 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 @@ -851,6 +899,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenCourses , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -862,6 +911,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenAllocations , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -892,6 +942,7 @@ 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 @@ -904,6 +955,7 @@ 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 @@ -928,6 +980,7 @@ 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 @@ -950,6 +1003,7 @@ 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 @@ -972,6 +1026,7 @@ 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 @@ -983,6 +1038,7 @@ 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 @@ -1007,6 +1063,7 @@ 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 @@ -1018,6 +1075,7 @@ 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 @@ -1034,6 +1092,7 @@ 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 @@ -1046,6 +1105,7 @@ 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 @@ -1056,6 +1116,7 @@ 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 @@ -1068,6 +1129,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeFields , navRoute = ExamOfficeR EOFieldsR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1079,6 +1141,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeUsers , navRoute = ExamOfficeR EOUsersR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1092,6 +1155,7 @@ pageActions SchoolListR = return { navLink = NavLink { navLabel = MsgMenuSchoolNew , navRoute = SchoolNewR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1105,6 +1169,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuLecturerInvite , navRoute = AdminNewFunctionaryInviteR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1116,6 +1181,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuUserAdd , navRoute = AdminUserAddR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1129,6 +1195,7 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserNotifications , navRoute = UserNotificationR cID + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1140,6 +1207,7 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserPassword , navRoute = UserPasswordR cID + , navDownload = Nothing , navAccess' = do uid <- decrypt cID User{userAuthentication} <- runDBRead $ get404 uid @@ -1156,6 +1224,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR + , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1167,6 +1236,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1178,6 +1248,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1189,6 +1260,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1202,6 +1274,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR + , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1213,6 +1286,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1224,6 +1298,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1235,6 +1310,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1248,6 +1324,7 @@ pageActions HealthR = return { navLink = NavLink { navLabel = MsgMenuInstance , navRoute = InstanceR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1261,6 +1338,7 @@ pageActions InstanceR = return { navLink = NavLink { navLabel = MsgMenuHealth , navRoute = HealthR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1274,6 +1352,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1285,6 +1364,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR + , navDownload = Nothing , navAccess' = hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1301,6 +1381,7 @@ pageActions HelpR = return return NavLink { navLabel , navRoute = InfoLecturerR :#: section + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1311,6 +1392,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1324,6 +1406,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ProfileDataR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1335,6 +1418,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuAuthPreds , navRoute = AuthPredsR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1346,6 +1430,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1361,6 +1446,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuTermCreate , navRoute = TermEditR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1372,6 +1458,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1385,6 +1472,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationInfo , navRoute = InfoAllocationR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1396,6 +1484,7 @@ 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 @@ -1407,6 +1496,7 @@ 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 @@ -1420,6 +1510,7 @@ 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 @@ -1431,6 +1522,7 @@ 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 @@ -1442,6 +1534,7 @@ 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 @@ -1457,6 +1550,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1468,6 +1562,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1479,6 +1574,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1492,6 +1588,7 @@ pageActions CourseNewR = return { navLink = NavLink { navLabel = MsgInfoLecturerTitle , navRoute = InfoLecturerR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1505,6 +1602,7 @@ 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 @@ -1521,6 +1619,7 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return , ("corrections-course", toPathPiece csh) ] ) + , navDownload = Nothing , navAccess' = do muid <- maybeAuthId case muid of @@ -1548,6 +1647,7 @@ 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 @@ -1562,6 +1662,7 @@ 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 @@ -1576,6 +1677,7 @@ 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 @@ -1592,6 +1694,7 @@ 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 @@ -1605,6 +1708,7 @@ 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 @@ -1616,6 +1720,7 @@ 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 @@ -1643,6 +1748,7 @@ 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 @@ -1656,6 +1762,7 @@ 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 @@ -1667,6 +1774,7 @@ 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 @@ -1679,6 +1787,7 @@ 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 @@ -1692,6 +1801,7 @@ 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 @@ -1704,6 +1814,7 @@ 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 @@ -1715,6 +1826,7 @@ 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 @@ -1726,6 +1838,7 @@ 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 @@ -1738,6 +1851,7 @@ 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 @@ -1754,6 +1868,7 @@ 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 @@ -1765,6 +1880,7 @@ 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 @@ -1776,6 +1892,7 @@ 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 @@ -1787,6 +1904,7 @@ 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 @@ -1800,6 +1918,7 @@ 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 @@ -1811,6 +1930,7 @@ 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 @@ -1822,6 +1942,7 @@ 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 @@ -1834,6 +1955,7 @@ 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 @@ -1845,6 +1967,7 @@ 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 @@ -1856,6 +1979,7 @@ 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 @@ -1869,6 +1993,7 @@ 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 @@ -1880,6 +2005,7 @@ 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 @@ -1895,6 +2021,7 @@ 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 @@ -1909,6 +2036,7 @@ 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 @@ -1927,6 +2055,7 @@ 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 @@ -1953,6 +2082,7 @@ 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 @@ -1964,6 +2094,7 @@ 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 @@ -1974,6 +2105,7 @@ 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 @@ -1986,6 +2118,7 @@ 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 @@ -2010,6 +2143,7 @@ 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 @@ -2021,6 +2155,7 @@ 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 @@ -2034,6 +2169,7 @@ 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 @@ -2045,6 +2181,7 @@ 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 @@ -2056,6 +2193,7 @@ 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 @@ -2068,6 +2206,7 @@ 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 @@ -2079,6 +2218,7 @@ 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 @@ -2091,6 +2231,7 @@ 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 @@ -2114,6 +2255,7 @@ 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 @@ -2130,6 +2272,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsDownload , navRoute = CorrectionsDownloadR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2141,6 +2284,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsUpload , navRoute = CorrectionsUploadR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2152,6 +2296,7 @@ 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 @@ -2176,6 +2321,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsGrade , navRoute = CorrectionsGradeR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2191,6 +2337,7 @@ pageActions CorrectionsGradeR = do { navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2204,6 +2351,7 @@ pageActions EExamListR = return { navLink = NavLink { navLabel = MsgMenuExternalExamNew , navRoute = EExamNewR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2217,6 +2365,7 @@ 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 @@ -2228,6 +2377,7 @@ 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 @@ -2239,6 +2389,7 @@ 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 @@ -2250,6 +2401,7 @@ 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 @@ -2263,6 +2415,7 @@ 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 @@ -2274,6 +2427,7 @@ 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 @@ -2285,6 +2439,7 @@ 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 @@ -2298,6 +2453,7 @@ 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 @@ -2309,6 +2465,7 @@ 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 @@ -2320,6 +2477,7 @@ 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 @@ -2333,6 +2491,7 @@ 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 @@ -2344,6 +2503,7 @@ 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 @@ -2355,6 +2515,7 @@ 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 @@ -2368,6 +2529,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgCsvOptions , navRoute = CsvOptionsR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -2380,6 +2542,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgMenuParticipantsIntersect , navRoute = ParticipantsIntersectR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False} , navQuick' = navQuick NavQuickViewPageActionSecondary @@ -2393,6 +2556,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionNew , navRoute = AdminWorkflowDefinitionNewR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2404,6 +2568,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceList , navRoute = AdminWorkflowInstanceListR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2417,6 +2582,7 @@ 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 @@ -2427,6 +2593,7 @@ 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 @@ -2440,6 +2607,7 @@ pageActions AdminWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceNew , navRoute = AdminWorkflowInstanceNewR + , navDownload = Nothing , navAccess' = return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2453,6 +2621,7 @@ 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 @@ -2466,6 +2635,7 @@ 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 @@ -2476,6 +2646,7 @@ 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 @@ -2487,6 +2658,7 @@ 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 @@ -2500,6 +2672,7 @@ 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 @@ -2510,6 +2683,7 @@ 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 @@ -2522,6 +2696,7 @@ 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/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 6c39decf0..279e9d66f 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -192,7 +192,7 @@ siteLayout' overrideHeading widget = do . observeFavouritesQuickActionsDuration $ do $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." items' <- pageQuickActions NavQuickViewFavourite courseRoute - items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n + items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) @@ -203,7 +203,7 @@ siteLayout' overrideHeading widget = do , maybe (return []) pageActions mcurrentRoute ] nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' - nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren) + nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren) mmsgs <- if | isModal -> return mempty @@ -225,9 +225,9 @@ siteLayout' overrideHeading widget = do -- ^ highlight last route in breadcrumbs, favorites taking priority highlight = (highR ==) . Just . urlRoute where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents - navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav + navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to navBaseRoute) nav highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs - highlightNav = (||) <$> navForceActive <*> highlight + highlightNav = (||) <$> navForceActive <*> (highlight . navBaseRoute) favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)] favouriteTermReason tid favReason' = favourites & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason') @@ -243,15 +243,16 @@ siteLayout' overrideHeading widget = do navWidget (n, navIdent, navRoute', navChildren') = case n of NavHeader{ navLink = navLink@NavLink{..}, .. } | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just navIdent - , modalId = Nothing - , modalTrigger = \mroute ident -> case mroute of - Just route -> $(widgetFile "widgets/navbar/item") - Nothing -> error "navWidget with non-link modal" - , modalContent = Left $ SomeRoute navLink - } + , navModal -> do + modalContent <- liftHandler $ Left <$> navLinkRoute navLink + customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/navbar/item") + Nothing -> error "navWidget with non-link modal" + , modalContent + } | NavTypeLink{} <- navType -> let route = navRoute' ident = navIdent @@ -259,14 +260,15 @@ siteLayout' overrideHeading widget = do NavPageActionPrimary{ navLink = navLink@NavLink{..} } -> let pWidget | NavTypeLink{..} <- navType - , navModal - = customModal Modal + , navModal = do + modalContent <- liftHandler $ Left <$> navLinkRoute navLink + customModal Modal { modalTriggerId = Just navIdent , modalId = Nothing , modalTrigger = \mroute ident -> case mroute of Just route -> $(widgetFile "widgets/pageaction/primary") Nothing -> error "navWidget with non-link modal" - , modalContent = Left $ SomeRoute navLink + , modalContent } | NavTypeLink{} <- navType = let route = navRoute' @@ -279,15 +281,16 @@ siteLayout' overrideHeading widget = do in $(widgetFile "widgets/pageaction/primary-wrapper") NavPageActionSecondary{ navLink = navLink@NavLink{..} } | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just navIdent - , modalId = Nothing - , modalTrigger = \mroute ident -> case mroute of - Just route -> $(widgetFile "widgets/pageaction/secondary") - Nothing -> error "navWidget with non-link modal" - , modalContent = Left $ SomeRoute navLink - } + , navModal -> do + modalContent <- liftHandler $ Left <$> navLinkRoute navLink + customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/pageaction/secondary") + Nothing -> error "navWidget with non-link modal" + , modalContent + } | NavTypeLink{} <- navType -> let route = navRoute' ident = navIdent @@ -307,25 +310,27 @@ siteLayout' overrideHeading widget = do navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of NavHeaderContainer{} | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just iNavIdent - , modalId = Nothing - , modalTrigger = \mroute ident -> case mroute of - Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link") - Nothing -> error "navWidget with non-link modal" - , modalContent = Left $ SomeRoute iN - } + , navModal -> do + modalContent <- liftHandler $ Left <$> navLinkRoute iN + customModal Modal + { modalTriggerId = Just iNavIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link") + Nothing -> error "navWidget with non-link modal" + , modalContent + } | NavTypeLink{} <- navType -> let route = iNavRoute ident = iNavIdent in $(widgetFile "widgets/navbar/navbar-container-item--link") | NavTypeButton{..} <- navType -> do csrfToken <- reqToken <$> getRequest + formAction <- liftHandler $ Just <$> navLinkRoute iN wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def { formMethod = navMethod , formSubmit = FormNoSubmit - , formAction = Just $ SomeRoute iN + , formAction } _other -> error "not implemented" diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index a95473ad7..a17b5b081 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -87,9 +87,14 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a csrfMiddleware handler = do hasBearer <- is _Just <$> lookupBearerAuth + reqHost <- W.requestHeaderHost <$> waiRequest + userGeneratedHost <- getsYesod $ \app -> + guardOnM (views _appRoot ($ ApprootDefault) app /= views _appRoot ($ ApprootUserGenerated) app) $ approotScopeHost ApprootUserGenerated app - if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler - | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler + if | hasBearer || fromMaybe False ((==) <$> reqHost <*> userGeneratedHost) + -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler + | otherwise + -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler where csrfSetCookieMiddleware' handler' = do mcsrf <- reqToken <$> getRequest @@ -150,7 +155,8 @@ routeNormalizers :: forall m backend. , BearerAuthSite UniWorX ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)] routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .) - [ normalizeRender + [ normalizeApproot + , normalizeRender , ncSchool , ncAllocation , ncCourse @@ -169,6 +175,12 @@ 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/Foundation/Yesod/Session.hs b/src/Foundation/Yesod/Session.hs index f8ed7274d..297e71431 100644 --- a/src/Foundation/Yesod/Session.hs +++ b/src/Foundation/Yesod/Session.hs @@ -17,46 +17,60 @@ import Web.Cookie makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend) -makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of - SessionStorageMemcachedSql sqlStore - -> mkBackend . stateSettings =<< ServerSession.createState sqlStore - SessionStorageAcid acidStore - | appServerSessionAcidFallback - -> mkBackend . stateSettings =<< ServerSession.createState acidStore - _other - -> return Nothing - where - cfg = JwtSession.ServerSessionJwtConfig - { sJwtJwkSet = appJSONWebKeySet - , sJwtStart = Nothing - , sJwtExpiration = appSessionTokenExpiration - , sJwtEncoding = appSessionTokenEncoding - , sJwtIssueBy = appInstanceID - , sJwtIssueFor = appClusterID - } - mkBackend :: forall sto. - ( ServerSession.SessionData sto ~ Map Text ByteString - , ServerSession.Storage sto - ) - => ServerSession.State sto -> IO (Maybe SessionBackend) - mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app) - stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto - stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig - sameSite - | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession) - = strictSameSiteSessions - | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession) - = laxSameSiteSessions - | otherwise - = id - notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) - notForBearer = fmap $ fmap notForBearer' - where notForBearer' :: SessionBackend -> SessionBackend - notForBearer' (SessionBackend load) - = let load' req - | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req - , any (is _Just . W.extractBearerAuth) aHdrs - = return (mempty, const $ return []) - | otherwise - = load req - in SessionBackend load' +makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of + SessionStorageMemcachedSql sqlStore + -> mkBackend . stateSettings =<< ServerSession.createState sqlStore + SessionStorageAcid acidStore + | appServerSessionAcidFallback + -> mkBackend . stateSettings =<< ServerSession.createState acidStore + _other + -> return Nothing + where + cfg = JwtSession.ServerSessionJwtConfig + { sJwtJwkSet = appJSONWebKeySet + , sJwtStart = Nothing + , sJwtExpiration = appSessionTokenExpiration + , sJwtEncoding = appSessionTokenEncoding + , sJwtIssueBy = appInstanceID + , sJwtIssueFor = appClusterID + } + mkBackend :: forall sto. + ( ServerSession.SessionData sto ~ Map Text ByteString + , ServerSession.Storage sto + ) + => ServerSession.State sto -> IO (Maybe SessionBackend) + mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app) + stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto + stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig + sameSite + | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession) + = strictSameSiteSessions + | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession) + = laxSameSiteSessions + | otherwise + = id + + notFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) + notFor f = fmap $ fmap notFor' + where notFor' :: SessionBackend -> SessionBackend + notFor' (SessionBackend load) = SessionBackend $ \req -> do + pMatches <- f req + if | not pMatches -> load req + | otherwise -> return (mempty, const $ return []) + + + isBearer req = return $ if + | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req + , any (is _Just . W.extractBearerAuth) aHdrs + -> True + | otherwise + -> False + + isUserGenerated req = return $ if + | Just approotHost <- approotScopeHost ApprootUserGenerated app + , Just reqHost <- W.requestHeaderHost req + , views _appRoot ($ ApprootUserGenerated) app /= views _appRoot ($ ApprootDefault) app + , reqHost == approotHost + -> True + | otherwise + -> False diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 826f42f79..f78bb5c1b 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -86,7 +86,7 @@ postAdminTokensR = do & HashSet.insert (Right uid) & HashSet.map (left toJSON) - fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt + fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' Nothing (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt siteLayoutMsg MsgMenuAdminTokens $ do setTitleI MsgMenuAdminTokens diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index 689919c45..ea927ce9e 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/src/Handler/Allocation/AddUser.hs @@ -13,6 +13,8 @@ import qualified Data.Conduit.Combinators as C import qualified Database.Esqueleto as E +import Handler.Course.Show + data AllocationAddUserForm = AllocationAddUserForm { aauUser :: UserId @@ -115,7 +117,12 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor afmApplicantEdit = True afmLecturer = True - appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> over _2 (course, allocCourse, hasApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing + appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> do + mApplicationTemplate <- runMaybeT $ do + guard hasApplicationTemplate + let Course{..} = course + liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ 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' @@ -123,7 +130,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor [whamlet| $newline never
- $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, hasApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews + $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
_{MsgAllocationPriority} @@ -141,16 +148,16 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor _{MsgCourseAllocationCourseAcceptsSubstitutesNever} $if allocationCourseAcceptSubstitutes >= Just now \ ^{iconOK} - $if hasApplicationTemplate || is _Just courseApplicationsInstructions + $if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
_{MsgCourseApplicationInstructionsApplication}
$maybe aInst <- courseApplicationsInstructions

#{aInst} - $if hasApplicationTemplate + $maybe templateUrl <- mApplicationTemplate

- + #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}

_{MsgCourseApplication} diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index f01ba8589..f2c8bf5b7 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -138,13 +138,15 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr | otherwise -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) - hasFiles <- for mApp $ \(Entity appId _) - -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] - appCID <- for mApp $ encrypt . entityKey - let appFilesInfo = (,) <$> hasFiles <*> appCID + 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 + return (hasFiles, appFilesLink) + let hasFiles = maybe False (view _1) appFilesInfo filesLinkView <- if - | Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) + | hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) -> let filesLinkField = Field{..} where fieldParse _ _ = return $ Right Nothing @@ -153,8 +155,8 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr = [whamlet| $newline never $case appFilesInfo - $of Just (True, appCID) - + $of Just (True, appFilesLink) + _{MsgCourseApplicationFiles} $of _ @@ -165,7 +167,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr -> return Nothing filesWarningView <- if - | Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit + | hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload | otherwise -> return Nothing diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 432566344..9f0c454b0 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -15,6 +15,8 @@ import Handler.Allocation.Application import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import Handler.Course.Show + data NotifyNewCourseButton = BtnNotifyNewCourseForceOn @@ -174,6 +176,10 @@ postAShowR tid ssh ash = do tRoute <- case mApp of Nothing -> return . AllocationR tid ssh ash $ AApplyR cID 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 + let mApplyFormView' = view _1 <$> mApplyFormView overrideVisible = not mayApply && is _Just mApp case mApplyFormView of diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs index 59cfaabe8..3d1ea1b0f 100644 --- a/src/Handler/Course/News/Download.hs +++ b/src/Handler/Course/News/Download.hs @@ -1,6 +1,6 @@ module Handler.Course.News.Download - ( getCNArchiveR - , getCNFileR + ( getCNArchiveR, cnArchiveSource + , getCNFileR, cnFileSource ) where import Import @@ -11,6 +11,11 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as C +cnArchiveSource :: CourseNewsId -> ConduitT () CourseNewsFile (YesodDB UniWorX) () +cnArchiveSource nId = (.| C.map entityVal) . E.selectSource . E.from $ \newsFile -> do + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + return newsFile + getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent getCNArchiveR tid ssh csh cID = do nId <- decrypt cID @@ -18,22 +23,16 @@ getCNArchiveR tid ssh csh cID = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle) - let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $ - \newsFile -> do - E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId - return newsFile - - serveSomeFiles archiveName getFilesQuery + serveSomeFiles archiveName $ cnArchiveSource nId +cnFileSource :: CourseNewsId -> FilePath -> ConduitT () CourseNewsFile (YesodDB UniWorX) () +cnFileSource nId fPath = (.| C.map entityVal) . E.selectSource . E.from $ \newsFile -> do + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val fPath + return newsFile + getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent -getCNFileR _ _ _ cID title = do +getCNFileR _ _ _ cID fPath = do nId <- decrypt cID - - let - fileQuery = E.selectSource . E.from $ \newsFile -> do - E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId - E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val title - return newsFile - - serveOneFile $ fileQuery .| C.map entityVal + serveOneFile $ cnFileSource nId fPath diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 331f94461..f8982faeb 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -101,31 +101,33 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do | otherwise -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) - hasFiles <- for application $ \(Entity appId _) - -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] - appCID <- for application $ encrypt . entityKey - let appFilesInfo = (,) <$> hasFiles <*> appCID + 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 + return (hasFiles, appFilesLink) + let hasFiles = maybe False (view _1) appFilesInfo filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired - when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $ + when (isn't _NoUpload courseApplicationsFiles || hasFiles) $ let filesLinkField = Field{..} where fieldParse _ _ = return $ Right Nothing fieldEnctype = mempty - fieldView theId _ attrs _ _ - = [whamlet| - $newline never - $case appFilesInfo - $of Just (True, appCID) - - _{filesMsg} - $of _ - - _{MsgCourseApplicationNoFiles} - |] + fieldView theId _ attrs _ _ = + [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appFilesLink) + + _{filesMsg} + $of _ + + _{MsgCourseApplicationNoFiles} + |] in void $ wforced filesLinkField (fslI filesMsg) Nothing - when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $ + when (hasFiles && isn't _NoUpload courseApplicationsFiles) $ wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 112412a97..f4e76c66a 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,6 +1,6 @@ module Handler.Course.Show ( getCShowR - , getCRegisterTemplateR + , getCRegisterTemplateR, courseRegisterTemplateSource ) where import Import @@ -25,12 +25,14 @@ 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 mbAid <- maybeAuthId now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -76,6 +78,9 @@ getCShowR tid ssh csh = do return allocation hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> 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 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 @@ -86,14 +91,17 @@ getCShowR tid ssh csh = do files' <- lift . lift . E.select . E.from $ \newsFile -> do E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle) - let files = files' + let files'' = files' & over (mapped . _1) E.unValue & over (mapped . _2) E.unValue lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR - return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete) + 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 + + return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl) events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid @@ -127,7 +135,7 @@ getCShowR tid ssh csh = do return $ material E.^. MaterialName mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -244,7 +252,7 @@ getCShowR tid ssh csh = do showNewsFiles fs = and [ not $ null fs , length fs <= 3 - , all (notElem pathSeparator . view _2) fs + , all (views (_1 . _2) $ notElem pathSeparator) fs ] hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events Course{courseVisibleFrom,courseVisibleTo} = course @@ -263,13 +271,15 @@ getCShowR tid ssh csh = do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") +courseRegisterTemplateSource :: TermId -> SchoolId -> CourseShorthand -> ConduitT () CourseAppInstructionFile (YesodDB UniWorX) () +courseRegisterTemplateSource tid ssh csh = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do + E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse + 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 courseAppInstructionFile + getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCRegisterTemplateR tid ssh csh = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh - let source = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do - E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse - 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 courseAppInstructionFile - serveSomeFiles archiveName source + serveSomeFiles archiveName $ courseRegisterTemplateSource tid ssh csh diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index fa6a8db39..dab8e610a 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -1,4 +1,12 @@ -module Handler.Material where +module Handler.Material + ( getMaterialListR + , getMFileR, getMVideoR + , getMShowR + , getMEditR, postMEditR + , getMaterialNewR, postMaterialNewR + , getMDelR, postMDelR + , getMArchiveR + ) where import Import @@ -58,11 +66,6 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template) (fslI MsgMaterialFiles) (mfFiles <$> template) -getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material) -getMaterialKeyBy404 tid ssh csh mnm = do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - getKeyBy404 $ UniqueMaterial cid mnm - fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) fetchMaterial tid ssh csh mnm = maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints @@ -80,8 +83,9 @@ getMaterialListR tid ssh csh = do let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR - filesLink :: MaterialName -> Route UniWorX - filesLink = CourseR tid ssh csh . flip MaterialR MArchiveR + 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 materialModDateCell :: IsDBTable m a => Material -> DBCell m a materialModDateCell Material{materialVisibleFrom, materialLastEdit} @@ -120,7 +124,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 -> fileCell $ filesLink materialName + | otherwise -> anchorCellM (filesLink materialName) iconFileDownload , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) @@ -173,9 +177,12 @@ 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 - MaterialFile{..} <- runDB $ get404 mfId + mf@MaterialFile{..} <- runDB $ get404 mfId let mimeType = mimeLookup $ pack materialFileTitle - mfile = CMaterialR tid ssh csh mnm $ MFileR 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) + mfileText <- toTextUrl mfile + mfileDownloadText <- toTextUrl mfileDownload unless (mimeType `Set.member` videoTypes) $ redirectWith movedPermanently301 mfile siteLayout' Nothing $ do @@ -185,10 +192,10 @@ getMVideoR tid ssh csh mnm cID = do
- + ^{iconFileDownload} # _{MsgMaterialVideoDownload} |] @@ -196,13 +203,10 @@ getMVideoR tid ssh csh mnm cID = do getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR tid ssh csh mnm = do - let zipLink :: Route UniWorX - zipLink = CMaterialR tid ssh csh mnm MArchiveR - 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)) <- runDB $ do + (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 matEnt <- fetchMaterial tid ssh csh mnm let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) materialModDateCol = if seeAllModificationTimestamps @@ -213,25 +217,25 @@ getMShowR tid ssh csh mnm = do { dbtSQLQuery = \matFile -> do E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories - return (matFile E.^. MaterialFileId, matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified) + return matFile , dbtRowKey = (E.^. MaterialFileId) , dbtColonnade = widgetColonnade $ mconcat - [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..} - -> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if + [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..}) + -> let matLink | isVideo - -> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value) - | otherwise -> return $ MFileR fileTitle + = SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId + | otherwise + = withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle wgt = [whamlet| $newline never - #{fileTitle} + #{materialFileTitle} $if isVideo \ ^{iconVideo} |] - isVideo = mimeLookup (pack fileTitle) `Set.member` videoTypes - fileTitle = unpack $ dbrOutput ^. _2 . _Value + isVideo = mimeLookup (pack materialFileTitle) `Set.member` videoTypes in anchorCellM matLink wgt - , materialModDateCol (view $ _dbrOutput . _3) + , materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified)) ] , dbtProj = return , dbtStyle = def @@ -246,7 +250,7 @@ getMShowR tid ssh csh mnm = do , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } - return (matEnt,fileTable') + return (matEnt,fileTable',zipLink) -- File table has no filtering by access, because we assume that -- access rights to material and material-files are identical. @@ -366,20 +370,22 @@ postMDelR tid ssh csh mnm = do , drDelete = const id -- TODO: audit } +materialArchiveSource :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> ConduitT () MaterialFile (YesodDB UniWorX) () +materialArchiveSource tid ssh csh mnm = (.| C.map entityVal) . E.selectSource . E.from $ + \(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do + E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial + E.on $ material E.^. MaterialCourse 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.&&. material E.^. MaterialName E.==. E.val mnm + return materialFile + -- | Serve all material-files getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR tid ssh csh mnm = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm - let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ - \(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do - E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial - E.on $ material E.^. MaterialCourse 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.&&. material E.^. MaterialName E.==. E.val mnm - return materialFile - + let getMatQuery = materialArchiveSource tid ssh csh mnm serveSomeFiles archiveName getMatQuery diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index cd1a6baa3..e1e9a9b01 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -9,6 +9,7 @@ import qualified Network.Wai.Middleware.Prometheus as Prometheus import qualified Data.Text as Text import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set @@ -28,7 +29,7 @@ getMetricsR = selectRep $ do uid <- MaybeT maybeAuthId guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid - encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing + encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing defaultLayout $ do setTitleI MsgTitleMetrics diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index bd7afe47a..f6776ebed 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 = CSheetR tid ssh csh sheetName $ SZipR sft + , let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh sheetName muid sft) . CSheetR tid ssh csh sheetName $ SZipR sft , let icn = toWgt $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs - then linkEitherCell link (icn, [whamlet| |]) + then linkEitherCellM 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 e4dea05ad..da586f4cf 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -46,22 +46,23 @@ getSShowR tid ssh csh shn = do return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle] , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified] , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType] + , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileContent, sheetFile E.?. SheetFileContent] ) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> - let link = CSheetR tid ssh csh shn $ SZipR ftype in - tellCell (Any True) $ - anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|] + [ 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 + in tellCell (Any True) $ + anchorCellM 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 fType) -> anchorCell - (CSheetR tid ssh csh shn (SFileR fType 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)) (str2widget fName) , sortable (toNothing "visible") (i18nCell MsgVisibleFrom) - $ \(_, _ , E.Value ftype) -> sftVisible ftype + $ \(_, _ , E.Value ftype, _) -> sftVisible ftype , sortable (Just "time") (i18nCell MsgFileModified) - $ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified + $ \(_,E.Value modified, E.Value ftype, _) -> sftModification ftype modified -- , colFileModification (view _2) ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] @@ -70,11 +71,11 @@ getSShowR tid ssh csh shn = do { dbtSQLQuery = fileData , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId) , dbtColonnade = colonnadeFiles - , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) + , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference)) , dbtStyle = def , dbtFilter = mconcat [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> - let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) + let (E.Value fName, _, E.Value fType, _) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference)) in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool ] , dbtFilterUI = mempty diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 62b87f8b3..c06eb0fd7 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -17,6 +17,8 @@ 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 @@ -50,7 +52,7 @@ postCorrectionR tid ssh csh shn cid = do MsgRenderer mr <- getMsgRenderer case results of - [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do + [(Entity cId Course{}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip pointsForm = case sheetType of NotGraded @@ -144,14 +146,11 @@ 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 let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound - - getCorrectionUserR tid ssh csh shn cid = do - - sub <- decrypt cid results <- runDB $ correctionData tid ssh csh shn sub @@ -159,5 +158,7 @@ getCorrectionUserR tid ssh csh shn cid = do case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment - in defaultLayout $(widgetFile "correction-user") + in defaultLayout $ do + urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource courseTerm courseSchool courseShorthand sheetName cid SubmissionCorrected) . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected + $(widgetFile "correction-user") _ -> notFound diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 6d55dfa62..683a0a7df 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -1,6 +1,6 @@ module Handler.Submission.Download - ( getSubDownloadR - , getSubArchiveR + ( getSubDownloadR, subDownloadSource + , getSubArchiveR, subArchiveSource , getCorrectionsDownloadR ) where @@ -16,8 +16,28 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.Combinators as Conduit +subDownloadSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> ConduitT () SubmissionFile (YesodDB UniWorX) () +subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do + (submissionID, isRating) <- lift $ do + submissionID <- submissionMatchesSheet tid ssh csh shn cID + + isRating <- (== Just submissionID) <$> isRatingFile path + + when (isUpdate || isRating) $ + guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + + return (submissionID, isRating) + + unless isRating $ (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. sf E.^. SubmissionFileTitle E.==. E.val path + E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 + return sf + getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do +getSubDownloadR tid ssh csh shn cID sft@(submissionFileTypeIsUpdate -> isUpdate) path = do (submissionID, isRating) <- runDB $ do submissionID <- submissionMatchesSheet tid ssh csh shn cID @@ -33,16 +53,26 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat | isUpdate -> maybe notFound sendThisFile <=< runDB . runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) | otherwise -> notFound - False -> do - let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do - E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.&&. sf E.^. SubmissionFileTitle E.==. E.val path - E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) - E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate - -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 - return sf + False -> serveOneFile $ subDownloadSource tid ssh csh shn cID sft path - serveOneFile results + +subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) () +subArchiveSource tid ssh csh shn cID sfType = do + when (sfType == SubmissionCorrected) $ + guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False + + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID + rating <- lift $ getRating submissionID + + case sfType of + SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False + return sf + _other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal) + + when (sfType == SubmissionCorrected) $ + maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent getSubArchiveR tid ssh csh shn cID sfType = do @@ -52,21 +82,7 @@ getSubArchiveR tid ssh csh shn cID sfType = do sfType' <- ap getMessageRender $ pure sfType archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' - let source = do - submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID - rating <- lift $ getRating submissionID - - case sfType of - SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do - E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False - return sf - _other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal) - - when (sfType == SubmissionCorrected) $ - maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating - - serveSomeFiles' archiveName source + serveSomeFiles' archiveName $ subArchiveSource tid ssh csh shn cID sfType getCorrectionsDownloadR :: Handler TypedContent diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 3ac78194c..30a2b3fca 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -28,6 +28,7 @@ import qualified Data.Aeson.Types as JSON import Data.Aeson.Lens +import Handler.Submission.Download import Handler.Submission.SubmissionUserInvite @@ -490,14 +491,12 @@ submissionHelper tid ssh csh shn mcid = do corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr Just isFile = origIsFile <|> corrIsFile in if - | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') - [whamlet|#{fileTitle'}|] + | Just True <- origIsFile -> anchorCellM (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 -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected submissionFileTitle) - [whamlet|_{MsgFileCorrected}|] + | isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget) | otherwise -> i18nCell MsgCorrected , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let origTime = submissionFileModified . entityVal <$> mOrig @@ -505,6 +504,8 @@ 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' submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle @@ -550,16 +551,13 @@ submissionHelper tid ssh csh shn mcid = do E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId) - let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> - let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment - courseTerm = tid - courseSchool = ssh - courseShorthand = csh - in $(widgetFile "correction-user") - defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn - let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected - urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal + (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 + 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 + in $(widgetFile "correction-user") $(widgetFile "submission") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index ccfd7d3e0..31ed5dccd 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -4,12 +4,9 @@ module Handler.Utils import Import hiding (link) -import qualified Data.Text.Encoding as T import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.Conduit.List as Conduit -import qualified Data.Conduit.Combinators as C import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils @@ -27,85 +24,13 @@ import Handler.Utils.Database as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils import Handler.Utils.Memcached as Handler.Utils import Handler.Utils.Files as Handler.Utils +import Handler.Utils.Download as Handler.Utils import Handler.Utils.Term as Handler.Utils import Control.Monad.Logger --- | Simply send a `File`-Value -sendThisFile :: DBFile -> Handler TypedContent -sendThisFile File{..} - | Just fileContent' <- fileContent = do - setCSPSandbox - setContentDisposition' . Just $ takeFileName fileTitle - let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8" - respondSourceDB cType $ - fileContent' .| Conduit.map toFlushBuilder - | otherwise = sendResponseStatus noContent204 () - -sendFileReference :: forall file a. HasFileReference file => file -> Handler a -sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do - when (is _Just fileReferenceContent) $ do - setCSPSandbox - setContentDisposition' . Just $ takeFileName fileReferenceTitle - let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8" - join . runDB $ respondFileConditional Nothing cType fRef - --- | Serve a single file, identified through a given DB query -serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent -serveOneFile source = do - results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below - case results of - [file] -> sendFileReference file - [] -> notFound - _other -> do - $logErrorS "SFileR" "Multiple matching files found." - error "Multiple matching files found." - --- | Serve one file directly or a zip-archive of files, identified through a given DB query --- --- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent -serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left - -serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent -serveSomeFiles' archiveName source = do - (source', results) <- runDB $ runPeekN 2 source - - $logDebugS "serveSomeFiles" . tshow $ length results - - case results of - [] -> notFound - [file] -> either sendFileReference sendThisFile file - _moreFiles -> do - setCSPSandbox - setContentDisposition' $ Just archiveName - respondSourceDB typeZip $ do - let zipComment = T.encodeUtf8 $ pack archiveName - source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder - --- | Serve any number of files as a zip-archive of files, identified through a given DB query --- --- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned -serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent -serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left - -serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent -serveZipArchive' archiveName source = do - (source', results) <- runDB $ runPeekN 1 source - - $logDebugS "serveZipArchive" . tshow $ length results - - case results of - [] -> notFound - _moreFiles -> do - setCSPSandbox - setContentDisposition' $ Just archiveName - respondSourceDB typeZip $ do - let zipComment = T.encodeUtf8 $ pack archiveName - source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder - -- | Prefix a message with a short course id, -- eg. for window title bars, etc. diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs index 3fa5d579a..2d1d4738d 100644 --- a/src/Handler/Utils/ContentDisposition.hs +++ b/src/Handler/Utils/ContentDisposition.hs @@ -3,10 +3,11 @@ module Handler.Utils.ContentDisposition , setContentDisposition' ) where -import Import +import Import.NoFoundation +import Foundation.Type -- | Check whether the user's preference for files is inline-viewing or downloading -downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool +downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m Bool downloadFiles = do mauth <- liftHandler maybeAuth case mauth of @@ -15,8 +16,8 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles -setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m () +setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Maybe FilePath -> m () setContentDisposition' mFileName = do - wantsDownload <- downloadFiles + wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 63bf227ac..91867c39c 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -19,7 +19,8 @@ module Handler.Utils.DateTime , formatGregorianW ) where -import Import +import Import.NoFoundation +import Foundation.Type import Data.Time.Zones import qualified Data.Time.Zones as TZ @@ -77,13 +78,13 @@ formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> p -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str -- Restricted type for safety -formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text +formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> m Text formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj) -- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text -- formatTimeH = formatTime -formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget +formatTimeW :: (HasLocalTime t, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> WidgetFor UniWorX () formatTimeW s t = toWidget =<< formatTime s t formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text @@ -92,7 +93,7 @@ formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . v getTimeLocale :: MonadHandler m => m TimeLocale getTimeLocale = getTimeLocale' <$> languages -getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat +getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> m DateTimeFormat getDateTimeFormat sel = do mauth <- liftHandler maybeAuth UserDefaultConf{..} <- getsYesod $ view _appUserDefaults @@ -110,7 +111,7 @@ getDateTimeFormat sel = do SelFormatTime -> userDefaultTimeFormat return fmt -getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormatter +getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter getDateTimeFormatter = do locale <- getTimeLocale formatMap <- traverse getDateTimeFormat id @@ -280,6 +281,7 @@ formatTimeRange' cont proj startT endT = do formatTimeRange :: ( HasLocalTime t, HasLocalTime t' , MonadHandler m , HandlerSite m ~ UniWorX + , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId ) => SelDateTimeFormat -> t -- ^ Start @@ -287,14 +289,14 @@ formatTimeRange :: ( HasLocalTime t, HasLocalTime t' -> m Text formatTimeRange = formatTimeRange' formatTime -formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget +formatTimeRangeW :: (HasLocalTime t, HasLocalTime t', YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> Maybe t' -> WidgetFor UniWorX () formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t' formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text formatTimeRangeMail = formatTimeRange' formatTimeMail -formatGregorianW :: Integer -> Int -> Int -> Widget +formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX () formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d instance Csv.ToField ZonedTime where diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs new file mode 100644 index 000000000..7683fe96d --- /dev/null +++ b/src/Handler/Utils/Download.hs @@ -0,0 +1,217 @@ +module Handler.Utils.Download + ( withFileDownloadTokenMaybe', withFileDownloadToken, withFileDownloadToken' + , sendThisFile + , sendFileReference + , serveOneFile + , serveSomeFiles + , serveSomeFiles' + , serveZipArchive + , serveZipArchive' + ) where + +import Import.NoFoundation +import Foundation.Type +import Foundation.Authorization + +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap + +import qualified Data.Conduit.Combinators as C + +import Handler.Utils.Zip +import Handler.Utils.ContentDisposition +import Handler.Utils.Files + + +data DownloadTokenRestriction + = DownloadRestrictSingle { downloadRestrictReference :: FileContentReference } + | DownloadRestrictMultiple + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + } ''DownloadTokenRestriction + +withFileDownloadTokenMaybe' :: forall url m. + ( HasRoute UniWorX url + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadCrypto m + , MonadCryptoKey m ~ CryptoIDKey + , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId + ) + => Maybe (ConduitT () (Either FileReference DBFile) m ()) + -> url + -> m (SomeRoute UniWorX) +withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ do + let rApproot = authoritiveApproot $ urlRoute route + case rApproot of + ApprootDefault -> mzero + _other -> return () + guardM . getsYesod $ \app -> views _appRoot (is _Just . ($ rApproot)) app + && views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app + + uid <- MaybeT maybeAuthId + now <- liftIO getCurrentTime + expireOffset <- getsYesod $ view _appDownloadTokenExpire + restr <- case mSource of + Just source -> do + results <- lift . runConduit $ source .| C.take 2 .| C.foldMap (pure . either Just (const Nothing)) + return $ case results of + [Just (FileReference{ fileReferenceContent = Just ref })] -> DownloadRestrictSingle ref + _other -> DownloadRestrictMultiple + Nothing -> return DownloadRestrictMultiple + bearer <- lift $ bearerRestrict (urlRoute route) restr <$> bearerToken + (HashSet.singleton $ Right uid) + (Just uid) + (HashMap.singleton BearerTokenRouteAccess . HashSet.singleton $ urlRoute route) + Nothing + (Just . Just $ addUTCTime expireOffset now) + (Just now) + encodedBearer <- lift $ encodeBearer bearer + + lift . setDownload $ SomeRoute @UniWorX route + & over (urlRouteParams $ Proxy @UniWorX) ((toPathPiece GetBearer, toPathPiece encodedBearer) :) + + where + setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX) + setDownload route' = do + wantsDownload <- downloadFiles + 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 + +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) + +-- | 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 () + +sendFileReference :: forall file a. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) + => file -> HandlerFor UniWorX a +sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do + whenIsJust fileReferenceContent $ \fRef' -> do + dlRestr <- maybeCurrentBearerRestrictions + case dlRestr of + Just (DownloadRestrictSingle restrRef) | restrRef == fRef' -> return () + _other -> setCSPSandbox + setContentDisposition' . Just $ takeFileName fileReferenceTitle + let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8" + join . runDB $ respondFileConditional Nothing cType fRef + +-- | Serve a single file, identified through a given DB query +serveOneFile :: forall file. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) => 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 + case results of + [file] -> sendFileReference file + [] -> notFound + _other -> do + $logErrorS "SFileR" "Multiple matching files found." + error "Multiple matching files found." + +-- | Serve one file directly or a zip-archive of files, identified through a given DB query +-- +-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned +serveSomeFiles :: forall file. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent +serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left + +serveSomeFiles' :: forall file. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent +serveSomeFiles' archiveName source = do + (source', results) <- runDB $ runPeekN 2 source + + $logDebugS "serveSomeFiles" . tshow $ length results + + case results of + [] -> notFound + [file] -> either sendFileReference sendThisFile file + _moreFiles -> do + setCSPSandbox + setContentDisposition' $ Just archiveName + respondSourceDB typeZip $ do + let zipComment = encodeUtf8 $ pack archiveName + source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder + +-- | Serve any number of files as a zip-archive of files, identified through a given DB query +-- +-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned +serveZipArchive :: forall file. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent +serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left + +serveZipArchive' :: forall file. + ( HasFileReference file + , BearerAuthSite UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistRunner UniWorX + ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent +serveZipArchive' archiveName source = do + (source', results) <- runDB $ runPeekN 1 source + + $logDebugS "serveZipArchive" . tshow $ length results + + case results of + [] -> notFound + _moreFiles -> do + setCSPSandbox + setContentDisposition' $ Just archiveName + respondSourceDB typeZip $ do + let zipComment = encodeUtf8 $ pack archiveName + source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index c058a3ffa..857428518 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -7,7 +7,9 @@ module Handler.Utils.Files , respondFileConditional ) where -import Import +import Import.NoFoundation +import Foundation.Type +import Utils.Metrics import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (unfoldM) @@ -77,10 +79,11 @@ sourceFileMinio fileReference = do in go -sourceFiles :: Monad m => ConduitT FileReference DBFile m () +sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m () sourceFiles = C.map sourceFile -sourceFile :: FileReference -> DBFile +sourceFile :: YesodPersistBackend UniWorX ~ SqlBackend + => FileReference -> DBFile sourceFile FileReference{..} = File { fileTitle = fileReferenceTitle , fileModified = fileReferenceModified @@ -94,16 +97,16 @@ sourceFile FileReference{..} = File inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference bool sourceFileMinio sourceFileDB inDB fileReference -sourceFiles' :: forall file m. (HasFileReference file, Monad m) => ConduitT file DBFile m () +sourceFiles' :: forall file m. (HasFileReference file, Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT file DBFile m () sourceFiles' = C.map sourceFile' -sourceFile' :: forall file. HasFileReference file => file -> DBFile +sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile sourceFile' = sourceFile . view (_FileReference . _1) -respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) +respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX) => Maybe UTCTime -> MimeType -> FileReference - -> SqlPersistT m (Handler a) + -> SqlPersistT m (HandlerFor UniWorX a) respondFileConditional representationLastModified cType FileReference{..} = do if | Just fileContent <- fileReferenceContent diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index e2ffbe14e..9c6436c52 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -26,6 +26,7 @@ import Text.Hamlet import qualified Data.Conduit.List as C import qualified Data.List.NonEmpty as NonEmpty import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set import Data.Aeson (fromJSON) @@ -215,7 +216,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' jInviter <- liftHandler maybeAuthId route <- mapReaderT liftHandler $ invitationRoute fEnt dat InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat - protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt + protoToken <- bearerToken itAuthority Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) bearer <- encodeBearer token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)]) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 342a7bd18..e23b65a19 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -104,11 +104,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass addUrgencyClass = addCellClass $ statusToUrgencyClass Warning -- | for simple file downloads -fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a +fileCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a fileCell route = anchorCell route iconFileDownload -- | for zip-archive downloads -zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a +zipCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a zipCell route = anchorCell route iconFileZip -- | for csv downloads diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 73b6cacae..50a4e8d5f 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -25,6 +25,7 @@ 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 @@ -375,7 +376,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body | showLink -> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do cID <- encrypt appId - return $ CApplicationR tid ssh csh cID CAFilesR + liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR | otherwise -> mempty diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 5a5f305dd..e003f7968 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -31,11 +31,13 @@ visibleUTCTime dtf t = do -- | Simple link to a known route -simpleLink :: Widget -> Route UniWorX -> Widget -simpleLink lbl url = [whamlet|^{lbl}|] +simpleLink :: RedirectUrl UniWorX url => Widget -> url -> Widget +simpleLink lbl url = do + tUrl <- toTextUrl url + [whamlet|^{lbl}|] -simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget -simpleLinkI lbl url = [whamlet|_{lbl}|] +simpleLinkI :: (RenderMessage UniWorX msg, RedirectUrl UniWorX url) => msg -> url -> Widget +simpleLinkI = simpleLink . i18n -- | toWidget-Version of @nameHtml@, for convenience nameWidget :: Text -- ^ userDisplayName diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 70147cbd2..3638a98dc 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -11,7 +11,7 @@ module Handler.Utils.Zip , receiveFiles, acceptFile ) where -import Import +import Import.NoFoundation import Handler.Utils.Files (acceptFile) import Handler.Utils.DateTime (localTimeToUTCSimple, utcToLocalTime) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 3afe363ce..4472d2483 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -4,7 +4,7 @@ module Handler.Workflow.Workflow.Workflow , workflowR ) where -import Import hiding (Last(..)) +import Import hiding (Last(..), Encoding(None)) import Utils.Form import Utils.Workflow @@ -44,7 +44,7 @@ data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHI data WorkflowHistoryItem = WorkflowHistoryItem { whiUser :: Maybe WorkflowHistoryItemActor , whiTime :: UTCTime - , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))] + , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))] , whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view , whiVia :: Maybe Text , whiTo :: Maybe Text @@ -53,11 +53,27 @@ data WorkflowHistoryItem = WorkflowHistoryItem data WorkflowCurrentState = WorkflowCurrentState { wcsState :: Maybe Text , wcsMessages :: Set Message - , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))] + , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))] } 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 @@ -155,6 +171,8 @@ workflowR rScope cID = do -> WorkflowFieldPayloadW Void (Maybe (Entity User)) -> Ordering payloadSort (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of + (WFPFile a', _ ) -> absurd a' + (_, WFPFile a' ) -> absurd a' (WFPText a', WFPText b' ) -> compareUnicode a' b' (WFPText{}, _ ) -> LT (WFPNumber a', WFPNumber b') -> compare a' b' @@ -169,7 +187,6 @@ workflowR rScope cID = do (WFPDay{}, WFPNumber{} ) -> GT (WFPDay{}, WFPBool{} ) -> GT (WFPDay{}, _ ) -> LT - (WFPFile a', _ ) -> absurd a' (WFPUser a', WFPUser b' ) -> case (a', b') of (Nothing, _) -> GT (_, Nothing) -> LT @@ -178,13 +195,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) . over _2 (bool Nothing (Just fRoute). getAny)) . execWriterT . 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) + 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) payloadChanges <- State.state $ \oldPayload -> ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index e4c5c341f..53e111377 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -13,6 +13,7 @@ import Utils.Frontend.Notification as Import import Utils.Lens as Import import Utils.Failover as Import import Utils.Room as Import +import Utils.Approot as Import import Settings as Import import Settings.StaticFiles as Import diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs index 52daa4188..5c953a76a 100644 --- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs +++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs @@ -6,13 +6,14 @@ import Import import Handler.Utils.Mail import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap import qualified Data.CaseInsensitive as CI import Text.Hamlet dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> JobHandler UniWorX dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do - bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing + bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing jwt <- encodeBearer bearer let setDisplayEmailUrl :: SomeRoute UniWorX diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs index a6eee899b..c14b1fb91 100644 --- a/src/Jobs/Handler/SendNotification/Utils.hs +++ b/src/Jobs/Handler/SendNotification/Utils.hs @@ -8,6 +8,7 @@ import Import import Text.Hamlet import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) @@ -16,7 +17,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX)) mkEditNotifications uid = liftHandler $ do cID <- encrypt uid - jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing + jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing let editNotificationsUrl :: SomeRoute UniWorX editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)]) diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs index d5b4c75aa..c0dde70f1 100644 --- a/src/Jobs/Handler/SendPasswordReset.hs +++ b/src/Jobs/Handler/SendPasswordReset.hs @@ -10,6 +10,7 @@ import Handler.Utils.Users import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteArray as BA import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap import Text.Hamlet @@ -29,7 +30,7 @@ dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecip LTUUnique utc' _ -> utc' _other -> UTCTime (addDays 2 $ utctDay now) 0 - resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing + resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing let resetBearer = resetBearer' & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication) encodedBearer <- encodeBearer resetBearer diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index b899f2377..3e3bd5678 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -82,7 +82,7 @@ dispatchHealthCheckMatchingClusterConfig dispatchHealthCheckHTTPReachable :: Handler HealthReport dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do - staticAppRoot <- getsYesod $ view _appRoot + staticAppRoot <- getsYesod $ views _appRoot ($ ApprootDefault) doHTTP <- getsYesod $ view _appHealthCheckHTTP for (staticAppRoot <* guard doHTTP) $ \_ -> do url <- getUrlRender <*> pure InstanceR diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index d8e3cd901..3185729c4 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -2,7 +2,7 @@ {-# LANGUAGE UndecidableInstances #-} module Model.Tokens.Bearer - ( BearerToken(..) + ( BearerToken(..), BearerTokenRouteMode(..) , _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt , bearerRestrict , bearerToJSON, bearerParseJSON @@ -16,6 +16,9 @@ import Model.Tokens.Lens import Utils (assertM', foldMapM) import Utils.Lens hiding ((.=)) import Data.Aeson.Lens (AsJSON(..)) +import Utils.PathPiece + +import Data.Universe import Yesod.Auth (AuthId) @@ -42,13 +45,26 @@ import qualified Data.CryptoID.Class.ImplicitNamespace as I +data BearerTokenRouteMode + = BearerTokenRouteEval -- ^ Token is not to be evaluated for routes outside of the given restriction + | BearerTokenRouteAccess -- ^ Token may be evaluated for routes outside of the given restriction, but not if the initial request was outside the restriction + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, Hashable, Binary) +nullaryPathPiece ''BearerTokenRouteMode $ camelToPathPiece' 3 +pathPieceJSON ''BearerTokenRouteMode +pathPieceJSONKey ''BearerTokenRouteMode +instance Default BearerTokenRouteMode where + def = BearerTokenRouteEval + -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token data BearerToken site = BearerToken { bearerIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens , bearerAuthority :: HashSet (Either Value (AuthId site)) -- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`) - , bearerRoutes :: Maybe (HashSet (Route site)) + , bearerImpersonate :: Maybe (AuthId site) + -- ^ Token doubles as session token; i.e. if presented `maybeAuthId` etc. should evaluate to the given value + , bearerRoutes :: HashMap BearerTokenRouteMode (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes , bearerAddAuth :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid. @@ -125,9 +141,12 @@ bearerToJSON BearerToken{..} = do authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths + iCID <- traverse I.encrypt bearerImpersonate :: m (Maybe (CryptoUUID (AuthId (HandlerSite m)))) + return . JSON.object $ catMaybes [ Just $ "authority" .= authorityToJSON cID - , ("routes" .=) <$> bearerRoutes + , ("impersonate" .=) <$> iCID + , ("routes" .=) <$> assertM' (not . HashMap.null) bearerRoutes , ("add-auth" .=) <$> bearerAddAuth , ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions ] @@ -154,7 +173,9 @@ bearerParseJSON v@(Object o) = do ] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site)))) bearerAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.decrypt)) bearerAuthority' - bearerRoutes <- lift $ o .:? "routes" + bearerImpersonate <- traverse I.decrypt <=< lift $ (o .:? "impersonate" :: Parser (Maybe (CryptoUUID (AuthId site)))) + bearerRoutes <- lift $ (o .:? "routes" .!= HashMap.empty) + <|> (maybe HashMap.empty (HashMap.singleton def) <$> o .:? "routes") bearerAddAuth <- lift $ o .:? "add-auth" bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty Jose.JwtClaims{..} <- lift $ parseJSON v diff --git a/src/Settings.hs b/src/Settings.hs index 77e182a29..0c48504f9 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -94,7 +94,7 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing a SMTP Mailserver , appWidgetMemcachedConf :: Maybe WidgetMemcachedConf -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent` - , appRoot :: Maybe Text + , appRoot :: ApprootScope -> Maybe Text -- ^ Base for all generated URLs. If @Nothing@, determined -- from the request headers. , appHost :: HostPreference @@ -196,10 +196,16 @@ data AppSettings = AppSettings , appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime + , appDownloadTokenExpire :: NominalDiffTime + , appInitialInstanceID :: Maybe (Either FilePath UUID) , appRibbon :: Maybe Text } deriving Show +data ApprootScope = ApprootUserGenerated | ApprootDefault + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, Hashable) + newtype ServerSessionSettings = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a } @@ -308,6 +314,12 @@ data VerpMode = VerpNone | Verp { verpPrefix :: Text, verpSeparator :: Char } deriving (Eq, Show, Read, Generic) +nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1 +pathPieceJSON ''ApprootScope +pathPieceJSONKey ''ApprootScope +pathPieceBinary ''ApprootScope +pathPieceHttpApiData ''ApprootScope + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 @@ -456,7 +468,7 @@ instance FromJSON AppSettings where appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached" appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached" appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" - appRoot <- o .:? "approot" + appRoot <- o .:? "approot" .!= const Nothing appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" @@ -564,6 +576,8 @@ instance FromJSON AppSettings where appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire" + appDownloadTokenExpire <- o .: "download-token-expire" + return AppSettings{..} makeClassy_ ''AppSettings diff --git a/src/Utils/Approot.hs b/src/Utils/Approot.hs new file mode 100644 index 000000000..751207819 --- /dev/null +++ b/src/Utils/Approot.hs @@ -0,0 +1,18 @@ +module Utils.Approot + ( approotScopeHost + ) where + +import ClassyPrelude +import Settings + +import qualified Network.URI as URI + +import Control.Lens + + +approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString +approotScopeHost 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 diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 2fdbf6311..bdf07749b 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -21,7 +21,7 @@ import Data.Universe import Control.Monad.Trans.Maybe (MaybeT(..)) -data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun +data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun | GetDownload deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) diff --git a/src/Utils/Route.hs b/src/Utils/Route.hs index f7ee1c589..047687442 100644 --- a/src/Utils/Route.hs +++ b/src/Utils/Route.hs @@ -2,22 +2,40 @@ module Utils.Route where import Control.Lens import ClassyPrelude.Yesod -- hiding (foldlM) +import Data.Kind (Type) + +import qualified Data.Map as Map class RedirectUrl site url => HasRoute site url where + type RouteWithParams site url :: Type + type RouteWithParams site url = (Route site, [(Text, Text)]) urlRoute :: url -> Route site + urlRouteParams :: forall p. p site -> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)] + default urlRouteParams :: forall p. + RouteWithParams site url ~ (Route site, [(Text, Text)]) + => p site + -> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)] + urlRouteParams _ = lens (const []) (\(urlRoute -> route') params -> (route', params)) instance HasRoute site (Route site) where urlRoute = id -- | for GET-Parameters instance (key ~ Text) => HasRoute site (Route site, Map key Text) where urlRoute = view _1 + urlRouteParams _ = lens (views _2 Map.toList) (\(route, _) params -> (route, params)) -- | for GET-Parameters instance (key ~ Text) => HasRoute site (Route site, [(key, Text)]) where urlRoute = view _1 + urlRouteParams _ = _2 -- | for PageAnchors, implemented through Fragments instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where + type RouteWithParams site (Fragment a b) = Fragment (RouteWithParams site a) b urlRoute (a :#: _) = urlRoute a + urlRouteParams pSite = fragRoute . urlRouteParams pSite + where + fragRoute :: forall a1 a2 b'. Lens (Fragment a1 b') (Fragment a2 b') a1 a2 + fragRoute = lens (\(a :#: _) -> a) (\(_ :#: f) a' -> a' :#: f) data SomeRoute site = forall url. HasRoute site url => SomeRoute url deriving (Typeable) @@ -25,4 +43,6 @@ data SomeRoute site = forall url. HasRoute site url => SomeRoute url instance RedirectUrl site (SomeRoute site) where toTextUrl (SomeRoute url) = toTextUrl url 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)) diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index f29aa5da9..354599c30 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -53,14 +53,15 @@ bearerToken :: forall m. , HasClusterID (HandlerSite m) ClusterId , HasAppSettings (HandlerSite m) ) - => HashSet (Either Value (AuthId (HandlerSite m))) - -> Maybe (HashSet (Route (HandlerSite m))) - -> Maybe AuthDNF - -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically - -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately + => HashSet (Either Value (AuthId (HandlerSite m))) -- ^ Authority + -> Maybe (AuthId (HandlerSite m)) -- ^ Impersonate + -> HashMap BearerTokenRouteMode (HashSet (Route (HandlerSite m))) + -> Maybe AuthDNF -- ^ Additional auth + -> Maybe (Maybe UTCTime) -- ^ Expiration; @Nothing@ determines default expiry time automatically + -> Maybe UTCTime -- ^ Start of Validity; @Nothing@ means token starts to be valid immediately -> m (BearerToken (HandlerSite m)) -- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict` -bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do +bearerToken bearerAuthority bearerImpersonate bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do bearerIdentifier <- liftIO getRandom bearerIssuedAt <- liftIO getCurrentTime bearerIssuedBy <- getsYesod $ view instanceID diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 56c967d06..483ecdd3b 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -40,9 +40,9 @@ $if hasApplicationTemplate || is _Just courseApplicationsInstructions $maybe aInst <- courseApplicationsInstructions

#{aInst} - $if hasApplicationTemplate + $maybe templateUrl <- mApplicationTemplate

- + #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} $maybe ApplicationFormView{ ..} <- mApplyFormView'

diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 248462a04..1620eefd1 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -44,7 +44,7 @@ _{MsgRatingFiles} - + _{MsgRatingUpdatedFiles} $maybe comment <- ratingComment diff --git a/templates/course.hamlet b/templates/course.hamlet index 6dd36f2f1..8aaca6e03 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -8,7 +8,7 @@ $newline never
$if not (null news)