feat: admins can efficiently generate many tokens for random users

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

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

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 ->
+construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
-            let (b1, vals) = f info
+construct (E.ERaw p f)        = E.ERaw E.Parens $ \info ->
-                build ("?", [E.PersistList vals']) =
+  let (b1, vals) = f info
-                  (E.uncommas $ replicate (length vals') "?", vals')
+      build ("?", [E.PersistList vals']) =
-                build expr = expr
+        (E.uncommas $ replicate (length vals') "?", vals')
-             in  build (E.parensM p b1, vals)
+      build expr = expr
-          construct (E.ECompositeKey f) =
+   in  build (E.parensM p b1, vals)
-            E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty)
+construct (E.ECompositeKey f) =
-          construct (E.EAliasedValue i _) = 
+  E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty)
-            E.ERaw E.Never $ E.aliasedValueIdentToRawSql i
+construct (E.EAliasedValue i _) = 
-          construct (E.EValueReference i i') = 
+  E.ERaw E.Never $ E.aliasedValueIdentToRawSql i
-            E.ERaw E.Never $ E.valueReferenceToRawSql i 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

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)
+  { btfAuthority   :: HashSet (Either UserGroupName UserId)
-  , btfRoutes    :: Maybe (HashSet (Route UniWorX))
+  , btfImpersonate :: Maybe BTFImpersonate
-  , btfRestrict  :: HashMap (Route UniWorX) Value
+  , btfRoutes      :: Maybe (HashSet (Route UniWorX))
-  , btfAddAuth   :: Maybe AuthDNF
+  , btfRestrict    :: HashMap (Route UniWorX) Value
-  , btfExpiresAt :: Maybe (Maybe UTCTime)
+  , btfAddAuth     :: Maybe AuthDNF
-  , btfStartsAt  :: Maybe UTCTime
+  , 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

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