Clean up auth-predicate evaluation

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.

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

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)
+    |]
 
 
 ---------------------