Add support for disallowing certain phone number prefixes

libs/brig-types/src/Brig/Types/Common.hs

@@ -150,6 +150,43 @@ instance FromJSON PhoneBudgetTimeout where
 instance ToJSON PhoneBudgetTimeout where
     toJSON (PhoneBudgetTimeout t) = object [ "expires_in" .= t ]
 
+-----------------------------------------------------------------------------
+-- PhonePrefix (for excluding from SMS/calling)
+
+newtype PhonePrefix = PhonePrefix { fromPhonePrefix :: Text } deriving (Eq, Show, ToJSON)
+
+-- | Parses a phone number prefix with a mandatory leading '+'.
+parsePhonePrefix :: Text -> Maybe PhonePrefix
+parsePhonePrefix p
+    | isValidPhonePrefix p  = Just $ PhonePrefix p
+    | otherwise             = Nothing
+
+-- | Checks whether a phone number prefix is valid,
+-- i.e. it is like a E.164 format phone number, but shorter
+-- (with a mandatory leading '+', followed by 1-15 digits.)
+isValidPhonePrefix :: Text -> Bool
+isValidPhonePrefix = isRight . parseOnly e164Prefix
+  where
+    e164Prefix = char '+' *> count 1 digit *> count 14 (optional digit) *> endOfInput
+
+-- | get all valid prefixes of a phone number or phone number prefix
+-- e.g. from +123456789 get prefixes ["+1", "+12", "+123", ..., "+123456789" ]
+allPrefixes :: Text -> [PhonePrefix]
+allPrefixes t = catMaybes $ parsePhonePrefix <$> Text.inits t
+
+instance FromJSON PhonePrefix where
+    parseJSON = withText "PhonePrefix" $ \s ->
+        case parsePhonePrefix s of
+            Just p  -> return p
+            Nothing -> fail $ "Invalid phone number prefix: [" ++ show s
+                            ++ "]. Expected format similar to E.164 (with 1-15 digits after the +)."
+
+instance FromByteString PhonePrefix where
+    parser = parser >>= maybe (fail "Invalid phone") return . parsePhonePrefix
+
+instance ToByteString PhonePrefix where
+    builder = builder . fromPhonePrefix
+
 -----------------------------------------------------------------------------
 -- UserIdentity
 

services/brig/brig.cabal

@@ -293,6 +293,7 @@ executable brig-schema
         V53
         V54
         V55
+        V56
 
     build-depends:
         base

services/brig/schema/src/Main.hs

@@ -52,6 +52,7 @@ import qualified V52
 import qualified V53
 import qualified V54
 import qualified V55
+import qualified V56
 
 main :: IO ()
 main = do
@@ -104,4 +105,5 @@ main = do
         , V53.migration
         , V54.migration
         , V55.migration
+        , V56.migration
         ] `finally` close l

services/brig/schema/src/V56.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module V56 (migration) where
+
+import Imports
+import Cassandra.Schema
+import Text.RawString.QQ
+
+migration :: Migration
+migration = Migration 56 "Add table to exclude phone number prefixes" $ do
+    -- A table for manual excluding of phone number prefixes that abuse sms sending
+    -- and/or calling.
+    --
+    -- Operations we need to support:
+    --   * Add a new prefix of arbitrary length
+    --   * Remove a prefix
+    --   * Given a phone number, check whether it matches any existing prefix
+    void $ schema' [r|
+        create table if not exists excluded_phones
+            ( prefix text
+            , primary key (prefix)
+            )
+    |]
+

services/brig/src/Brig/API.hs

@@ -190,6 +190,17 @@ sitemap o = do
     post "/i/users/blacklist" (continue addBlacklist) $
         param "email" ||| param "phone"
 
+    -- given a phone number (or phone number prefix), see whether
+    -- it is blocked via a prefix (and if so, via which specific prefix)
+    get "/i/users/phone-prefixes/:prefix" (continue getPhonePrefixes) $
+        capture "prefix"
+
+    delete "/i/users/phone-prefixes/:prefix" (continue deleteFromPhonePrefix) $
+        capture "prefix"
+
+    post "/i/users/phone-prefixes/:prefix" (continue addPhonePrefix) $
+        capture "prefix"
+
     -- is :uid not team owner, or there are other team owners?
     get "/i/users/:uid/can-be-deleted/:tid" (continue canBeDeleted) $
       capture "uid"
