From 87ab470072ba1a72235832006e9749e0838417de Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 29 May 2018 10:49:46 +0200 Subject: [PATCH 1/2] Minor refactor andAP and adminAP --- src/Foundation.hs | 25 ++++++++++++------------- src/Utils.hs | 14 ++++++++++---- 2 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 0d610b932..467bb59fc 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 0024dc117..868049a1f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 From 5e5c980459273a1fac570f893aa8261672a600be Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 5 Jun 2018 08:34:14 +0200 Subject: [PATCH 2/2] minor refactors --- src/Foundation.hs | 6 +++--- src/Utils.hs | 4 ++-- src/Utils/Common.hs | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 194d23bb4..e8d7324e3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -226,7 +226,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId 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) + guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -259,7 +259,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do - guardMExceptT (unauthorizedI MsgUnauthorizedCorrectorAny) . not $ Map.null resMap + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized ) ,("time", APDB $ \case @@ -286,7 +286,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId 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 MsgUnauthorizedParticipant) (c > 0) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized r -> do $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r diff --git a/src/Utils.hs b/src/Utils.hs index 14166ba53..e753dcbf2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -85,7 +85,7 @@ maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a -catchIfMaybeT pred act = catchIf pred (lift act) (const mzero) +catchIfMaybeT p act = catchIf p (lift act) (const mzero) --------------- -- Exception -- @@ -113,7 +113,7 @@ exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b exceptT f g = either f g <=< runExceptT catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a -catchIfMExceptT err pred act = catchIf pred (lift act) (throwE <=< lift . err) +catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) ------------ diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 56c437905..3a2e6c804 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -5,10 +5,10 @@ module Utils.Common where -- Common Utility Functions import Language.Haskell.TH -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except +-- import Control.Monad +-- import Control.Monad.Trans.Class +-- import Control.Monad.Trans.Maybe +-- import Control.Monad.Trans.Except ------------ -- Tuples --