feat: admins can efficiently generate many tokens for random users
This commit is contained in:
Gregor Kleen
parent
ba3b8d5a4f
commit
600bbe5d7e
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user