diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 55c83c173..2691071a2 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1492,29 +1492,16 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem ] defaultAuthDNF :: AuthDNF -defaultAuthDNF = PredDNF $ Set.fromList - [ impureNonNull . Set.singleton $ PLVariable AuthAdmin - , impureNonNull . Set.singleton $ PLVariable AuthToken - ] +defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF --- ^ DNF up to entailment: --- --- > (A_1 && A_2 && ...) OR' B OR' ... --- --- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs +-- ^ DNF up to entailment, see `predDNFEntail` +routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs where - partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) - partition' prev t - | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) - = if - | oany (authTags `Set.isSubsetOf`) prev - -> Right prev - | otherwise - -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev - | otherwise - = Left $ InvalidAuthTag t + parse :: AuthDNF -> Text -> Either InvalidAuthTag AuthDNF + parse prev t = case fromNullable . Set.fromList =<< mapM fromPathPiece (Text.splitOn "AND" t) of + Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t' + Nothing -> Left $ InvalidAuthTag t evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m -- ^ `tell`s disabled predicates, identified as pivots @@ -1651,32 +1638,41 @@ evalWorkflowRoleFor' :: forall m backend. -> Route UniWorX -> Bool -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult -evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = case wRole of - WorkflowRoleUser{..} -> lift . exceptT return return $ do - uid <- maybeExceptT AuthenticationRequired $ return mAuthId - unless (uid == workflowRoleUser) $ - throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch - return Authorized - -- `WorkflowRoleInitiator` now means "during initiation". - -- The old meaning can be emulated via `WorkflowRolePayloadReference`. - WorkflowRoleInitiator{} -> if - | is _Nothing mwwId -> return Authorized - | otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated - -- WorkflowRoleInitiator{} -> exceptT return return $ do - -- wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId - -- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId - -- let WorkflowAction{..} = head workflowWorkflowState - -- wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser - -- lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite - WorkflowRolePayloadReference{..} -> exceptT return return $ do - uid <- maybeExceptT AuthenticationRequired $ return mAuthId - wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId - WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId - let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState - unless (uid `Set.member` uids) $ - throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch - return Authorized - WorkflowRoleAuthorized{..} -> eval workflowRoleAuthorized mAuthId route isWrite +evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do + mr <- getMsgRenderer + + let + orAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + + orDefault = orAR' $ eval defaultAuthDNF mAuthId route isWrite + + case wRole of + WorkflowRoleUser{..} -> orDefault . lift . exceptT return return $ do + uid <- maybeExceptT AuthenticationRequired $ return mAuthId + unless (uid == workflowRoleUser) $ + throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch + return Authorized + -- `WorkflowRoleInitiator` now means "during initiation". + -- The old meaning can be emulated via `WorkflowRolePayloadReference`. + WorkflowRoleInitiator{} -> orDefault $ if + | is _Nothing mwwId -> return Authorized + | otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated + -- WorkflowRoleInitiator{} -> exceptT return return $ do + -- wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId + -- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId + -- let WorkflowAction{..} = head workflowWorkflowState + -- wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser + -- lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite + WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do + uid <- maybeExceptT AuthenticationRequired $ return mAuthId + wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId + WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId + let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState + unless (uid `Set.member` uids) $ + throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch + return Authorized + WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite evalWorkflowRoleFor :: ( MonadHandler m , HandlerSite m ~ UniWorX diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 14c4de981..f2349bd29 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -556,7 +556,7 @@ deriveFinite ''ExamModePredicate newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece) + deriving newtype (ToJSON, FromJSON, PathPiece) derivePersistFieldJSON ''ExamModeDNF diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index b7f84b82f..480321380 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -176,7 +176,6 @@ instance PathPiece a => PathPiece (PredLiteral a) where newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (Semigroup, Monoid) deriving anyclass (Binary, Hashable) makeLenses_ ''PredDNF @@ -216,6 +215,13 @@ predDNFFalse = PredDNF Set.empty predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton +predDNFVar, predDNFNeg :: Ord a => a -> PredDNF a +predDNFVar = predDNFSingleton . PLVariable +predDNFNeg = predDNFSingleton . PLNegated + +infixr 3 `predDNFAnd` +infixr 2 `predDNFOr` + predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do aConj <- Set.toList a @@ -223,6 +229,20 @@ predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b +predDNFEntail :: forall a. Ord a => PredDNF a -> PredDNF a +-- ^ Conversion to “DNF up to entailment”: +-- +-- > (A_1 && A_2 && ...) OR B OR ... -> (A_1 && A_2 && ...) OR' B OR' ... +-- +-- > A OR' B := ((A |- B) ==> A) && (A || B) +predDNFEntail = over _dnfTerms $ ofoldl' entail Set.empty + where entail :: Set (NonNull (Set (PredLiteral a))) -> NonNull (Set (PredLiteral a)) -> Set (NonNull (Set (PredLiteral a))) + entail prev t + | oany (t `isSubsetOf`) prev = prev + | otherwise = Set.insert t $ Set.filter (not . (`isSubsetOf` t)) prev + where isSubsetOf = Set.isSubsetOf `on` toNullable + + data UserGroupName = UserGroupMetrics diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a2ab5ffc8..40b90e616 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -28,6 +28,7 @@ import qualified Data.Csv as Csv import Crypto.Random (getRandomBytes) import Data.List (genericLength) +import qualified Data.List as List (splitAt) import qualified Data.Conduit.Combinators as C @@ -276,6 +277,35 @@ fillDb = do , userSex = Just SexFemale , userShowSex = userDefaultShowSex } + sbarth <- insert User + { userIdent = "Stephan.Barth@campus.lmu.de" + , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing + , userTokensIssuedAfter = Nothing + , userMatrikelnummer = Nothing + , userEmail = "Stephan.Barth@lmu.de" + , userDisplayEmail = "stephan.barth@ifi.lmu.de" + , userDisplayName = "Stephan Barth" + , userSurname = "Barth" + , userFirstName = "Stephan" + , userTitle = Nothing + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userLanguages = Nothing + , userNotificationSettings = def + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = Nothing + , userCsvOptions = def + , userSex = Just SexMale + , userShowSex = userDefaultShowSex + } let firstNames = [ "James", "John", "Robert", "Michael" @@ -386,8 +416,8 @@ fillDb = do void . insert' $ UserFunction jost ifi SchoolLecturer void . insert' $ UserFunction svaupel ifi SchoolLecturer void . insert' $ UserFunction gkleen ifi SchoolAllocation - void . insert' $ UserFunction gkleen ifi SchoolExamOffice - void . insert' $ UserFunction gkleen mi SchoolExamOffice + void . insert' $ UserFunction sbarth ifi SchoolLecturer + void . insert' $ UserFunction sbarth ifi SchoolExamOffice for_ [gkleen, fhamann, jost, maxMuster, svaupel] $ \uid -> void . insert' $ UserSchool uid ifi False for_ [gkleen, tinaTester] $ \uid -> @@ -1202,9 +1232,11 @@ fillDb = do , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight , allocationMatchingSeed = aSeedBig } - bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do - csh <- ("ZA-" <>) . pack . take 3 <$> getRandomRs ('A', 'Z') - + bigAllocShorthands <- + let go xs = let (csh, xs') = List.splitAt 3 xs + in pack csh : go xs' + in take 40 . nub . go <$> getRandomRs ('A', 'Z') + bigAllocCourses <- forM (zip [1..] bigAllocShorthands) $ \(n :: Natural, csh) -> do cap <- getRandomR (10,50) minCap <- round . (* fromIntegral cap) <$> getRandomR (0, 0.5 :: Double) @@ -1234,7 +1266,7 @@ fillDb = do , courseDeregisterNoShow = False } insert_ $ CourseEdit gkleen now cid - insert_ . AllocationCourse bigAlloc cid minCap $ Just substitutesUntil + void . insert' . AllocationCourse bigAlloc cid minCap $ Just substitutesUntil -- void . insert' $ Lecturer gkleen cid CourseLecturer return cid