From 600bbe5d7e9051e4a4eac540b01ff358666ebc9c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Mar 2021 16:02:00 +0100 Subject: [PATCH] feat: admins can efficiently generate many tokens for random users --- messages/uniworx/misc/de-de-formal.msg | 10 +++ messages/uniworx/misc/en-eu.msg | 10 +++ src/Database/Esqueleto/Utils.hs | 53 +++++++++---- src/Handler/Admin/Tokens.hs | 101 +++++++++++++++++++++++-- src/Model/Types/File.hs | 6 ++ 5 files changed, 156 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index f2e4518b1..cd3b87a3b 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -2936,6 +2936,16 @@ BearerTokenExpires: Ablaufzeitpunkt BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufzeitpunkt angegeben, ist das Token für immer gültig. BearerTokenOverrideStart: Startzeitpunkt BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft. +BearerTokenImpersonate: Auftreten als +BearerTokenImpersonateNone: Keine Änderung +BearerTokenImpersonateSingle: Einzelner Benutzer +BearerTokenImpersonateRandom: Zufälliger Benutzer +BearerTokenImpersonateSingleUser: Benutzer +BearerTokenImpersonateRandomNegative: Anzahl muss positiv sein +BearerTokenImpersonateRandomCount: Anzahl +BearerTokenImpersonateUnknownUser email@UserEmail: Ein Nutzer mit E-Mail #{email} ist dem System nicht bekannt +BearerTokenImpersonateRandomWeightActivity: Nach Aktivität gewichten +BearerTokenArchiveName: tokens.zip FaqTitle: Häufig gestellte Fragen AdditionalFaqs: Weitere häufig gestellte Fragen diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 892b593f9..beae162cc 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -2936,6 +2936,16 @@ BearerTokenExpires: Expiration time BearerTokenExpiresTip: If no expiration time is given, the token will not expire. It will be valid forever. BearerTokenOverrideStart: Start time BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used. +BearerTokenImpersonate: Impersonate +BearerTokenImpersonateNone: No one +BearerTokenImpersonateSingle: A specific user +BearerTokenImpersonateRandom: Random users +BearerTokenImpersonateSingleUser: User +BearerTokenImpersonateRandomNegative: Count must be positive +BearerTokenImpersonateRandomCount: Count +BearerTokenImpersonateUnknownUser email: Could not find any user with email #{email} +BearerTokenImpersonateRandomWeightActivity: Weight by activity +BearerTokenArchiveName: tokens.zip FaqTitle: Frequently asked questions AdditionalFaqs: More frequently asked questions diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index ca7bb0c46..a17b30cf1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -20,7 +20,7 @@ module Database.Esqueleto.Utils , selectExists, selectNotExists , SqlHashable , sha256 - , maybe, maybe2, maybeEq, unsafeCoalesce + , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , bool , max, min , abs @@ -30,7 +30,7 @@ module Database.Esqueleto.Utils , unKey , selectCountRows , selectMaybe - , day, diffDays + , day, diffDays, diffTimes , exprLift , module Database.Esqueleto.Utils.TH ) where @@ -53,6 +53,8 @@ import Crypto.Hash (Digest, SHA256) import Data.Coerce (Coercible) +import Data.Time.Clock (NominalDiffTime) + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -127,19 +129,20 @@ substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3) , strVals <> fromiVals <> foriVals ) substring a b c = substring (construct a) (construct b) (construct c) - where construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) - construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> - let (b1, vals) = f info - build ("?", [E.PersistList vals']) = - (E.uncommas $ replicate (length vals') "?", vals') - build expr = expr - in build (E.parensM p b1, vals) - construct (E.ECompositeKey f) = - E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) - construct (E.EAliasedValue i _) = - E.ERaw E.Never $ E.aliasedValueIdentToRawSql i - construct (E.EValueReference i i') = - E.ERaw E.Never $ E.valueReferenceToRawSql i i' + +construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) +construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> + let (b1, vals) = f info + build ("?", [E.PersistList vals']) = + (E.uncommas $ replicate (length vals') "?", vals') + build expr = expr + in build (E.parensM p b1, vals) +construct (E.ECompositeKey f) = + E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) +construct (E.EAliasedValue i _) = + E.ERaw E.Never $ E.aliasedValueIdentToRawSql i +construct (E.EValueReference i i') = + E.ERaw E.Never $ E.valueReferenceToRawSql i i' and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and = F.foldr (E.&&.) true @@ -338,6 +341,13 @@ maybeEq a b = E.case_ ] (E.else_ $ a E.==. b) +guardMaybe :: PersistField a + => E.SqlExpr (E.Value (Maybe a)) + -> E.SqlQuery (E.SqlExpr (E.Value a)) +guardMaybe mVal = do + E.where_ $ isJust mVal + return $ E.veryUnsafeCoerceSqlExprValue mVal + bool :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) @@ -419,11 +429,22 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" -infixl 6 `diffDays` +infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) -- ^ PostgreSQL is weird. diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b + +diffTimes :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value NominalDiffTime) +diffTimes a b = unsafeExtract "EPOCH" $ a E.-. b + +unsafeExtract :: String -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) +unsafeExtract extr (E.ERaw vP vF) = E.ERaw E.Never $ \info -> + let (vTLB, vVals) = vF info + in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parensM vP vTLB) + , vVals + ) +unsafeExtract extr v = unsafeExtract extr $ construct v class ExprLift e a | e -> a where diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index f78bb5c1b..fbbd6e1de 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -8,6 +8,7 @@ import Handler.Utils import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson @@ -16,15 +17,44 @@ import Data.Map ((!), (!?)) import qualified Data.Text as Text +import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Utils as E +import qualified Control.Monad.Random.Class as Random +import Control.Monad.Random.Strict (evalRand, Rand) + +import qualified Data.Conduit.List as C (unfoldM) +import qualified Data.Conduit.Combinators as C + +import qualified Crypto.Random as Crypto + + +data BTFImpersonate + = BTFISingle + { btfiUser :: UserId + } + | BTFIRandom + { btfiCount :: Int64 + , btfiWeightActivity :: Bool + } + deriving (Eq, Ord, Generic, Typeable) + +data BTFImpersonate' = BTFINone' | BTFISingle' | BTFIRandom' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving (Universe, Finite, Hashable) +nullaryPathPiece ''BTFImpersonate' $ camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''BTFImpersonate' $ ("BearerTokenImpersonate" <>) . dropPrefix "BTFI" . dropSuffix "'" + data BearerTokenForm = BearerTokenForm - { btfAuthority :: HashSet (Either UserGroupName UserId) - , btfRoutes :: Maybe (HashSet (Route UniWorX)) - , btfRestrict :: HashMap (Route UniWorX) Value - , btfAddAuth :: Maybe AuthDNF - , btfExpiresAt :: Maybe (Maybe UTCTime) - , btfStartsAt :: Maybe UTCTime - } + { btfAuthority :: HashSet (Either UserGroupName UserId) + , btfImpersonate :: Maybe BTFImpersonate + , btfRoutes :: Maybe (HashSet (Route UniWorX)) + , btfRestrict :: HashMap (Route UniWorX) Value + , btfAddAuth :: Maybe AuthDNF + , btfExpiresAt :: Maybe (Maybe UTCTime) + , btfStartsAt :: Maybe UTCTime + } deriving (Generic, Typeable) bearerTokenForm :: WForm Handler (FormResult BearerTokenForm) bearerTokenForm = do @@ -37,6 +67,15 @@ bearerTokenForm = do btfAuthority' = (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty) + let + btfiActs = mapF $ \case + BTFINone' -> pure Nothing + BTFISingle' -> Just . BTFISingle <$> apreq (checkMap (left MsgBearerTokenImpersonateUnknownUser) Right $ userField False Nothing) (fslpI MsgBearerTokenImpersonateSingleUser (mr MsgLdapIdentificationOrEmail)) Nothing + BTFIRandom' -> fmap Just $ BTFIRandom + <$> apreq (posIntFieldI MsgBearerTokenImpersonateRandomNegative) (fslI MsgBearerTokenImpersonateRandomCount) (Just 1) + <*> apopt checkBoxField (fslI MsgBearerTokenImpersonateRandomWeightActivity) (Just True) + btfImpersonate' <- multiActionW btfiActs (fslI MsgBearerTokenImpersonate) Nothing + let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") MsgBearerTokenRouteMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True) @@ -68,6 +107,7 @@ bearerTokenForm = do return $ BearerTokenForm <$> btfAuthority' + <*> btfImpersonate' <*> btfRoutes' <*> btfRestrict' <*> btfAddAuth' @@ -86,7 +126,52 @@ postAdminTokensR = do & HashSet.insert (Right uid) & HashSet.map (left toJSON) - fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' Nothing (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt + case btfImpersonate of + Just BTFIRandom{..} -> do + MsgRenderer mr <- getMsgRenderer + now <- liftIO getCurrentTime + users <- runDB $ if + | not btfiWeightActivity -> fmap (fmap E.unValue) . E.select . E.from $ \user -> do + E.orderBy [E.asc $ E.random_ @Int64] + E.limit btfiCount + return $ user E.^. UserId + | otherwise -> do + users'' <- E.select . E.from $ \user -> + return ( user E.^. UserId + , E.maybe E.nothing (E.just . E.diffTimes (E.val now)) $ user E.^. UserLastAuthentication + ) + let users :: Map UserId (Maybe Rational) + users = Map.fromList $ users'' <&> \(E.Value uid', E.Value mDiff) -> (uid', toRational <$> mDiff) + chooseUsers :: ConduitT () UserId (Rand Crypto.ChaChaDRG) () + chooseUsers = C.unfoldM chooseUsers' (users, btfiCount) + where chooseUsers' (users', n) = runMaybeT $ do + guard $ n > 0 + let getWeighted = MaybeT . Random.weightedMay . mapMaybe (\(uid', mDiff) -> (uid', ) <$> mDiff) $ Map.toList users' + getUnweighted = MaybeT . Random.uniformMay $ Map.keysSet users' + user <- getWeighted <|> getUnweighted + return (user, (Map.delete user users', pred n)) + drg <- liftIO Crypto.drgNew + return . flip evalRand drg . runConduit $ chooseUsers .| C.foldMap pure + + let + toTokenFile :: UserId -> DB (Either Void DBFile) + toTokenFile uid' = do + cID <- encrypt uid' :: DB CryptoUUIDUser + tok <- encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' (Just uid') (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt + return . Right $ File + { fileTitle = unpack (toPathPiece cID) <.> "jwt" + , fileModified = now + , fileContent = Just . yield $ unJwt tok + } + + sendResponse <=< serveZipArchive' ((ensureExtension `on` unpack) extensionZip (mr MsgBearerTokenArchiveName)) $ yieldMany users .| C.mapM toTokenFile + + _other -> do + let btfImpersonate' = btfImpersonate <&> \case + BTFISingle{..} -> btfiUser + _other -> error "btfImpersonate: not BTFISingle where expected" + + fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfImpersonate' (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt siteLayoutMsg MsgMenuAdminTokens $ do setTitleI MsgMenuAdminTokens diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index be8922eff..f397a66e6 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE EmptyCase #-} module Model.Types.File ( FileContentChunkReference(..), FileContentReference(..) @@ -169,6 +170,11 @@ class HasFileReference record where _FileReference :: Iso' record (FileReference, FileReferenceResidual record) +instance HasFileReference Void where + data FileReferenceResidual Void + + _FileReference = iso (\case {}) $ views _2 (\case {}) + instance HasFileReference FileReference where data FileReferenceResidual FileReference = FileReferenceResidual