@@ -1400,6 +1411,26 @@ addBlacklist emailOrPhone = do
     void . lift $ API.blacklistInsert emailOrPhone
     return empty
 
+-- | Get any matching prefixes. Also try for shorter prefix matches,
+-- i.e. checking for +123456 also checks for +12345, +1234, ...
+getPhonePrefixes :: PhonePrefix -> Handler Response
+getPhonePrefixes prefix = do
+    results <- lift $ API.phonePrefixGet prefix
+    return $ case results of
+        []      -> setStatus status404 empty
+        _       -> json results
+
+-- | Delete a phone prefix entry (must be an exact match)
+deleteFromPhonePrefix :: PhonePrefix -> Handler Response
+deleteFromPhonePrefix prefix = do
+    void . lift $ API.phonePrefixDelete prefix
+    return empty
+
+addPhonePrefix :: PhonePrefix -> Handler Response
+addPhonePrefix prefix = do
+    void . lift $ API.phonePrefixInsert prefix
+    return empty
+
 canBeDeleted :: UserId ::: TeamId -> Handler Response
 canBeDeleted (uid ::: tid) = do
     onlyOwner <- lift (Team.teamOwnershipStatus uid tid)

services/brig/src/Brig/API/User.hs

@@ -58,6 +58,11 @@ module Brig.API.User
     , blacklistDelete
     , blacklistInsert
 
+      -- * Phone Prefix blocking
+    , phonePrefixGet
+    , phonePrefixDelete
+    , phonePrefixInsert
+
       -- * Utilities
     , fetchUserIdentity
     ) where
@@ -524,15 +529,23 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of
             Just (Just uid, c) -> sendActivationEmail   ek c        uid -- User re-requesting activation
 
     Right phone -> do
-        pk <- maybe (throwE $ InvalidRecipient (userPhoneKey phone))
-                    (return . userPhoneKey)
+        -- validatePhone returns the canonical E.164 phone number format
+        canonical <- maybe (throwE $ InvalidRecipient (userPhoneKey phone))
+                    return
                     =<< lift (validatePhone phone)
+        let pk = userPhoneKey canonical
         exists <- lift $ isJust <$> Data.lookupKey pk
         when exists $
             throwE $ UserKeyInUse pk
         blacklisted <- lift $ Blacklist.exists pk
         when blacklisted $
             throwE (ActivationBlacklistedUserKey pk)
+
+        -- check if any prefixes of this phone number are blocked
+        prefixExcluded <- lift $ Blacklist.existsAnyPrefix canonical
+        when prefixExcluded $
+            throwE (ActivationBlacklistedUserKey pk)
+
         c <- lift $ fmap snd <$> Data.lookupActivationCode pk
         p <- mkPair pk c Nothing
         void . forPhoneKey pk $ \ph -> lift $
@@ -860,6 +873,15 @@ blacklistDelete emailOrPhone = do
     let uk = either userEmailKey userPhoneKey emailOrPhone
     Blacklist.delete uk
 
+phonePrefixGet :: PhonePrefix -> AppIO [PhonePrefix]
+phonePrefixGet prefix = Blacklist.getAllPrefixes prefix
+
+phonePrefixDelete :: PhonePrefix -> AppIO ()
+phonePrefixDelete = Blacklist.deletePrefix
+
+phonePrefixInsert :: PhonePrefix -> AppIO ()
+phonePrefixInsert = Blacklist.insertPrefix
+
 -------------------------------------------------------------------------------
 -- Utilities
 

services/brig/src/Brig/App.hs

@@ -118,7 +118,7 @@ import qualified System.Logger            as Log
 import qualified System.Logger.Class      as LC
 
 schemaVersion :: Int32
-schemaVersion = 55
+schemaVersion = 56
 
 -------------------------------------------------------------------------------
 -- Environment

services/brig/src/Brig/Data/Blacklist.hs

@@ -1,11 +1,26 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Brig.Data.Blacklist where
+module Brig.Data.Blacklist
+    ( -- * UserKey blacklisting
+      insert
+    , exists
+    , delete
+
+      -- * PhonePrefix excluding
+    , insertPrefix
+    , deletePrefix
+    , existsAnyPrefix
+    , getAllPrefixes
+    ) where
 
 import Imports
 import Brig.Data.UserKey
+import Brig.Types.Common
 import Cassandra
 
+--------------------------------------------------------------------------------
+-- UserKey blacklisting
+
 insert :: MonadClient m => UserKey -> m ()
 insert uk = retry x5 $ write keyInsert (params Quorum (Identity $ keyText uk))
 
@@ -16,9 +31,6 @@ exists uk = return . isJust =<< fmap runIdentity <$>
 delete :: MonadClient m => UserKey -> m ()
 delete uk = retry x5 $ write keyDelete (params Quorum (Identity $ keyText uk))
 
---------------------------------------------------------------------------------
--- Queries
-
 keyInsert :: PrepQuery W (Identity Text) ()
 keyInsert = "INSERT INTO blacklist (key) VALUES (?)"
 
@@ -27,3 +39,36 @@ keySelect = "SELECT key FROM blacklist WHERE key = ?"
 
 keyDelete :: PrepQuery W (Identity Text) ()
 keyDelete = "DELETE FROM blacklist WHERE key = ?"
+
+--------------------------------------------------------------------------------
+-- Excluded phone prefixes
+
+insertPrefix :: MonadClient m => PhonePrefix -> m ()
+insertPrefix prefix = retry x5 $ write ins (params Quorum (Identity $ fromPhonePrefix prefix))
+  where
+    ins :: PrepQuery W (Identity Text) ()
+    ins = "INSERT INTO excluded_phones (prefix) VALUES (?)"
+
+deletePrefix :: MonadClient m => PhonePrefix -> m ()
+deletePrefix prefix = retry x5 $ write del (params Quorum (Identity $ fromPhonePrefix prefix))
+  where
+    del :: PrepQuery W (Identity Text) ()
+    del = "DELETE FROM excluded_phones WHERE prefix = ?"
+
+getAllPrefixes :: MonadClient m => PhonePrefix -> m [PhonePrefix]
+getAllPrefixes prefix = do
+    let prefixes = fromPhonePrefix <$> allPrefixes (fromPhonePrefix prefix)
+    selectPrefixes prefixes
+
+existsAnyPrefix :: MonadClient m => Phone -> m Bool
+existsAnyPrefix phone = do
+    let prefixes = fromPhonePrefix <$> allPrefixes (fromPhone phone)
+    (not . null) <$> selectPrefixes prefixes
+
+selectPrefixes :: MonadClient m => [Text] -> m [PhonePrefix]
+selectPrefixes prefixes = do
+    results <- fmap runIdentity <$> retry x1 (query sel (params Quorum (Identity $ prefixes)))
+    return (PhonePrefix <$> results)
+  where
+    sel :: PrepQuery R (Identity [Text]) (Identity Text)
+    sel = "SELECT prefix FROM excluded_phones WHERE prefix IN ?"

services/brig/test/integration/API/Team.hs

@@ -237,7 +237,7 @@ testCreateTeam brig galley aws = do
 testCreateTeamPreverified :: Brig -> Galley -> AWS.Env -> Http ()
 testCreateTeamPreverified brig galley aws = do
     email <- randomEmail
-    requestActivationCode brig (Left email)
+    requestActivationCode brig 200 (Left email)
     act <- getActivationCode brig (Left email)
     case act of
         Nothing     -> liftIO $ assertFailure "activation key/code not found"

services/brig/test/integration/API/User/Account.hs

@@ -80,6 +80,8 @@ tests _ at _ p b c ch g aws = testGroup "account"
     , test' aws p "put /self/password - 200"                 $ testPasswordChange b
     , test' aws p "put /self/locale - 200"                   $ testUserLocaleUpdate b aws
     , test' aws p "post /activate/send - 200"                $ testSendActivationCode b
