+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see .
+
+module V1_DeleteApnsVoipTokens where
+
+import Cassandra
+import Conduit
+import Data.Conduit.Internal (zipSources)
+import Data.Conduit.List qualified as C
+import Data.Id
+import Data.Text qualified as Text
+import Gundeck.DataMigration.Types
+import Imports
+import System.Logger.Class qualified as Log
+
+migration :: Migration
+migration =
+ Migration
+ { version = MigrationVersion 1,
+ text = "Delete APNS_VOIP push tokens",
+ action =
+ runConduit $
+ zipSources
+ (C.sourceList [(1 :: Int32) ..])
+ getPushTokens
+ .| C.mapM
+ ( \(i, p) ->
+ Log.info (Log.field "push tokens" (show (i * pageSize)))
+ >> pure p
+ )
+ .| C.concatMap (filter isVoipToken)
+ .| C.map (\(uid, token, app, transport, _mArn) -> (uid, token, app, transport))
+ .| C.mapM_ deletePushToken
+ }
+
+pageSize :: Int32
+pageSize = 1000
+
+----------------------------------------------------------------------------
+-- Queries
+
+-- | We do not use the push token types here because they will likely be
+-- changed in future breaking this migration.
+getPushTokens ::
+ MonadClient m =>
+ ConduitM () [(UserId, Text, Text, Int32, Maybe Text)] m ()
+getPushTokens = paginateC cql (paramsP LocalQuorum () pageSize) x5
+ where
+ cql :: PrepQuery R () (UserId, Text, Text, Int32, Maybe Text)
+ cql = "SELECT usr, ptoken, app, transport, arn FROM user_push"
+
+deletePushToken :: MonadClient m => (UserId, Text, Text, Int32) -> m ()
+deletePushToken pair =
+ retry x5 $ write cql (params LocalQuorum pair)
+ where
+ cql :: PrepQuery W (UserId, Text, Text, Int32) ()
+ cql = "DELETE FROM user_push where usr = ? AND ptoken = ? AND app = ? AND transport = ?"
+
+isVoipTransport :: Int32 -> Bool
+isVoipTransport 3 = True -- APNS_VOIP
+isVoipTransport 4 = True -- APNS_VOIP_SANDBOX
+isVoipTransport _ = False
+
+isVoipArn :: Text -> Bool
+isVoipArn arn =
+ case Text.splitOn ":" arn of
+ ["arn", "aws", "sns", _region, _accountId, topic] ->
+ case Text.splitOn "/" topic of
+ ("endpoint" : "APNS_VOIP" : _) -> True
+ ("endpoint" : "APNS_VOIP_SANDBOX" : _) -> True
+ _ -> False
+ _ -> False
+
+isVoipToken :: (UserId, Text, Text, Int32, Maybe Text) -> Bool
+isVoipToken (_, _, _, transport, mArn) =
+ isVoipTransport transport || maybe False isVoipArn mArn
diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs
index b1636f33b7..ea5fe96886 100644
--- a/services/gundeck/src/Gundeck/Aws.hs
+++ b/services/gundeck/src/Gundeck/Aws.hs
@@ -369,12 +369,17 @@ newtype Attributes = Attributes
-- Note [VoIP TTLs]
-- ~~~~~~~~~~~~~~~~
--- For GCM, APNS and APNS_SANDBOX, SNS treats the TTL "0"
+-- The TTL message attributes for APNS_VOIP and APNS_VOIP_SANDBOX are not
+-- documented but appear to work. The reason might be that TTLs were
+-- introduced before support for VoIP notifications. There is a catch,
+-- however. For GCM, APNS and APNS_SANDBOX, SNS treats the TTL "0"
-- specially, i.e. it forwards it to the provider where it has a special
--- meaning. Which means if the TTL is lower than the "dwell time" in SNS,
--- the notification is never sent to the provider. So we must specify a
--- reasonably large TTL for transient VoIP notifications, so that they are
--- not discarded already by SNS.
+-- meaning. That does not appear to be the case for APNS_VOIP and
+-- APNS_VOIP_SANDBOX, for which the TTL is interpreted normally, which means
+-- if the TTL is lower than the "dwell time" in SNS, the notification is
+-- never sent to the provider. So we must specify a reasonably large TTL
+-- for transient VoIP notifications, so that they are not discarded
+-- already by SNS.
--
-- cf. http://docs.aws.amazon.com/sns/latest/dg/sns-ttl.html
@@ -390,9 +395,13 @@ timeToLive t s = Attributes (Endo (ttlAttr s))
ttlNow GCM = "0"
ttlNow APNS = "0"
ttlNow APNSSandbox = "0"
+ ttlNow APNSVoIP = "15" -- See note [VoIP TTLs]
+ ttlNow APNSVoIPSandbox = "15" -- See note [VoIP TTLs]
ttlKey GCM = "AWS.SNS.MOBILE.GCM.TTL"
ttlKey APNS = "AWS.SNS.MOBILE.APNS.TTL"
ttlKey APNSSandbox = "AWS.SNS.MOBILE.APNS_SANDBOX.TTL"
+ ttlKey APNSVoIP = "AWS.SNS.MOBILE.APNS_VOIP.TTL"
+ ttlKey APNSVoIPSandbox = "AWS.SNS.MOBILE.APNS_VOIP_SANDBOX.TTL"
publish :: EndpointArn -> LT.Text -> Attributes -> Amazon (Either PublishError ())
publish arn txt attrs = do
diff --git a/services/gundeck/src/Gundeck/Aws/Arn.hs b/services/gundeck/src/Gundeck/Aws/Arn.hs
index 6c09b4bf36..17588d0810 100644
--- a/services/gundeck/src/Gundeck/Aws/Arn.hs
+++ b/services/gundeck/src/Gundeck/Aws/Arn.hs
@@ -135,6 +135,8 @@ arnTransportText :: Transport -> Text
arnTransportText GCM = "GCM"
arnTransportText APNS = "APNS"
arnTransportText APNSSandbox = "APNS_SANDBOX"
+arnTransportText APNSVoIP = "APNS_VOIP"
+arnTransportText APNSVoIPSandbox = "APNS_VOIP_SANDBOX"
-- Parsers --------------------------------------------------------------------
@@ -163,5 +165,7 @@ endpointTopicParser = do
transportParser :: Parser Transport
transportParser =
string "GCM" $> GCM
+ <|> string "APNS_VOIP_SANDBOX" $> APNSVoIPSandbox
+ <|> string "APNS_VOIP" $> APNSVoIP
<|> string "APNS_SANDBOX" $> APNSSandbox
<|> string "APNS" $> APNS
diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs
index 8b5b334f15..83ab2a692b 100644
--- a/services/gundeck/src/Gundeck/Instances.hs
+++ b/services/gundeck/src/Gundeck/Instances.hs
@@ -34,22 +34,21 @@ import Gundeck.Aws.Arn (EndpointArn)
import Gundeck.Types
import Imports
--- | We provide a instance for `Either Int Transport` so we can handle (ie., gracefully ignore
--- rather than crash on) deprecated values in cassandra. See "Gundeck.Push.Data".
-instance Cql (Either Int32 Transport) where
+instance Cql Transport where
ctype = Tagged IntColumn
- toCql (Right GCM) = CqlInt 0
- toCql (Right APNS) = CqlInt 1
- toCql (Right APNSSandbox) = CqlInt 2
- toCql (Left i) = CqlInt i -- (this is weird, but it's helpful for cleaning up deprecated tokens.)
+ toCql GCM = CqlInt 0
+ toCql APNS = CqlInt 1
+ toCql APNSSandbox = CqlInt 2
+ toCql APNSVoIP = CqlInt 3
+ toCql APNSVoIPSandbox = CqlInt 4
fromCql (CqlInt i) = case i of
- 0 -> pure $ Right GCM
- 1 -> pure $ Right APNS
- 2 -> pure $ Right APNSSandbox
- 3 -> pure (Left 3) -- `APNSVoIPV1` tokens are deprecated and will be ignored
- 4 -> pure (Left 4) -- `APNSVoIPSandboxV1` tokens are deprecated and will be ignored
+ 0 -> pure GCM
+ 1 -> pure APNS
+ 2 -> pure APNSSandbox
+ 3 -> pure APNSVoIP
+ 4 -> pure APNSVoIPSandbox
n -> Left $ "unexpected transport: " ++ show n
fromCql _ = Left "transport: int expected"
diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs
index 3e6fa5c05c..b11785fa77 100644
--- a/services/gundeck/src/Gundeck/Push.hs
+++ b/services/gundeck/src/Gundeck/Push.hs
@@ -36,6 +36,7 @@ import Control.Error
import Control.Exception (ErrorCall (ErrorCall))
import Control.Lens (to, view, (.~), (^.))
import Control.Monad.Catch
+import Control.Monad.Except (throwError)
import Data.Aeson as Aeson (Object)
import Data.Id
import Data.List.Extra qualified as List
@@ -350,10 +351,7 @@ nativeTargets psh rcps' alreadySent =
addresses :: Recipient -> m [Address]
addresses u = do
addrs <- mntgtLookupAddresses (u ^. recipientId)
- pure
- $ preference
- . filter (eligible u)
- $ addrs
+ pure $ filter (eligible u) addrs
eligible :: Recipient -> Address -> Bool
eligible u a
-- Never include the origin client.
@@ -373,17 +371,7 @@ nativeTargets psh rcps' alreadySent =
whitelistedOrNoWhitelist a =
null (psh ^. pushConnections)
|| a ^. addrConn `elem` psh ^. pushConnections
- -- Apply transport preference in case of alternative transports for the
- -- same client. If no explicit preference is given, the default preference depends on the priority.
- preference as =
- let pref = psh ^. pushNativeAps >>= view apsPreference
- in filter (pick (fromMaybe defPreference pref)) as
- where
- pick pr a = case a ^. addrTransport of
- GCM -> True
- APNS -> pr == ApsStdPreference
- APNSSandbox -> pr == ApsStdPreference
- defPreference = ApsStdPreference
+
check :: Either SomeException [a] -> m [a]
check (Left e) = mntgtLogErr e >> pure []
check (Right r) = pure r
@@ -391,21 +379,21 @@ nativeTargets psh rcps' alreadySent =
type AddTokenResponse = Either Public.AddTokenError Public.AddTokenSuccess
addToken :: UserId -> ConnId -> PushToken -> Gundeck AddTokenResponse
-addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) $ do
- (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum
- Log.info $
- "user"
- .= UUID.toASCIIBytes (toUUID uid)
- ~~ "token"
- .= Text.take 16 (tokenText (newtok ^. token))
- ~~ msg (val "Registering push token")
- continue newtok cur
- >>= either
- pure
- ( \a -> do
- Native.deleteTokens old (Just a)
- pure (Right $ Public.AddTokenSuccess newtok)
- )
+addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) $ runExceptT $ do
+ when (newtok ^. tokenTransport `elem` [APNSVoIP, APNSVoIPSandbox]) $
+ throwError Public.AddTokenErrorApnsVoipNotSupported
+
+ (cur, old) <- lift $ foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum
+ lift $
+ Log.info $
+ "user"
+ .= UUID.toASCIIBytes (toUUID uid)
+ ~~ "token"
+ .= Text.take 16 (tokenText (newtok ^. token))
+ ~~ msg (val "Registering push token")
+ addr <- continue newtok cur
+ lift $ Native.deleteTokens old (Just addr)
+ pure $ Public.AddTokenSuccess newtok
where
matching ::
PushToken ->
@@ -424,14 +412,14 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
continue ::
PushToken ->
Maybe Address ->
- Gundeck (Either AddTokenResponse Address)
+ ExceptT Public.AddTokenError Gundeck Address
continue t Nothing = create (0 :: Int) t
continue t (Just a) = update (0 :: Int) t (a ^. addrEndpoint)
create ::
Int ->
PushToken ->
- Gundeck (Either AddTokenResponse Address)
+ ExceptT Public.AddTokenError Gundeck Address
create n t = do
let trp = t ^. tokenTransport
let app = t ^. tokenApp
@@ -441,32 +429,33 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
ept <- Aws.execute aws' (Aws.createEndpoint uid trp env app tok)
case ept of
Left (Aws.EndpointInUse arn) -> do
- Log.info $ "arn" .= toText arn ~~ msg (val "ARN in use")
+ lift $ Log.info $ "arn" .= toText arn ~~ msg (val "ARN in use")
update (n + 1) t arn
Left (Aws.AppNotFound app') -> do
- Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'")
- pure (Left (Left Public.AddTokenErrorNotFound))
+ lift $ Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'")
+ throwError Public.AddTokenErrorNotFound
Left (Aws.InvalidToken _) -> do
- Log.info $
- "token"
- .= tokenText tok
- ~~ msg (val "Invalid push token.")
- pure (Left (Left Public.AddTokenErrorInvalid))
+ lift $
+ Log.info $
+ "token"
+ .= tokenText tok
+ ~~ msg (val "Invalid push token.")
+ throwError Public.AddTokenErrorInvalid
Left (Aws.TokenTooLong l) -> do
- Log.info $ msg ("Push token is too long: token length = " ++ show l)
- pure (Left (Left Public.AddTokenErrorTooLong))
+ lift $ Log.info $ msg ("Push token is too long: token length = " ++ show l)
+ throwError Public.AddTokenErrorTooLong
Right arn -> do
Data.insert uid trp app tok arn cid (t ^. tokenClient)
- pure (Right (mkAddr t arn))
+ pure $ mkAddr t arn
update ::
Int ->
PushToken ->
SnsArn EndpointTopic ->
- Gundeck (Either AddTokenResponse Address)
+ ExceptT Public.AddTokenError Gundeck Address
update n t arn = do
when (n >= 3) $ do
- Log.err $ msg (val "AWS SNS inconsistency w.r.t. " +++ toText arn)
+ lift $ Log.err $ msg (val "AWS SNS inconsistency w.r.t. " +++ toText arn)
throwM (mkError status500 "server-error" "Server Error")
aws' <- view awsEnv
ept <- Aws.execute aws' (Aws.lookupEndpoint arn)
@@ -474,7 +463,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
Nothing -> create (n + 1) t
Just ep ->
do
- updateEndpoint uid t arn ep
+ lift $ updateEndpoint uid t arn ep
Data.insert
uid
(t ^. tokenTransport)
@@ -483,7 +472,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
arn
cid
(t ^. tokenClient)
- pure (Right (mkAddr t arn))
+ pure $ mkAddr t arn
`catch` \case
-- Note: If the endpoint was recently deleted (not necessarily
-- concurrently), we may get an EndpointNotFound error despite
@@ -492,7 +481,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
-- possibly updates in general). We make another attempt to (re-)create
-- the endpoint in these cases instead of failing immediately.
Aws.EndpointNotFound {} -> create (n + 1) t
- Aws.InvalidCustomData {} -> pure (Left (Left Public.AddTokenErrorMetadataTooLong))
+ Aws.InvalidCustomData {} -> throwError Public.AddTokenErrorMetadataTooLong
ex -> throwM ex
mkAddr ::
diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs
index fa495b0e1f..c688f64f4d 100644
--- a/services/gundeck/src/Gundeck/Push/Data.hs
+++ b/services/gundeck/src/Gundeck/Push/Data.hs
@@ -38,29 +38,26 @@ import System.Logger.Class qualified as Log
lookup :: (MonadClient m, MonadLogger m) => UserId -> Consistency -> m [Address]
lookup u c = foldM mk [] =<< retry x1 (query q (params c (Identity u)))
where
- q :: PrepQuery R (Identity UserId) (UserId, Either Int32 Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId)
+ q :: PrepQuery R (Identity UserId) (UserId, Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId)
q = "select usr, transport, app, ptoken, arn, connection, client from user_push where usr = ?"
mk as r = maybe as (: as) <$> mkAddr r
insert :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m ()
-insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, Right t, a, p, e, o, c))
+insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, t, a, p, e, o, c))
where
- q :: PrepQuery W (UserId, Either Int32 Transport, AppName, Token, EndpointArn, ConnId, ClientId) ()
+ q :: PrepQuery W (UserId, Transport, AppName, Token, EndpointArn, ConnId, ClientId) ()
q = "insert into user_push (usr, transport, app, ptoken, arn, connection, client) values (?, ?, ?, ?, ?, ?, ?)"
updateArn :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> m ()
-updateArn uid transport app token arn = retry x5 $ write q (params LocalQuorum (arn, uid, Right transport, app, token))
+updateArn uid transport app token arn = retry x5 $ write q (params LocalQuorum (arn, uid, transport, app, token))
where
- q :: PrepQuery W (EndpointArn, UserId, Either Int32 Transport, AppName, Token) ()
+ q :: PrepQuery W (EndpointArn, UserId, Transport, AppName, Token) ()
q = {- `IF EXISTS`, but that requires benchmarking -} "update user_push set arn = ? where usr = ? and transport = ? and app = ? and ptoken = ?"
delete :: MonadClient m => UserId -> Transport -> AppName -> Token -> m ()
-delete u t = deleteAux u (Right t)
-
-deleteAux :: MonadClient m => UserId -> Either Int32 Transport -> AppName -> Token -> m ()
-deleteAux u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p))
+delete u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p))
where
- q :: PrepQuery W (UserId, Either Int32 Transport, AppName, Token) ()
+ q :: PrepQuery W (UserId, Transport, AppName, Token) ()
q = "delete from user_push where usr = ? and transport = ? and app = ? and ptoken = ?"
erase :: MonadClient m => UserId -> m ()
@@ -71,20 +68,16 @@ erase u = retry x5 $ write q (params LocalQuorum (Identity u))
mkAddr ::
(MonadClient m, MonadLogger m) =>
- (UserId, Either Int32 Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) ->
+ (UserId, Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) ->
m (Maybe Address)
-mkAddr (usr, trp, app, tok, arn, con, clt) = case (trp, clt, arn) of
- (Right t, Just c, Just a) -> pure $! Just $! Address usr a con (pushToken t app tok c)
+mkAddr (usr, trp, app, tok, arn, con, clt) = case (clt, arn) of
+ (Just c, Just a) -> pure $! Just $! Address usr a con (pushToken trp app tok c)
_ -> do
Log.info $
field "user" (toByteString usr)
~~ field "transport" (show trp)
~~ field "app" (appNameText app)
~~ field "token" (tokenText tok)
- ~~ msg
- ( val
- "Deleting legacy push token without a client or ARN, or with deprecated \
- \APNSVoIP* transports (transport type not shown in this message)."
- )
- deleteAux usr trp app tok
+ ~~ msg (val "Deleting legacy push token without a client or ARN.")
+ delete usr trp app tok
pure Nothing
diff --git a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs
index 07f783c36d..bf9e0e491c 100644
--- a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs
+++ b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs
@@ -54,6 +54,8 @@ renderText t prio x = case t of
GCM -> trim "GCM" (jsonString gcmJson)
APNS -> trim "APNS" (jsonString stdApnsJson)
APNSSandbox -> trim "APNS_SANDBOX" (jsonString stdApnsJson)
+ APNSVoIP -> trim "APNS_VOIP" (jsonString voipApnsJson)
+ APNSVoIPSandbox -> trim "APNS_VOIP_SANDBOX" (jsonString voipApnsJson)
where
gcmJson =
object
@@ -65,6 +67,11 @@ renderText t prio x = case t of
[ "aps" .= apsDict,
"data" .= x
]
+ voipApnsJson =
+ object
+ [ "aps" .= object [],
+ "data" .= x
+ ]
-- https://developer.apple.com/documentation/usernotifications/modifying_content_in_newly_delivered_notifications
-- Must contain `mutable-content: 1` and include an alert dictionary with title, subtitle, or body information.
-- Since we have no useful data here, we send a default payload that gets overridden by the client
@@ -87,6 +94,8 @@ maxPayloadSize :: Transport -> Int64
maxPayloadSize GCM = 4096
maxPayloadSize APNS = 4096
maxPayloadSize APNSSandbox = 4096
+maxPayloadSize APNSVoIP = 5120
+maxPayloadSize APNSVoIPSandbox = 5120
gcmPriority :: Priority -> Text
gcmPriority LowPriority = "normal"
diff --git a/services/gundeck/src/Gundeck/Schema/Run.hs b/services/gundeck/src/Gundeck/Schema/Run.hs
index ccec5141e4..247f7a6948 100644
--- a/services/gundeck/src/Gundeck/Schema/Run.hs
+++ b/services/gundeck/src/Gundeck/Schema/Run.hs
@@ -22,6 +22,7 @@ import Cassandra.Schema
import Control.Exception (finally)
import Gundeck.Schema.V1 qualified as V1
import Gundeck.Schema.V10 qualified as V10
+import Gundeck.Schema.V11 qualified as V11
import Gundeck.Schema.V2 qualified as V2
import Gundeck.Schema.V3 qualified as V3
import Gundeck.Schema.V4 qualified as V4
@@ -61,5 +62,6 @@ migrations =
V7.migration,
V8.migration,
V9.migration,
- V10.migration
+ V10.migration,
+ V11.migration
]
diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/gundeck/src/Gundeck/Schema/V11.hs
similarity index 52%
rename from services/galley/src/Galley/Effects/WaiRoutes/IO.hs
rename to services/gundeck/src/Gundeck/Schema/V11.hs
index 69da6a3824..c734aab0a2 100644
--- a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs
+++ b/services/gundeck/src/Gundeck/Schema/V11.hs
@@ -15,27 +15,21 @@
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see .
-module Galley.Effects.WaiRoutes.IO where
+module Gundeck.Schema.V11 (migration) where
-import Control.Error
-import Data.ProtocolBuffers qualified as Proto
-import Data.Serialize.Get
-import Galley.API.Error
-import Galley.Effects.WaiRoutes
+import Cassandra.Schema
import Imports
-import Network.Wai.Utilities hiding (Error)
-import Polysemy
-import Polysemy.Error
+import Text.RawString.QQ
-interpretWaiRoutes ::
- ( Member (Embed IO) r,
- Member (Error InvalidInput) r
- ) =>
- Sem (WaiRoutes ': r) a ->
- Sem r a
-interpretWaiRoutes = interpret $ \case
- FromJsonBody r -> exceptT (throw . InvalidPayload) pure (parseBody r)
- FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) pure (parseOptionalBody r)
- FromProtoBody r -> do
- b <- readBody r
- either (throw . InvalidPayload . fromString) pure (runGetLazy Proto.decodeMessage b)
+migration :: Migration
+migration = Migration 11 "Create table `data_migration`" $ do
+ schema'
+ [r|
+ CREATE TABLE data_migration (
+ id int,
+ version int,
+ descr text,
+ date timestamp,
+ PRIMARY KEY (id, version)
+ );
+ |]
diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs
index 0d9f128b4a..a91a075ac0 100644
--- a/services/gundeck/test/integration/API.hs
+++ b/services/gundeck/test/integration/API.hs
@@ -106,8 +106,7 @@ tests s =
],
testGroup
"Tokens"
- [ test s "register a push token" testRegisterPushToken,
- test s "unregister a push token" testUnregisterPushToken
+ [ test s "unregister a push token" testUnregisterPushToken
],
testGroup
"Websocket pingpong"
@@ -724,49 +723,6 @@ testUnregisterClient = do
-- ${env}-test (FCM), ${env}-test (APNS_SANDBOX), ${env}-com.wire.ent (APNS_SANDBOX),
-- with ${env} normally being integration.
-testRegisterPushToken :: TestM ()
-testRegisterPushToken = do
- g <- view tsGundeck
- uid <- randomUser
- -- Client 1 with 4 distinct tokens
- c1 <- randomClientId
- t11 <- randomToken c1 apnsToken
- t11' <- randomToken c1 apnsToken -- overlaps
- t12 <- randomToken c1 apnsToken {tName = AppName "com.wire.ent"} -- different app
- t13 <- randomToken c1 gcmToken -- different transport
-
- -- Client 2 with 1 token
- c2 <- randomClientId
- t21 <- randomToken c2 apnsToken
- t22 <- randomToken c2 gcmToken -- different transport
- t22' <- randomToken c2 gcmToken -- overlaps
-
- -- Register non-overlapping tokens
- _ <- registerPushToken uid t11
- _ <- registerPushToken uid t12
- _ <- registerPushToken uid t13
- _ <- registerPushToken uid t21
- _ <- registerPushToken uid t22
- -- Check tokens
- _tokens <- sortPushTokens <$> listPushTokens uid
- let _expected = sortPushTokens [t11, t12, t13, t21, t22]
- liftIO $ assertEqual "unexpected tokens" _expected _tokens
- -- Register overlapping tokens. The previous overlapped
- -- tokens should be removed, but none of the others.
- _ <- registerPushToken uid t11'
- _ <- registerPushToken uid t22'
- -- Check tokens
- _tokens <- sortPushTokens <$> listPushTokens uid
- let _expected = sortPushTokens [t11', t12, t13, t21, t22']
- liftIO $ assertEqual "unexpected tokens" _expected _tokens
- -- Native push tokens are deleted together with the client
- unregisterClient g uid c1 !!! const 200 === statusCode
- unregisterClient g uid c1 !!! const 200 === statusCode -- (deleting a non-existing token is ok.)
- unregisterClient g uid c2 !!! const 200 === statusCode
- unregisterClient g uid c2 !!! const 200 === statusCode -- (deleting a non-existing token is ok.)
- _tokens <- listPushTokens uid
- liftIO $ assertEqual "unexpected tokens" [] _tokens
-
-- TODO: Try to make this test more performant, this test takes too long right now
testRegisterTooManyTokens :: TestM ()
testRegisterTooManyTokens = do
@@ -838,8 +794,9 @@ testSharePushToken = do
gcmTok <- Token . T.decodeUtf8 . toByteString' <$> randomId
apsTok <- Token . T.decodeUtf8 . B16.encode <$> randomBytes 32
let tok1 = pushToken GCM "test" gcmTok
- let tok2 = pushToken APNS "com.wire.int.ent" apsTok
- forM_ [tok1, tok2] $ \tk -> do
+ let tok2 = pushToken APNSVoIP "com.wire.dev.ent" apsTok
+ let tok3 = pushToken APNS "com.wire.int.ent" apsTok
+ forM_ [tok1, tok2, tok3] $ \tk -> do
u1 <- randomUser
u2 <- randomUser
c1 <- randomClientId
@@ -995,10 +952,6 @@ connectUsersAndDevicesWithSendingClientsRaw ca uidsAndConnIds = do
assertPresences :: (UserId, [ConnId]) -> TestM ()
assertPresences (uid, conns) = wsAssertPresences uid (length conns)
--- | Sort 'PushToken's based on the actual 'token' values.
-sortPushTokens :: [PushToken] -> [PushToken]
-sortPushTokens = sortBy (compare `on` view token)
-
wsRun :: HasCallStack => CannonR -> UserId -> ConnId -> WS.ClientApp () -> TestM (Async ())
wsRun ca uid (ConnId con) app = do
liftIO $ async $ WS.runClientWith caHost caPort caPath caOpts caHdrs app
diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs
index 500ec668ff..2e525f7cf1 100644
--- a/services/gundeck/test/unit/Native.hs
+++ b/services/gundeck/test/unit/Native.hs
@@ -73,6 +73,8 @@ instance FromJSON SnsNotification where
[("GCM", String n)] -> parseGcm n
[("APNS", String n)] -> parseApns APNS n
[("APNS_SANDBOX", String n)] -> parseApns APNSSandbox n
+ [("APNS_VOIP", String n)] -> parseApns APNSVoIP n
+ [("APNS_VOIP_SANDBOX", String n)] -> parseApns APNSVoIPSandbox n
_ -> mempty
where
parseApns t n =
diff --git a/services/nginz/third_party/nginx-zauth-module/zauth_module.c b/services/nginz/third_party/nginx-zauth-module/zauth_module.c
index 11e3eba09e..6c8db823b4 100644
--- a/services/nginz/third_party/nginx-zauth-module/zauth_module.c
+++ b/services/nginz/third_party/nginx-zauth-module/zauth_module.c
@@ -469,8 +469,8 @@ static ngx_int_t zauth_parse_request (ngx_http_request_t * r) {
} else {
ngx_str_t name = ngx_string("zprovider");
ngx_str_t cookie = ngx_null_string;
- ngx_int_t index = ngx_http_parse_multi_header_lines(&r->headers_in.cookies, &name, &cookie);
- if (index != NGX_DECLINED) {
+ ngx_table_elt_t* cookie_header = ngx_http_parse_multi_header_lines(r, r->headers_in.cookie, &name, &cookie);
+ if (cookie_header != NULL) {
res = zauth_token_parse(cookie.data, cookie.len, &tkn);
}
}
diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs
index 52d502da6f..ea77775853 100644
--- a/services/spar/test-integration/Test/Spar/APISpec.hs
+++ b/services/spar/test-integration/Test/Spar/APISpec.hs
@@ -214,30 +214,9 @@ specInitiateLogin = do
specFinalizeLogin :: SpecWith TestEnv
specFinalizeLogin = do
describe "POST /sso/finalize-login" $ do
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
- -- Send authentication error and no cookie if response from SSO IdP was rejected
- context "rejectsSAMLResponseSayingAccessNotGranted" $ do
- it "responds with a very peculiar 'forbidden' HTTP response" $ do
- (user, tid) <- callCreateUserWithTeam
- (idp, (_, privcreds)) <- registerTestIdPWithMeta user
- authnreq <- negotiateAuthnRequest idp
- spmeta <- getTestSPMetadata tid
- authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False
- sparresp <- submitAuthnResponse tid authnresp
- liftIO $ do
- statusCode sparresp `shouldBe` 200
- let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp)
- bdy `shouldContain` ""
- bdy `shouldContain` ""
- bdy `shouldContain` "wire:sso:error:forbidden"
- bdy `shouldContain` "window.opener.postMessage({"
- bdy `shouldContain` "\"type\":\"AUTH_ERROR\""
- bdy `shouldContain` "\"payload\":{"
- bdy `shouldContain` "\"label\":\"forbidden\""
- bdy `shouldContain` "}, receiverOrigin)"
- hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header"
-
- -- @END
+ context "not granted" $ do
+ it "testRejectsSAMLResponseSayingAccessNotGranted - responds with a very peculiar 'forbidden' HTTP response" $
+ testRejectsSAMLResponseSayingAccessNotGranted
context "access granted" $ do
let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar ()
@@ -314,7 +293,6 @@ specFinalizeLogin = do
authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp3 spmeta authnreq True
loginSuccess =<< submitAuthnResponse tid3 authnresp
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
-- Do not authenticate if SSO IdP response is for different team
context "rejectsSAMLResponseInWrongTeam" $ do
it "fails" $ do
@@ -341,8 +319,6 @@ specFinalizeLogin = do
authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp2 spmeta authnreq True
loginFailure =<< submitAuthnResponse tid2 authnresp
- -- @END
-
context "user is created once, then deleted in team settings, then can login again." $ do
it "responds with 'allowed'" $ do
(ownerid, teamid) <- callCreateUserWithTeam
@@ -406,115 +382,10 @@ specFinalizeLogin = do
pending
context "bad AuthnResponse" $ do
- let check ::
- (IdP -> TestSpar SAML.AuthnRequest) ->
- (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) ->
- (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) ->
- (ResponseLBS -> IO ()) ->
- TestSpar ()
- check mkareq mkaresp submitaresp checkresp = do
- (ownerid, teamid) <- callCreateUserWithTeam
- (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid
- authnreq <- mkareq idp
- spmeta <- getTestSPMetadata teamid
- authnresp <-
- runSimpleSP $
- mkaresp
- privcreds
- idp
- spmeta
- authnreq
- sparresp <- submitaresp teamid authnresp
- liftIO $ checkresp sparresp
-
- shouldContainInBase64 :: String -> String -> Expectation
- shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle
- where
- Right (Just hay'') = decodeBase64 <$> validateBase64 hay'
- hay' = cs $ f hay
- where
- -- exercise to the reader: do this more idiomatically!
- f (splitAt 5 -> ("", s)) = g s
- f (_ : s) = f s
- f "" = ""
- g (splitAt 6 -> ("", _)) = ""
- g (c : s) = c : g s
- g "" = ""
-
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
- -- Do not authenticate if SSO IdP response is for unknown issuer
- it "rejectsSAMLResponseFromWrongIssuer" $ do
- let mkareq = negotiateAuthnRequest
- mkaresp privcreds idp spmeta authnreq =
- mkAuthnResponse
- privcreds
- (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|])
- spmeta
- authnreq
- True
- submitaresp = submitAuthnResponse
- checkresp sparresp = do
- statusCode sparresp `shouldBe` 404
- -- body should contain the error label in the title, the verbatim haskell error, and the request:
- (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found"
- (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)"
- (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\""
- check mkareq mkaresp submitaresp checkresp
-
- -- @END
-
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
- -- Do not authenticate if SSO IdP response is signed with wrong key
- it "rejectsSAMLResponseSignedWithWrongKey" $ do
- (ownerid, _teamid) <- callCreateUserWithTeam
- (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid
- let mkareq = negotiateAuthnRequest
- mkaresp _ idp spmeta authnreq =
- mkAuthnResponse
- badprivcreds
- idp
- spmeta
- authnreq
- True
- submitaresp = submitAuthnResponse
- checkresp sparresp = statusCode sparresp `shouldBe` 400
- check mkareq mkaresp submitaresp checkresp
-
- -- @END
-
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
- -- Do not authenticate if SSO IdP response has no corresponding request anymore
- it "rejectsSAMLResponseIfRequestIsStale" $ do
- let mkareq idp = do
- req <- negotiateAuthnRequest idp
- runSpar $ AReqIDStore.unStore (req ^. SAML.rqID)
- pure req
- mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True
- submitaresp = submitAuthnResponse
- checkresp sparresp = do
- statusCode sparresp `shouldBe` 200
- (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden"
- (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)"
- check mkareq mkaresp submitaresp checkresp
-
- -- @END
-
- -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3
- -- Do not authenticate if SSO IdP response is gone missing
- it "rejectsSAMLResponseIfResponseIsStale" $ do
- let mkareq = negotiateAuthnRequest
- mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True
- submitaresp teamid authnresp = do
- _ <- submitAuthnResponse teamid authnresp
- submitAuthnResponse teamid authnresp
- checkresp sparresp = do
- statusCode sparresp `shouldBe` 200
- (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden"
- check mkareq mkaresp submitaresp checkresp
-
- -- {- ORMOLU_DISABLE -} -- FUTUREWORK: try a newer release of ormolu?
- -- @END
- -- {- ORMOLU_ENABLE -}
+ it "testRejectsSAMLResponseFromWrongIssuer" testRejectsSAMLResponseFromWrongIssuer
+ it "testRejectsSAMLResponseSignedWithWrongKey" testRejectsSAMLResponseSignedWithWrongKey
+ it "testRejectsSAMLResponseIfRequestIsStale" testRejectsSAMLResponseIfRequestIsStale
+ it "testRejectsSAMLResponseIfResponseIsStale" testRejectsSAMLResponseIfResponseIsStale
context "IdP changes response format" $ do
it "treats NameId case-insensitively" $ do
@@ -1787,3 +1658,134 @@ specReAuthSsoUserWithPassword =
payload =
RequestBodyLBS . encode . object . maybeToList $
fmap ("password" .=) pw
+
+----------------------------------------------------------------------
+-- tests for bsi audit
+
+testRejectsSAMLResponseSayingAccessNotGranted :: TestSpar ()
+testRejectsSAMLResponseSayingAccessNotGranted = do
+ (user, tid) <- callCreateUserWithTeam
+ (idp, (_, privcreds)) <- registerTestIdPWithMeta user
+ authnreq <- negotiateAuthnRequest idp
+ spmeta <- getTestSPMetadata tid
+ authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False
+ sparresp <- submitAuthnResponse tid authnresp
+ liftIO $ do
+ statusCode sparresp `shouldBe` 200
+ let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp)
+ bdy `shouldContain` ""
+ bdy `shouldContain` ""
+ bdy `shouldContain` "wire:sso:error:forbidden"
+ bdy `shouldContain` "window.opener.postMessage({"
+ bdy `shouldContain` "\"type\":\"AUTH_ERROR\""
+ bdy `shouldContain` "\"payload\":{"
+ bdy `shouldContain` "\"label\":\"forbidden\""
+ bdy `shouldContain` "}, receiverOrigin)"
+ hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header"
+
+-- Do not authenticate if SSO IdP response is for unknown issuer
+testRejectsSAMLResponseFromWrongIssuer :: TestSpar ()
+testRejectsSAMLResponseFromWrongIssuer = do
+ let mkareq = negotiateAuthnRequest
+ mkaresp privcreds idp spmeta authnreq =
+ mkAuthnResponse
+ privcreds
+ (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|])
+ spmeta
+ authnreq
+ True
+ submitaresp = submitAuthnResponse
+ checkresp sparresp = do
+ statusCode sparresp `shouldBe` 404
+ -- body should contain the error label in the title, the verbatim haskell error, and the request:
+ (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found"
+ (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)"
+ (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\""
+ checkSamlFlow
+ mkareq
+ mkaresp
+ submitaresp
+ checkresp
+
+-- Do not authenticate if SSO IdP response is signed with wrong key
+testRejectsSAMLResponseSignedWithWrongKey :: TestSpar ()
+testRejectsSAMLResponseSignedWithWrongKey = do
+ (ownerid, _teamid) <- callCreateUserWithTeam
+ (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid
+ let mkareq = negotiateAuthnRequest
+ mkaresp _ idp spmeta authnreq =
+ mkAuthnResponse
+ badprivcreds
+ idp
+ spmeta
+ authnreq
+ True
+ submitaresp = submitAuthnResponse
+ checkresp sparresp = statusCode sparresp `shouldBe` 400
+ checkSamlFlow mkareq mkaresp submitaresp checkresp
+
+-- Do not authenticate if SSO IdP response has no corresponding request anymore
+testRejectsSAMLResponseIfRequestIsStale :: TestSpar ()
+testRejectsSAMLResponseIfRequestIsStale = do
+ let mkareq idp = do
+ req <- negotiateAuthnRequest idp
+ runSpar $ AReqIDStore.unStore (req ^. SAML.rqID)
+ pure req
+ mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True
+ submitaresp = submitAuthnResponse
+ checkresp sparresp = do
+ statusCode sparresp `shouldBe` 200
+ (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden"
+ (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)"
+ checkSamlFlow mkareq mkaresp submitaresp checkresp
+
+-- Do not authenticate if SSO IdP response is gone missing
+testRejectsSAMLResponseIfResponseIsStale :: TestSpar ()
+testRejectsSAMLResponseIfResponseIsStale = do
+ let mkareq = negotiateAuthnRequest
+ mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True
+ submitaresp teamid authnresp = do
+ _ <- submitAuthnResponse teamid authnresp
+ submitAuthnResponse teamid authnresp
+ checkresp sparresp = do
+ statusCode sparresp `shouldBe` 200
+ (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden"
+ checkSamlFlow mkareq mkaresp submitaresp checkresp
+
+----------------------------------------------------------------------
+-- Helpers
+
+shouldContainInBase64 :: String -> String -> Expectation
+shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle
+ where
+ Right (Just hay'') = decodeBase64 <$> validateBase64 hay'
+ hay' = cs $ f hay
+ where
+ -- exercise to the reader: do this more idiomatically!
+ f (splitAt 5 -> ("", s)) = g s
+ f (_ : s) = f s
+ f "" = ""
+ g (splitAt 6 -> ("", _)) = ""
+ g (c : s) = c : g s
+ g "" = ""
+
+checkSamlFlow ::
+ (IdP -> TestSpar SAML.AuthnRequest) ->
+ (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) ->
+ (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) ->
+ (ResponseLBS -> IO ()) ->
+ TestSpar ()
+checkSamlFlow mkareq mkaresp submitaresp checkresp = do
+ (ownerid, teamid) <- callCreateUserWithTeam
+ (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid
+ authnreq <- mkareq idp
+ spmeta <- getTestSPMetadata teamid
+ authnresp <-
+ runSimpleSP $
+ mkaresp
+ privcreds
+ idp
+ spmeta
+ authnreq
+ sparresp <- submitaresp teamid authnresp
+ liftIO $ checkresp sparresp
diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs
index e646e8e2a5..9247594fe8 100644
--- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs
+++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs
@@ -63,7 +63,7 @@ spec = do
specDeleteToken
specListTokens
describe "Miscellaneous" $ do
- it "doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded
+ it "testAuthIsNeeded - doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded
----------------------------------------------------------------------------
-- Token creation
@@ -74,9 +74,9 @@ specCreateToken = describe "POST /auth-tokens" $ do
it "works" testCreateToken
it "respects the token limit" testTokenLimit
it "requires the team to have no more than one IdP" testNumIdPs
- it "authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins
+ it "testCreateTokenAuthorizesOnlyAdmins - authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins
it "requires a password" testCreateTokenRequiresPassword
- it "works with verification code" testCreateTokenWithVerificationCode
+ it "testCreateTokenWithVerificationCode - works with verification code" testCreateTokenWithVerificationCode
-- FUTUREWORK: we should also test that for a password-less user, e.g. for an SSO user,
-- reauthentication is not required. We currently (2019-03-05) can't test that because
@@ -106,8 +106,6 @@ testCreateToken = do
listUsers_ (Just token) (Just fltr) (env ^. teSpar)
!!! const 200 === statusCode
--- @SF.Channel @TSFI.RESTfulAPI @S2
---
-- Test positive case but also that a SCIM token cannot be created with wrong
-- or missing second factor email verification code when this feature is enabled
testCreateTokenWithVerificationCode :: TestSpar ()
@@ -143,8 +141,6 @@ testCreateTokenWithVerificationCode = do
call $
post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email))
--- @END
-
unlockFeature :: GalleyReq -> TeamId -> TestSpar ()
unlockFeature galley tid =
call $ put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig, toByteString' Public.LockStatusUnlocked]) !!! const 200 === statusCode
@@ -223,7 +219,6 @@ testNumIdPs = do
createToken_ owner (CreateScimToken "drei" (Just defPassword) Nothing) (env ^. teSpar)
!!! checkErr 400 (Just "more-than-one-idp")
--- @SF.Provisioning @TSFI.RESTfulAPI @S2
-- Test that a token can only be created as a team owner
testCreateTokenAuthorizesOnlyAdmins :: TestSpar ()
testCreateTokenAuthorizesOnlyAdmins = do
@@ -256,8 +251,6 @@ testCreateTokenAuthorizesOnlyAdmins = do
(mkUser RoleAdmin >>= createToken')
!!! const 200 === statusCode
--- @END
-
-- | Test that for a user with a password, token creation requires reauthentication (i.e. the
-- field @"password"@ should be provided).
--
@@ -456,7 +449,6 @@ testDeletedTokensAreUnlistable = do
----------------------------------------------------------------------------
-- Miscellaneous tests
--- @SF.Provisioning @TSFI.RESTfulAPI @S2
-- This test verifies that the SCIM API responds with an authentication error
-- and can't be used if it receives an invalid secret token
-- or if no token is provided at all
@@ -468,5 +460,3 @@ testAuthIsNeeded = do
listUsers_ (Just invalidToken) Nothing (env ^. teSpar) !!! checkErr 401 Nothing
-- Try to do @GET /Users@ without a token and check that it fails
listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing
-
--- @END
diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs
index 5d23f93a9b..1ff2bdb258 100644
--- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs
+++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs
@@ -490,7 +490,7 @@ specCreateUser = describe "POST /Users" $ do
it "set locale to hr and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage (Just (Locale (Language HR) Nothing)) Nothing
it "set locale to default and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage Nothing Nothing
it "requires externalId to be present" $ testExternalIdIsRequired
- it "rejects invalid handle" $ testCreateRejectsInvalidHandle
+ it "testCreateRejectsInvalidHandle - rejects invalid handle" $ testCreateRejectsInvalidHandle
it "rejects occupied handle" $ testCreateRejectsTakenHandle
it "rejects occupied externalId (uref)" $ testCreateRejectsTakenExternalId True
it "rejects occupied externalId (email)" $ testCreateRejectsTakenExternalId False
@@ -840,9 +840,6 @@ testExternalIdIsRequired = do
createUser_ (Just tok) user' (env ^. teSpar)
!!! const 400 === statusCode
--- The next line contains a mapping from this test to the following test standards:
--- @SF.Provisioning @TSFI.RESTfulAPI @S2
---
-- Test that user creation fails if handle is invalid
testCreateRejectsInvalidHandle :: TestSpar ()
testCreateRejectsInvalidHandle = do
@@ -853,8 +850,6 @@ testCreateRejectsInvalidHandle = do
createUser_ (Just tok) (user {Scim.User.userName = "#invalid name"}) (env ^. teSpar)
!!! const 400 === statusCode
--- @END
-
-- | Test that user creation fails if handle is already in use (even on different team).
testCreateRejectsTakenHandle :: TestSpar ()
testCreateRejectsTakenHandle = do
diff --git a/services/spar/test/Test/Spar/Sem/NowSpec.hs b/services/spar/test/Test/Spar/Sem/NowSpec.hs
index 91cf3acdcd..57de87070d 100644
--- a/services/spar/test/Test/Spar/Sem/NowSpec.hs
+++ b/services/spar/test/Test/Spar/Sem/NowSpec.hs
@@ -27,7 +27,6 @@ import Data.Time.Calendar.Julian
import Imports
import Polysemy
import Polysemy.Input
-import SAML2.WebSSO.Types
import Test.Hspec
import Test.Hspec.QuickCheck
import Wire.Sem.Now.IO
@@ -41,4 +40,4 @@ spec :: Spec
spec = do
modifyMaxSuccess (const 1000) $ do
propsForInterpreter "nowToIO" $ fmap Identity . runM . nowToIO . runInputConst ()
- propsForInterpreter "nowToInput" $ pure . Identity . run . runInputConst someTime . nowToInput @Time . runInputConst ()
+ propsForInterpreter "nowToInput" $ pure . Identity . run . runInputConst someTime . nowToInput . runInputConst ()
diff --git a/tools/db/phone-users/.ormolu b/tools/db/phone-users/.ormolu
new file mode 120000
index 0000000000..ffc2ca9745
--- /dev/null
+++ b/tools/db/phone-users/.ormolu
@@ -0,0 +1 @@
+../../../.ormolu
\ No newline at end of file
diff --git a/tools/db/phone-users/README.md b/tools/db/phone-users/README.md
new file mode 100644
index 0000000000..ab03b0b8fa
--- /dev/null
+++ b/tools/db/phone-users/README.md
@@ -0,0 +1,44 @@
+# Phone users
+
+This program scans brig's users table and determines the number of users that can only login by phone/sms.
+
+Example usage:
+
+```shell
+phone-users --brig-cassandra-keyspace brig --galley-cassandra-keyspace galley -l 100000
+```
+
+Display usage:
+
+```shell
+phone-users -h
+```
+
+```text
+phone-users
+
+Usage: phone-users [--brig-cassandra-host HOST] [--brig-cassandra-port PORT]
+ [--brig-cassandra-keyspace STRING]
+ [--galley-cassandra-host HOST] [--galley-cassandra-port PORT]
+ [--galley-cassandra-keyspace STRING] [-l|--limit INT]
+
+ This program scans brig's users table and determines the number of users that
+ can only login by phone/sms
+
+Available options:
+ -h,--help Show this help text
+ --brig-cassandra-host HOST
+ Cassandra Host for brig (default: "localhost")
+ --brig-cassandra-port PORT
+ Cassandra Port for brig (default: 9042)
+ --brig-cassandra-keyspace STRING
+ Cassandra Keyspace for brig (default: "brig_test")
+ --galley-cassandra-host HOST
+ Cassandra Host for galley (default: "localhost")
+ --galley-cassandra-port PORT
+ Cassandra Port for galley (default: 9043)
+ --galley-cassandra-keyspace STRING
+ Cassandra Keyspace for galley
+ (default: "galley_test")
+ -l,--limit INT Limit the number of users to process
+```
diff --git a/services/brig/src/Brig/Team/Types.hs b/tools/db/phone-users/app/Main.hs
similarity index 78%
rename from services/brig/src/Brig/Team/Types.hs
rename to tools/db/phone-users/app/Main.hs
index e85bc4eb5b..be8658b800 100644
--- a/services/brig/src/Brig/Team/Types.hs
+++ b/tools/db/phone-users/app/Main.hs
@@ -1,6 +1,6 @@
-- This file is part of the Wire Server implementation.
--
--- Copyright (C) 2022 Wire Swiss GmbH
+-- Copyright (C) 2024 Wire Swiss GmbH
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
@@ -15,9 +15,9 @@
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see .
-module Brig.Team.Types where
+module Main where
-import Imports
+import qualified PhoneUsers.Lib as Lib
-data ShowOrHideInvitationUrl = ShowInvitationUrl | HideInvitationUrl
- deriving (Eq, Show)
+main :: IO ()
+main = Lib.main
diff --git a/tools/db/phone-users/default.nix b/tools/db/phone-users/default.nix
new file mode 100644
index 0000000000..2903ef5770
--- /dev/null
+++ b/tools/db/phone-users/default.nix
@@ -0,0 +1,48 @@
+# WARNING: GENERATED FILE, DO NOT EDIT.
+# This file is generated by running hack/bin/generate-local-nix-packages.sh and
+# must be regenerated whenever local packages are added or removed, or
+# dependencies are added or removed.
+{ mkDerivation
+, aeson
+, aeson-pretty
+, base
+, bytestring
+, cassandra-util
+, conduit
+, cql
+, gitignoreSource
+, imports
+, lens
+, lib
+, optparse-applicative
+, time
+, tinylog
+, types-common
+, wire-api
+}:
+mkDerivation {
+ pname = "phone-users";
+ version = "1.0.0";
+ src = gitignoreSource ./.;
+ isLibrary = true;
+ isExecutable = true;
+ libraryHaskellDepends = [
+ aeson
+ aeson-pretty
+ bytestring
+ cassandra-util
+ conduit
+ cql
+ imports
+ lens
+ optparse-applicative
+ time
+ tinylog
+ types-common
+ wire-api
+ ];
+ executableHaskellDepends = [ base ];
+ description = "Check users that are only able to login via phone";
+ license = lib.licenses.agpl3Only;
+ mainProgram = "phone-users";
+}
diff --git a/tools/db/phone-users/phone-users.cabal b/tools/db/phone-users/phone-users.cabal
new file mode 100644
index 0000000000..ab9c01f828
--- /dev/null
+++ b/tools/db/phone-users/phone-users.cabal
@@ -0,0 +1,96 @@
+cabal-version: 3.0
+name: phone-users
+version: 1.0.0
+synopsis: Check users that are only able to login via phone
+category: Network
+author: Wire Swiss GmbH
+maintainer: Wire Swiss GmbH
+copyright: (c) 2024 Wire Swiss GmbH
+license: AGPL-3.0-only
+build-type: Simple
+
+library
+ hs-source-dirs: src
+ exposed-modules:
+ PhoneUsers.Lib
+ PhoneUsers.Types
+
+ ghc-options:
+ -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
+ -funbox-strict-fields -threaded -with-rtsopts=-N
+ -Wredundant-constraints -Wunused-packages
+
+ build-depends:
+ , aeson
+ , aeson-pretty
+ , bytestring
+ , cassandra-util
+ , conduit
+ , cql
+ , imports
+ , lens
+ , optparse-applicative
+ , time
+ , tinylog
+ , types-common
+ , wire-api
+
+ default-extensions:
+ AllowAmbiguousTypes
+ BangPatterns
+ ConstraintKinds
+ DataKinds
+ DefaultSignatures
+ DeriveFunctor
+ DeriveGeneric
+ DeriveLift
+ DeriveTraversable
+ DerivingStrategies
+ DerivingVia
+ DuplicateRecordFields
+ EmptyCase
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GADTs
+ GeneralizedNewtypeDeriving
+ InstanceSigs
+ KindSignatures
+ LambdaCase
+ MultiParamTypeClasses
+ MultiWayIf
+ NamedFieldPuns
+ NoImplicitPrelude
+ OverloadedLabels
+ OverloadedRecordDot
+ OverloadedStrings
+ PackageImports
+ PatternSynonyms
+ PolyKinds
+ QuasiQuotes
+ RankNTypes
+ RecordWildCards
+ ScopedTypeVariables
+ StandaloneDeriving
+ TupleSections
+ TypeApplications
+ TypeFamilies
+ TypeFamilyDependencies
+ TypeOperators
+ UndecidableInstances
+ ViewPatterns
+
+executable phone-users
+ main-is: Main.hs
+ build-depends:
+ , base
+ , phone-users
+
+ hs-source-dirs: app
+ default-language: Haskell2010
+ ghc-options:
+ -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
+ -funbox-strict-fields -threaded -with-rtsopts=-N
+ -Wredundant-constraints -Wunused-packages
diff --git a/tools/db/phone-users/src/PhoneUsers/Lib.hs b/tools/db/phone-users/src/PhoneUsers/Lib.hs
new file mode 100644
index 0000000000..8c913b7a0b
--- /dev/null
+++ b/tools/db/phone-users/src/PhoneUsers/Lib.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2024 Wire Swiss GmbH
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see .
+
+module PhoneUsers.Lib where
+
+import Cassandra as C
+import Cassandra.Settings as C
+import Data.Conduit
+import qualified Data.Conduit.Combinators as Conduit
+import qualified Data.Conduit.List as CL
+import Data.Id (TeamId, UserId)
+import Data.Time
+import qualified Database.CQL.Protocol as CQL
+import Imports
+import Options.Applicative
+import PhoneUsers.Types
+-- import qualified System.IO as SIO
+import qualified System.Logger as Log
+import System.Logger.Message ((.=), (~~))
+import Wire.API.Team.Feature (FeatureStatus (FeatureStatusDisabled, FeatureStatusEnabled))
+import Wire.API.User (AccountStatus (Active))
+
+lookupClientsLastActiveTimestamps :: ClientState -> UserId -> IO [Maybe UTCTime]
+lookupClientsLastActiveTimestamps client u = do
+ runClient client $ runIdentity <$$> retry x1 (query selectClients (params One (Identity u)))
+ where
+ selectClients :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime))
+ selectClients = "SELECT last_active from clients where user = ?"
+
+readUsers :: ClientState -> ConduitM () [UserRow] IO ()
+readUsers client =
+ transPipe (runClient client) (paginateC selectUsersAll (paramsP One () 1000) x5)
+ .| Conduit.map (fmap CQL.asRecord)
+ where
+ selectUsersAll :: C.PrepQuery C.R () (CQL.TupleType UserRow)
+ selectUsersAll =
+ "SELECT id, email, phone, activated, status, team FROM user"
+
+getConferenceCalling :: ClientState -> TeamId -> IO (Maybe FeatureStatus)
+getConferenceCalling client tid = do
+ runClient client $ runIdentity <$$> retry x1 (query1 select (params One (Identity tid)))
+ where
+ select :: PrepQuery R (Identity TeamId) (Identity FeatureStatus)
+ select =
+ "select conference_calling from team_features where team_id = ?"
+
+process :: Log.Logger -> Maybe Int -> ClientState -> ClientState -> IO Result
+process logger limit brigClient galleyClient =
+ runConduit $
+ readUsers brigClient
+ -- .| Conduit.mapM (\chunk -> SIO.hPutStr stderr "." $> chunk)
+ .| Conduit.concat
+ .| (maybe (Conduit.filter (const True)) Conduit.take limit)
+ .| Conduit.mapM (getUserInfo logger brigClient galleyClient)
+ .| forever (CL.isolate 10000 .| (Conduit.foldMap infoToResult >>= yield))
+ .| Conduit.takeWhile ((> 0) . usersSearched)
+ .| CL.scan (<>) mempty
+ `fuseUpstream` Conduit.mapM_ (\r -> Log.info logger $ "intermediate_result" .= show r)
+
+getUserInfo :: Log.Logger -> ClientState -> ClientState -> UserRow -> IO UserInfo
+getUserInfo logger brigClient galleyClient ur = do
+ if not $ isCandidate
+ then pure NoPhoneUser
+ else do
+ -- should we give C* a little break here and add a small threadDelay?
+ -- threadDelay 200
+ lastActiveTimeStamps <- lookupClientsLastActiveTimestamps brigClient ur.id
+ now <- getCurrentTime
+ -- activity:
+ -- inactive: they have no client or client's last_active is greater than 90 days ago
+ -- active: otherwise
+ -- last_active is null on client creation, but it will be set once notifications are fetched
+ -- therefore we can consider empty last_active as inactive
+ let activeLast90Days = any (clientWasActiveLast90Days now) $ catMaybes lastActiveTimeStamps
+ userInfo <-
+ if activeLast90Days
+ then do
+ apu <- case ur.team of
+ Nothing -> pure ActivePersonalUser
+ Just tid -> do
+ isPaying <- isPayingTeam galleyClient tid
+ pure $
+ if isPaying
+ then ActiveTeamUser Free
+ else ActiveTeamUser Paid
+ Log.info logger $
+ "active_phone_user" .= show apu
+ ~~ "user_record" .= show ur
+ ~~ "last_active_timestamps" .= show lastActiveTimeStamps
+ ~~ Log.msg (Log.val "active phone user found")
+ pure apu
+ else pure InactiveLast90Days
+ pure $ PhoneUser userInfo
+ where
+ -- to qualify as an active phone user candidate, their account must be active and they must have a phone number but no verified email
+ isCandidate :: Bool
+ isCandidate =
+ ur.activated && ur.status == Just Active && isJust ur.phone && isNothing ur.email
+
+ clientWasActiveLast90Days :: UTCTime -> UTCTime -> Bool
+ clientWasActiveLast90Days now lastActive = diffUTCTime now lastActive < 90 * nominalDay
+
+ -- if conference_calling is enabled for the team, then it's a paying team
+ isPayingTeam :: ClientState -> TeamId -> IO Bool
+ isPayingTeam client tid = do
+ status <- getConferenceCalling client tid
+ pure $ case status of
+ Just FeatureStatusEnabled -> True
+ Just FeatureStatusDisabled -> False
+ Nothing -> False
+
+infoToResult :: UserInfo -> Result
+infoToResult = \case
+ NoPhoneUser -> mempty {usersSearched = 1}
+ PhoneUser InactiveLast90Days -> mempty {usersSearched = 1, phoneUsersTotal = 1, inactivePhoneUsers = 1}
+ PhoneUser ActivePersonalUser -> mempty {usersSearched = 1, phoneUsersTotal = 1, activePersonalPhoneUsers = 1}
+ PhoneUser (ActiveTeamUser Free) ->
+ Result
+ { usersSearched = 1,
+ phoneUsersTotal = 1,
+ inactivePhoneUsers = 0,
+ activePersonalPhoneUsers = 0,
+ activeFreeTeamPhoneUsers = 1,
+ activePaidTeamPhoneUsers = 0
+ }
+ PhoneUser (ActiveTeamUser Paid) ->
+ Result
+ { usersSearched = 1,
+ phoneUsersTotal = 1,
+ inactivePhoneUsers = 0,
+ activePersonalPhoneUsers = 0,
+ activeFreeTeamPhoneUsers = 0,
+ activePaidTeamPhoneUsers = 1
+ }
+
+main :: IO ()
+main = do
+ opts <- execParser (info (helper <*> optsParser) desc)
+ logger <- initLogger
+ brigClient <- initCas opts.brigDb logger
+ galleyClient <- initCas opts.galleyDb logger
+ putStrLn "scanning users table..."
+ res <- process logger opts.limit brigClient galleyClient
+ Log.info logger $ "result" .= show res
+ where
+ initLogger =
+ Log.new
+ . Log.setLogLevel Log.Info
+ . Log.setOutput Log.StdOut
+ . Log.setFormat Nothing
+ . Log.setBufSize 0
+ $ Log.defSettings
+ initCas settings l =
+ C.init
+ . C.setLogger (C.mkLogger l)
+ . C.setContacts settings.host []
+ . C.setPortNumber (fromIntegral settings.port)
+ . C.setKeyspace settings.keyspace
+ . C.setProtocolVersion C.V4
+ $ C.defSettings
+ desc = header "phone-users" <> progDesc "This program scans brig's users table and determines the number of users that can only login by phone/sms" <> fullDesc
diff --git a/tools/db/phone-users/src/PhoneUsers/Types.hs b/tools/db/phone-users/src/PhoneUsers/Types.hs
new file mode 100644
index 0000000000..fc60a3ee03
--- /dev/null
+++ b/tools/db/phone-users/src/PhoneUsers/Types.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2024 Wire Swiss GmbH
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see .
+
+module PhoneUsers.Types where
+
+import Cassandra as C
+import Control.Lens
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Encode.Pretty as A
+import qualified Data.ByteString.Lazy.Char8 as LC8
+import Data.Id
+import Data.Text.Strict.Lens
+import Database.CQL.Protocol hiding (Result)
+import Imports
+import Options.Applicative
+import Wire.API.User
+
+data CassandraSettings = CassandraSettings
+ { host :: String,
+ port :: Int,
+ keyspace :: C.Keyspace
+ }
+
+data Opts = Opts
+ { brigDb :: CassandraSettings,
+ galleyDb :: CassandraSettings,
+ limit :: Maybe Int
+ }
+
+optsParser :: Parser Opts
+optsParser =
+ Opts
+ <$> brigCassandraParser
+ <*> galleyCassandraParser
+ <*> optional
+ ( option
+ auto
+ ( long "limit"
+ <> short 'l'
+ <> metavar "INT"
+ <> help "Limit the number of users to process"
+ )
+ )
+
+galleyCassandraParser :: Parser CassandraSettings
+galleyCassandraParser =
+ CassandraSettings
+ <$> strOption
+ ( long "galley-cassandra-host"
+ <> metavar "HOST"
+ <> help "Cassandra Host for galley"
+ <> value "localhost"
+ <> showDefault
+ )
+ <*> option
+ auto
+ ( long "galley-cassandra-port"
+ <> metavar "PORT"
+ <> help "Cassandra Port for galley"
+ <> value 9043
+ <> showDefault
+ )
+ <*> ( C.Keyspace . view packed
+ <$> strOption
+ ( long "galley-cassandra-keyspace"
+ <> metavar "STRING"
+ <> help "Cassandra Keyspace for galley"
+ <> value "galley_test"
+ <> showDefault
+ )
+ )
+
+brigCassandraParser :: Parser CassandraSettings
+brigCassandraParser =
+ CassandraSettings
+ <$> strOption
+ ( long "brig-cassandra-host"
+ <> metavar "HOST"
+ <> help "Cassandra Host for brig"
+ <> value "localhost"
+ <> showDefault
+ )
+ <*> option
+ auto
+ ( long "brig-cassandra-port"
+ <> metavar "PORT"
+ <> help "Cassandra Port for brig"
+ <> value 9042
+ <> showDefault
+ )
+ <*> ( C.Keyspace . view packed
+ <$> strOption
+ ( long "brig-cassandra-keyspace"
+ <> metavar "STRING"
+ <> help "Cassandra Keyspace for brig"
+ <> value "brig_test"
+ <> showDefault
+ )
+ )
+
+data Result = Result
+ { usersSearched :: Int,
+ phoneUsersTotal :: Int,
+ inactivePhoneUsers :: Int,
+ activePersonalPhoneUsers :: Int,
+ activeFreeTeamPhoneUsers :: Int,
+ activePaidTeamPhoneUsers :: Int
+ }
+ deriving (Generic)
+
+instance A.ToJSON Result
+
+instance Show Result where
+ show = LC8.unpack . A.encodePretty
+
+instance Semigroup Result where
+ r1 <> r2 =
+ Result
+ { usersSearched = r1.usersSearched + r2.usersSearched,
+ phoneUsersTotal = r1.phoneUsersTotal + r2.phoneUsersTotal,
+ inactivePhoneUsers = r1.inactivePhoneUsers + r2.inactivePhoneUsers,
+ activePersonalPhoneUsers = r1.activePersonalPhoneUsers + r2.activePersonalPhoneUsers,
+ activeFreeTeamPhoneUsers = r1.activeFreeTeamPhoneUsers + r2.activeFreeTeamPhoneUsers,
+ activePaidTeamPhoneUsers = r1.activePaidTeamPhoneUsers + r2.activePaidTeamPhoneUsers
+ }
+
+instance Monoid Result where
+ mempty =
+ Result
+ { usersSearched = 0,
+ phoneUsersTotal = 0,
+ inactivePhoneUsers = 0,
+ activePersonalPhoneUsers = 0,
+ activeFreeTeamPhoneUsers = 0,
+ activePaidTeamPhoneUsers = 0
+ }
+
+type Activated = Bool
+
+data UserRow = UserRow
+ { id :: UserId,
+ email :: Maybe Email,
+ phone :: Maybe Phone,
+ activated :: Activated,
+ status :: Maybe AccountStatus,
+ team :: Maybe TeamId
+ }
+ deriving (Generic)
+
+instance A.ToJSON UserRow
+
+recordInstance ''UserRow
+
+instance Show UserRow where
+ show = LC8.unpack . A.encodePretty
+
+data TeamUser = Free | Paid
+ deriving (Show)
+
+data UserInfo = NoPhoneUser | PhoneUser PhoneUserInfo
+ deriving (Show)
+
+data PhoneUserInfo
+ = InactiveLast90Days
+ | ActivePersonalUser
+ | ActiveTeamUser TeamUser
+ deriving (Show)
diff --git a/tools/stern/default.nix b/tools/stern/default.nix
index 4461863a63..5c9adf4ce7 100644
--- a/tools/stern/default.nix
+++ b/tools/stern/default.nix
@@ -49,7 +49,6 @@
, utf8-string
, uuid
, wai
-, wai-routing
, wai-utilities
, wire-api
, yaml
@@ -92,7 +91,6 @@ mkDerivation {
utf8-string
uuid
wai
- wai-routing
wai-utilities
wire-api
yaml
diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs
index e5b74b1b11..0f3b0aa5e4 100644
--- a/tools/stern/src/Stern/App.hs
+++ b/tools/stern/src/Stern/App.hs
@@ -39,8 +39,7 @@ import Data.UUID (toString)
import Data.UUID.V4 qualified as UUID
import Imports
import Network.HTTP.Client (responseTimeoutMicro)
-import Network.Wai (Request, ResponseReceived)
-import Network.Wai.Routing (Continue)
+import Network.Wai (Request, Response, ResponseReceived)
import Network.Wai.Utilities (Error (..), lookupRequestId)
import Network.Wai.Utilities.Error qualified as WaiError
import Network.Wai.Utilities.Response (json, setStatus)
@@ -125,6 +124,8 @@ runAppT e (AppT ma) = runReaderT ma e
type Handler = ExceptT Error App
+type Continue m = Response -> m ResponseReceived
+
runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived
runHandler e r h k = do
i <- reqId (lookupRequestId r)
diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal
index 9a31ed6591..9d3634cccc 100644
--- a/tools/stern/stern.cabal
+++ b/tools/stern/stern.cabal
@@ -104,7 +104,6 @@ library
, utf8-string
, uuid >=1.3
, wai >=3.0
- , wai-routing >=0.10
, wai-utilities >=0.9
, wire-api >=0.1
, yaml
diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs
index ebb65c85e3..acfa6afa73 100644
--- a/tools/stern/test/integration/Util.hs
+++ b/tools/stern/test/integration/Util.hs
@@ -240,5 +240,7 @@ getTeamMember getter tid gettee = do
getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> UserId -> TeamId -> UserId -> m TeamMember
getTeamMember' g getter tid gettee = do
- r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter)