From 0b0eaff20daf9f38e42678d7ab159a0e75ebec66 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 10 Aug 2020 10:35:09 +0200 Subject: [PATCH] fix(personalised-sheet-files): more thorough check wrt sub-warnings --- src/Foundation.hs | 41 +++++++++++++++++++++++++++++++++---- src/Handler/Sheet/Show.hs | 17 +++++++++------ src/Model/Types/Security.hs | 18 ++++++++++++++++ src/Utils/Lens.hs | 2 -- 4 files changed, 66 insertions(+), 12 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 5eec55a10..87556aadb 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1572,13 +1572,23 @@ evalAccessFor mAuthId route isWrite = do evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB = evalAccessFor -evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult -evalAccess route isWrite = do +evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult +evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated + let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf + case dnf' of + Nothing -> return Authorized + Just dnf'' -> do + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite + result <$ tellSessionJson SessionInactiveAuthTags deactivated + +evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessWithDB = evalAccessWith + +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess = evalAccessWith [] evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessDB = evalAccess @@ -1598,6 +1608,29 @@ hasReadAccessTo = flip hasAccessTo False hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True +wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> Bool + -> m Bool +wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite + +wouldHaveReadAccessTo, wouldHaveWriteAccessTo + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False +wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True + +wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessToIff assumptions route = and2M (fmap not $ hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route +wouldHaveWriteAccessToIff assumptions route = and2M (fmap not $ hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route + -- | Conditional redirect that hides the URL if the user is not authorized for the route redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index c001e64fa..00f38c092 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -116,7 +116,11 @@ getSShowR tid ssh csh shn = do , formEncoding = generateEnctype , formSubmit = FormNoSubmit } - mRequiredExam <- fmap join . for (sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do + checkExamRegistration <- orM + [ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR + , wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR + ] + mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ exam E.^. ExamId E.==. E.val eId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName) @@ -125,14 +129,15 @@ getSShowR tid ssh csh shn = do let eUrl = CExamR etid essh ecsh examn EShowR guardM $ hasReadAccessTo eUrl return eUrl - mMissingExamRegistration <- for (sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do + mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do uid <- MaybeT maybeAuthId lift . fmap not . runDB $ exists [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid ] - let checkPersonalisedFiles - = not (sheetAllowNonPersonalisedSubmission sheet) - && NTop (sheetActiveFrom sheet) <= NTop (Just now) - && NTop (sheetActiveTo sheet) >= NTop (Just now) + checkPersonalisedFiles <- andM + [ return . not $ sheetAllowNonPersonalisedSubmission sheet + , return $ NTop (sheetActiveFrom sheet) <= NTop (Just now), return $ NTop (Just now) <= NTop (sheetActiveTo sheet) + , wouldHaveWriteAccessToIff [(AuthPersonalisedSheetFiles, True)] $ CSheetR tid ssh csh shn SubmissionNewR + ] mMissingPersonalisedFiles <- for (guardOnM checkPersonalisedFiles muid) $ \uid -> runDB $ fmap not . E.selectExists . E.from $ \psFile -> E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. E.val uid diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 30ba8df72..235161ecc 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -127,6 +127,8 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (Hashable, Binary) +makeLenses_ ''PredLiteral + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "val" "var" @@ -145,6 +147,8 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving newtype (Semigroup, Monoid) deriving anyclass (Binary, Hashable) +makeLenses_ ''PredDNF + $(return []) instance ToJSON a => ToJSON (PredDNF a) where @@ -161,6 +165,20 @@ type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag +dnfAssumeValue :: forall a. Ord a => a -> Bool -> PredDNF a -> Maybe (PredDNF a) +-- ^ `Nothing` corresponds to @⊤@ +dnfAssumeValue var val + = fmap (PredDNF . Set.fromList) . sequence + . foldMapOf (_dnfTerms . folded) (pure @[] . fromNullable . Set.filter (not . agrees) . toNullable) + . over _dnfTerms (Set.filter $ none disagrees . toNullable) + where + agrees, disagrees :: PredLiteral a -> Bool + agrees PLVariable{..} = plVar == var && val + agrees PLNegated{..} = plVar == var && not val + disagrees PLNegated{..} = plVar == var && val + disagrees PLVariable{..} = plVar == var && not val + + data UserGroupName = UserGroupMetrics | UserGroupCustom { userGroupCustomName :: CI Text } diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 667b2f782..46758dc70 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -180,8 +180,6 @@ makePrisms ''OccurrenceException makeLenses_ ''Occurrences -makeLenses_ ''PredDNF - makeLenses_ ''Invitation makeLenses_ ''ExamBonusRule