diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8b15af8b0..1595dc8d9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -171,7 +171,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. -UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} +UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt diff --git a/src/Foundation.hs b/src/Foundation.hs index ab9552bdf..601db3527 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -454,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of && NTop systemMessageTo >= cTime return Authorized - r -> $unsupportedAuthPredicate "time" r + r -> $unsupportedAuthPredicate AuthTime r tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -467,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized - r -> $unsupportedAuthPredicate "registered" r + r -> $unsupportedAuthPredicate AuthRegistered r tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized - r -> $unsupportedAuthPredicate "capacity" r + r -> $unsupportedAuthPredicate AuthCapacity r tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -482,41 +482,41 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ registered <= 0 return Authorized - r -> $unsupportedAuthPredicate "empty" r + r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized - r -> $unsupportedAuthPredicate "materials" r + r -> $unsupportedAuthPredicate AuthMaterials r tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized - r -> $unsupportedAuthPredicate "owner" r + r -> $unsupportedAuthPredicate AuthOwner r tagAccessPredicate AuthRated = APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized - r -> $unsupportedAuthPredicate "rated" r + r -> $unsupportedAuthPredicate AuthRated r tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == UserSubmissions return Authorized - r -> $unsupportedAuthPredicate "user-submissions" r + r -> $unsupportedAuthPredicate AuthUserSubmissions r tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == CorrectorSubmissions return Authorized - r -> $unsupportedAuthPredicate "corrector-submissions" r + r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID @@ -524,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of isAuthenticated <- isJust <$> liftHandlerT maybeAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized - r -> $unsupportedAuthPredicate "authentication" r + r -> $unsupportedAuthPredicate AuthAuthentication r tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) diff --git a/src/Utils.hs b/src/Utils.hs index 0bd5a400d..fed726e6f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 +import Data.Fixed (Centi) +import Data.Ratio ((%)) + ----------- @@ -87,7 +90,7 @@ guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () -data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route +data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route deriving (Eq, Ord, Typeable, Show) instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) @@ -95,8 +98,8 @@ 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) + $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|] + unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] @@ -204,17 +207,15 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out display = pack . show -} -textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? +textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercent x = lz <> pack (show rx) <> "%" where - round' :: Double -> Int -- avoids annoying warning - round' = round - rx :: Double - rx = fromIntegral (round' $ 1000.0*x) / 10.0 + rx :: Centi + rx = realToFrac (x * 100) lz = if rx < 10.0 then "0" else "" textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? -textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole) +textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter