Minor cleanup

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
 

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)
 

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}|]
+        $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
-        unauthorizedI (UnsupportedAuthPredicate tag 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
+   rx :: Centi
-   round' = round
+   rx = realToFrac (x * 100)
-   rx :: Double
-   rx = fromIntegral (round' $ 1000.0*x) / 10.0
    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