+    , test' aws p "post /activate/send - 403"                $ testSendActivationCodePrefixExcluded b
+    , test' aws p "post /i/users/phone-prefix"               $ testInternalPhonePrefixes b
     , test' aws p "put /i/users/:id/status (suspend)"        $ testSuspendUser b
     , test' aws p "get /i/users?:(email|phone) - 200"        $ testGetByIdentity b
     , test' aws p "delete/phone-email"                       $ testEmailPhoneDelete b c
@@ -698,14 +700,61 @@ testPasswordChange brig = do
 testSendActivationCode :: Brig -> Http ()
 testSendActivationCode brig = do
     -- Code for phone pre-verification
-    requestActivationCode brig . Right =<< randomPhone
+    requestActivationCode brig 200 . Right =<< randomPhone
     -- Code for email pre-verification
-    requestActivationCode brig . Left =<< randomEmail
+    requestActivationCode brig 200 . Left =<< randomEmail
     -- Standard email registration flow
     r <- registerUser "Alice" brig <!! const 201 === statusCode
     let Just email = userEmail =<< decodeBody r
     -- Re-request existing activation code
-    requestActivationCode brig (Left email)
+    requestActivationCode brig 200 (Left email)
+
+testSendActivationCodePrefixExcluded :: Brig -> Http ()
+testSendActivationCodePrefixExcluded brig = do
+    p <- randomPhone
+    let prefix = PhonePrefix $ T.take 5 (fromPhone p)
+
+    -- expect activation to fail after it was excluded
+    insertPrefix brig prefix
+    requestActivationCode brig 403 (Right p)
+
+    -- expect activation to work again after removing block
+    deletePrefix brig prefix
+    requestActivationCode brig 200 (Right p)
+
+testInternalPhonePrefixes :: Brig -> Http ()
+testInternalPhonePrefixes brig = do
+    -- prefix1 is a prefix of prefix2
+    let prefix1 = PhonePrefix "+5678"
+        prefix2 = PhonePrefix "+56789"
+
+    insertPrefix brig prefix1
+    insertPrefix brig prefix2
+
+    -- test getting prefixs
+    res <- getPrefixes prefix1
+    liftIO $ assertEqual "prefix match prefix" res [prefix1]
+
+    -- we expect both prefixes returned when searching for the longer one
+    res2 <- getPrefixes prefix2
+    liftIO $ assertEqual "prefix match phone number" res2 [prefix1, prefix2]
+
+    deletePrefix brig prefix1
+    deletePrefix brig prefix2
+
+    getPrefix prefix1 !!! const 404 === statusCode
+  where
+    getPrefixes :: PhonePrefix -> Http [PhonePrefix]
+    getPrefixes prefix = decodeBody =<< getPrefix prefix
+
+    getPrefix :: PhonePrefix -> Http ResponseLBS
+    getPrefix prefix = get ( brig . paths ["/i/users/phone-prefixes", toByteString' prefix])
+
+insertPrefix :: Brig -> PhonePrefix -> Http ()
+insertPrefix brig prefix = post ( brig . paths ["/i/users/phone-prefixes", toByteString' prefix]) !!! const 200 === statusCode
+
+deletePrefix :: Brig -> PhonePrefix -> Http ()
+deletePrefix brig prefix = delete ( brig . paths ["/i/users/phone-prefixes", toByteString' prefix]) !!! const 200 === statusCode
 
 testEmailPhoneDelete :: Brig -> Cannon -> Http ()
 testEmailPhoneDelete brig cannon = do

services/brig/test/integration/Util.hs

@@ -119,10 +119,10 @@ createAnonUserExpiry expires name brig = do
     r <- post (brig . path "/register" . contentJson . body p) <!! const 201 === statusCode
     decodeBody r
 
-requestActivationCode :: HasCallStack => Brig -> Either Email Phone -> Http ()
-requestActivationCode brig ep =
+requestActivationCode :: HasCallStack => Brig -> Int -> Either Email Phone -> Http ()
+requestActivationCode brig expectedStatus ep =
     post (brig . path "/activate/send" . contentJson . body (RequestBodyLBS . encode $ bdy ep)) !!!
-        const 200 === statusCode
+        const expectedStatus === statusCode
   where
     bdy (Left e)  = object [ "email" .= fromEmail e ]
     bdy (Right p) = object [ "phone" .= fromPhone p ]