From 99d7b5813d13f0e8aa5b4cb77f890243f33f4172 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Jul 2018 18:48:11 +0200 Subject: [PATCH] Clean up auth-predicate evaluation --- messages/de.msg | 1 + src/Foundation.hs | 27 +++++++++------------------ src/Utils.hs | 19 ++++++++++++++++++- 3 files changed, 28 insertions(+), 19 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index db368200b..2104013c8 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -116,6 +116,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung +UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. diff --git a/src/Foundation.hs b/src/Foundation.hs index 8134af45a..2049e7172 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -183,6 +183,9 @@ instance RenderMessage UniWorX SheetFileType where SheetMarking -> renderMessage' MsgSheetMarking where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where + renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) + getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) @@ -343,9 +346,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req && NTop courseRegisterTo >= cTime return Authorized - r -> do - $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "time" r ) ,("registered", APDB $ \route _ -> case route of CourseR tid csh _ -> exceptT return return $ do @@ -358,9 +359,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized - r -> do - $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "registered" r ) ,("capacity", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do @@ -368,18 +367,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized - r -> do - $logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "capacity" r ) ,("materials", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh guard courseMaterialFree return Authorized - r -> do - $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "materials" r ) ,("owner", APDB $ \route _ -> case route of CSubmissionR _ _ _ cID _ -> exceptT return return $ do @@ -387,9 +382,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized - r -> do - $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "owner" r ) ,("rated", APDB $ \route _ -> case route of CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do @@ -397,9 +390,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized - r -> do - $logErrorS "AccessControl" $ "'!rated' used on route that doesn't support it: " <> tshow r - unauthorizedI MsgUnauthorized + r -> $unsupportedAuthPredicate "rated" r ) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) diff --git a/src/Utils.hs b/src/Utils.hs index 20c395570..36412836a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -4,7 +4,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult module Utils @@ -39,6 +40,11 @@ import Control.Monad.Catch import qualified Database.Esqueleto as E (Value, unValue) +import Language.Haskell.TH +import Instances.TH.Lift () + +import Text.Shakespeare.Text (st) + ----------- -- Yesod -- ----------- @@ -61,6 +67,17 @@ guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () +data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route + deriving (Eq, Ord, Typeable, Show) +instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) + +unsupportedAuthPredicate :: ExpQ +unsupportedAuthPredicate = do + logFunc <- logErrorS + [e| \tag route -> do + $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|] + unauthorizedI (UnsupportedAuthPredicate tag route) + |] ---------------------