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

Minor refactor andAP and adminAP

Browse Source
This commit is contained in:
SJost 2018-05-29 10:49:46 +02:00
parent e3566d9832
commit 87ab470072
2 changed files with 22 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Foundation.hs
View File

@ -159,14 +159,12 @@ orAR _ _ Authorized = Authorized
orAR _ AuthenticationRequired _ = AuthenticationRequired
orAR _ _ AuthenticationRequired = AuthenticationRequired
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
andAR _ Authorized Authorized = Authorized
andAR _ Authorized other = other
andAR _ other Authorized = other
andAR _ AuthenticationRequired other = other
andAR _ other AuthenticationRequired = other
-- and
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR _ reason@(Unauthorized x) _ = reason
andAR _ _ reason@(Unauthorized x) = reason
andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
orAP = liftAR orAR (== Authorized)
@ -190,8 +188,9 @@ trueAP = APPure . const $ return Authorized
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
-- TODO: I believe falseAP := adminAP
adminAP :: AccessPredicate
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
adminAP = APDB $ \case
-- Courses: access only to school admins
CourseR tid csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
@ -200,15 +199,15 @@ adminAP = APDB $ \case
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 MsgUnauthorizedSchoolAdmin) (c > 0)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
-- other routes: access to any admin is granted here
_other -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
case adrights of
(Just _) -> return Authorized
Nothing -> lift $ unauthorizedI $ MsgUnauthorized
guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
return Authorized
knownTags :: Map (CI Text) AccessPredicate
knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId

14
src/Utils.hs
View File

@ -93,11 +93,17 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
guardExceptT :: Monad m => e -> Bool -> ExceptT e m ()
guardExceptT err b = unless b $ throwE err
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err
guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m ()
guardMExceptT err b = unless b $ lift err >>= throwE
whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE
guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err
guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT