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

Work on knownTags

Browse Source
This commit is contained in:
Gregor Kleen 2018-05-29 10:27:35 +02:00
parent e3566d9832
commit 69ee7b1a81
1 changed files with 15 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/Foundation.hs
View File

@ -219,18 +219,20 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
return Authorized return Authorized
) )
,("lecturer", APDB $ \case ,("lecturer", APDB $ \case
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do CourseR tid csh _ -> exceptT return return $ do
authId <- lift $ lift requireAuthId -- TODO SJ Continue authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-- getBy404 would disclose that the course exists [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
void . MaybeT . getBy $ UniqueLecturer authId cid E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (unauthorizedI MsgUnauthorizedLecturer) (c > 0)
return Authorized
_ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
return Authorized return Authorized
_ -> do
authId <- lift requireAuthId -- TODO SJ Continue
mul <- selectFirst [UserLecturerUser ==. authId] []
case mul of
Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
(Just _) -> return Authorized
) )
-- TODO: Continue here!!! -- TODO: Continue here!!!
,("corrector", undefined) ,("corrector", undefined)
@ -247,12 +249,12 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
tag2ap :: Text -> AccessPredicate tag2ap :: Text -> AccessPredicate
tag2ap t = case Map.lookup (CI.mk t) knownTags of tag2ap t = case Map.lookup (CI.mk t) knownTags of
(Just acp) -> acp (Just acp) -> acp
Nothing -> APHandler $ \_route -> do --TODO: can this be pure like falseAP? Nothing -> APHandler $ \_route -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
$logWarnS "AccessControl" ("route tag unknown for access control") $logWarnS "AccessControl" ("route tag unknown for access control")
unauthorizedI $ MsgUnauthorized unauthorizedI $ MsgUnauthorized
route2ap :: Route UniWorX -> AccessPredicate route2ap :: Route UniWorX -> AccessPredicate
route2ap r = foldr orAP adminAP attrsAND --TODO: adminAP causes all to be in DB!!! route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
where where
attrsAND = map splitAND $ Set.toList $ routeAttrs r attrsAND = map splitAND $ Set.toList $ routeAttrs r
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"