fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(workflows): make admin or token sufficient for all roles

Browse Source
This commit is contained in:
Gregor Kleen 2020-12-03 19:48:49 +01:00
parent c392cb5895
commit 7a7cd4d07c
4 changed files with 102 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
src/Foundation/Authorization.hs
View File

@ -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

2
src/Model/Types/Exam.hs
View File

@ -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

22
src/Model/Types/Security.hs
View File

@ -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

44
test/Database/Fill.hs
View File

@ -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