fix(personalised-sheet-files): more thorough check wrt sub-warnings

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

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

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 }

src/Utils/Lens.hs

@@ -180,8 +180,6 @@ makePrisms ''OccurrenceException
 
 makeLenses_ ''Occurrences
 
-makeLenses_ ''PredDNF
-
 makeLenses_ ''Invitation
 
 makeLenses_ ''ExamBonusRule