Skip to content

Commit

Permalink
Introduce PropertySubsystem (#4148)
Browse files Browse the repository at this point in the history
* Migrate integration tests for user properties to the new suite

* AsciiText: Write correct instance for FromHttpApiData

* AsciiText: Write correct instance for FromJSONKey

* Allow setting existing properties even if we have max properties

* Rename UserEvents -> Events, also support PropertyEvent

* Introduce PropertiesSubsystem
  • Loading branch information
akshaymankar authored Jul 24, 2024
1 parent 8151fae commit a9e8c5f
Show file tree
Hide file tree
Showing 39 changed files with 933 additions and 492 deletions.
1 change: 1 addition & 0 deletions changelog.d/3-bug-fixes/ascii-text-parsing
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
Return HTTP 400 instead of 500 when property key is not printable ASCII
1 change: 1 addition & 0 deletions changelog.d/3-bug-fixes/max-properties
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
Allow setting existing properties even if we have max properties
1 change: 1 addition & 0 deletions changelog.d/5-internal/property-subsystem
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
Introduce proeprty subsytem
1 change: 1 addition & 0 deletions integration/integration.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -139,6 +139,7 @@ library
Test.MLS.Unreachable
Test.Notifications
Test.Presence
Test.Property
Test.Provider
Test.PushToken
Test.Roles
Expand Down
30 changes: 30 additions & 0 deletions integration/test/API/Brig.hs
Original file line number Diff line number Diff line change
Expand Up @@ -675,3 +675,33 @@ addBot user providerId serviceId convId = do
req
& zType "access"
& addJSONObject ["provider" .= providerId, "service" .= serviceId]

setProperty :: (MakesValue user, ToJSON val) => user -> String -> val -> App Response
setProperty user propName val = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties", propName]
submit "PUT" $ req & addJSON val

getProperty :: (MakesValue user) => user -> String -> App Response
getProperty user propName = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties", propName]
submit "GET" req

deleteProperty :: (MakesValue user) => user -> String -> App Response
deleteProperty user propName = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties", propName]
submit "DELETE" req

getAllPropertyNames :: (MakesValue user) => user -> App Response
getAllPropertyNames user = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties"]
submit "GET" req

getAllPropertyValues :: (MakesValue user) => user -> App Response
getAllPropertyValues user = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties-values"]
submit "GET" req

clearProperties :: (MakesValue user) => user -> App Response
clearProperties user = do
req <- baseRequest user Brig Versioned $ joinHttpPath ["properties"]
submit "DELETE" req
25 changes: 25 additions & 0 deletions integration/test/API/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,8 @@ import Control.Monad.IO.Class
import Data.Array ((!))
import qualified Data.Array as Array
import qualified Data.ByteString as BS
import Data.Scientific (scientific)
import qualified Data.Vector as Vector
import System.Random (randomIO, randomRIO)
import Testlib.Prelude

Expand Down Expand Up @@ -47,6 +49,29 @@ randomHandleWithRange min' max' = liftIO $ do
randomBytes :: Int -> App ByteString
randomBytes n = liftIO $ BS.pack <$> replicateM n randomIO

randomString :: Int -> App String
randomString n = liftIO $ replicateM n randomIO

randomJSON :: App Value
randomJSON = do
let maxThings = 5
liftIO (randomRIO (0 :: Int, 5)) >>= \case
0 -> String . fromString <$> (randomString =<< randomRIO (0, maxThings))
1 -> Number <$> liftIO (scientific <$> randomIO <*> randomIO)
2 -> Bool <$> liftIO randomIO
3 -> pure Null
4 -> do
n <- liftIO $ randomRIO (0, maxThings)
Array . Vector.fromList <$> replicateM n randomJSON
5 -> do
n <- liftIO $ randomRIO (0, maxThings)
keys <- do
keyLength <- randomRIO (0, maxThings)
replicateM n (randomString keyLength)
vals <- replicateM n randomJSON
pure . object $ zipWith (.=) keys vals
_ -> error $ "impopssible: randomJSON"

randomHex :: Int -> App String
randomHex n = liftIO $ replicateM n pick
where
Expand Down
143 changes: 143 additions & 0 deletions integration/test/Test/Property.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,143 @@
module Test.Property where

import API.Brig
import API.Common
import qualified Data.Map as Map
import SetupHelpers
import Testlib.Prelude

testSetGetDeleteProperty :: App ()
testSetGetDeleteProperty = do
user <- randomUser OwnDomain def
setProperty user "foo" "bar" `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

getProperty user "foo" `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` toJSON "bar"

deleteProperty user "foo" `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200

getProperty user "foo" `bindResponse` \resp -> do
resp.status `shouldMatchInt` 404

testGetProperties :: App ()
testGetProperties = do
user <- randomUser OwnDomain def
-- Property names can only be printable ascii, using the handle function here
-- as a little shortcut.
propertyNames <- replicateM 16 $ randomHandleWithRange 8 20
propertyVals <- replicateM 16 $ randomJSON
let properties = zip propertyNames propertyVals
forM_ properties $ \(prop, val) ->
setProperty user prop val `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

getAllPropertyNames user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatchSet` propertyNames

getAllPropertyValues user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` Map.fromList properties

testClearProperties :: App ()
testClearProperties = do
user <- randomUser OwnDomain def

propertyNames <- replicateM 16 $ randomHandleWithRange 8 20
propertyVals <- replicateM 16 $ randomJSON
let properties = zip propertyNames propertyVals
forM_ properties $ \(prop, val) ->
setProperty user prop val `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

clearProperties user `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

getAllPropertyNames user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatchSet` mempty @[String]

getAllPropertyValues user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` Map.empty @String @Value

testMaxProperties :: App ()
testMaxProperties = do
user <- randomUser OwnDomain def

-- This is hardcoded in the prod code.
let maxProperties = 16

propertyNames <- replicateM maxProperties $ randomHandleWithRange 8 20
propertyVals <- replicateM maxProperties $ randomJSON
let properties = zip propertyNames propertyVals
forM_ properties $ \(prop, val) ->
setProperty user prop val `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

seventeenthPropName <- randomHandleWithRange 8 20
seventeenthPropVal <- randomJSON

-- cannot set seventeenth property
setProperty user seventeenthPropName seventeenthPropVal `bindResponse` \resp -> do
resp.status `shouldMatchInt` 403
resp.json %. "label" `shouldMatch` "too-many-properties"

-- Old properties are maintained
getAllPropertyValues user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` Map.fromList properties

-- Can still update the old properties
newPropertyVals <- replicateM 16 $ randomJSON
let newProperties = zip propertyNames newPropertyVals
forM_ newProperties $ \(prop, val) ->
setProperty user prop val `bindResponse` \resp ->
resp.status `shouldMatchInt` 200

getAllPropertyValues user `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` Map.fromList newProperties

testPropertyNameNotAscii :: App ()
testPropertyNameNotAscii = do
user <- randomUser OwnDomain def
setProperty user "döner" "yes" `bindResponse` \resp ->
resp.status `shouldMatchInt` 400

testMaxLength :: App ()
testMaxLength = do
user <- randomUser OwnDomain def

maxKeyLength <- asInt $ readServiceConfig Brig %. "optSettings.setPropertyMaxKeyLen"
maxValLength <- asInt $ readServiceConfig Brig %. "optSettings.setPropertyMaxValueLen"

tooLongProperty <- randomHandleWithRange (maxKeyLength + 1) (maxKeyLength + 1)
acceptableProperty <- randomHandleWithRange maxKeyLength maxKeyLength

-- Two chars are taken by the quotes for string values.
--
-- We use the `randomHandleWithRange` function because having non-ascii
-- characters or unprintable characters will increase the length of the JSON.
tooLongValue <- randomHandleWithRange (maxValLength - 1) (maxValLength - 1)
acceptableValue <- randomHandleWithRange (maxValLength - 2) (maxValLength - 2)

putStrLn $ "acceptableValue= " <> acceptableValue

setProperty user tooLongProperty acceptableValue `bindResponse` \resp -> do
resp.status `shouldMatchInt` 403
resp.json %. "label" `shouldMatch` "property-key-too-large"

setProperty user acceptableProperty tooLongValue `bindResponse` \resp -> do
resp.status `shouldMatchInt` 403
resp.json %. "label" `shouldMatch` "property-value-too-large"

setProperty user acceptableProperty acceptableValue `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200

getProperty user acceptableProperty `bindResponse` \resp -> do
resp.status `shouldMatchInt` 200
resp.json `shouldMatch` toJSON acceptableValue
10 changes: 7 additions & 3 deletions libs/types-common/src/Data/Text/Ascii.hs
Original file line number Diff line number Diff line change
Expand Up @@ -80,6 +80,7 @@ where
import Cassandra hiding (Ascii)
import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey)
import Data.Attoparsec.ByteString (Parser)
import Data.Bifunctor (first)
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Base64.URL qualified as B64Url
Expand All @@ -104,11 +105,9 @@ newtype AsciiText c = AsciiText {toText :: Text}
Monoid,
NFData,
ToByteString,
FromJSONKey,
ToJSONKey,
Hashable,
ToHttpApiData,
FromHttpApiData
ToHttpApiData
)

newtype AsciiChar c = AsciiChar {toChar :: Char}
Expand Down Expand Up @@ -141,6 +140,9 @@ class AsciiChars c where
instance (AsciiChars c) => FromByteString (AsciiText c) where
parser = parseBytes validate

instance (AsciiChars c) => FromHttpApiData (AsciiText c) where
parseUrlPiece = first Text.pack . validate

-- | Note: 'fromString' is a partial function that will 'error' when given
-- a string containing characters not in the set @c@. It is only intended to be used
-- via the @OverloadedStrings@ extension, i.e. for known ASCII string literals.
Expand All @@ -156,6 +158,8 @@ instance (AsciiChars c) => ToJSON (AsciiText c) where
instance (AsciiChars c) => FromJSON (AsciiText c) where
parseJSON = schemaParseJSON

instance (FromJSON (AsciiText c)) => FromJSONKey (AsciiText c)

instance (Typeable c, AsciiChars c) => S.ToSchema (AsciiText c) where
declareNamedSchema = schemaToSwagger

Expand Down
9 changes: 9 additions & 0 deletions libs/wire-api/src/Wire/API/Error/Brig.hs
Original file line number Diff line number Diff line change
Expand Up @@ -94,6 +94,9 @@ data BrigError
| ProviderNotFound
| TeamsNotFederating
| PasswordIsStale
| TooManyProperties
| PropertyKeyTooLarge
| PropertyValueTooLarge

instance (Typeable (MapError e), KnownError (MapError e)) => IsSwaggerError (e :: BrigError) where
addToOpenApi = addStaticErrorToSwagger @(MapError e)
Expand Down Expand Up @@ -282,3 +285,9 @@ type instance MapError 'ConflictingInvitations = 'StaticError 409 "conflicting-i
type instance MapError 'TeamsNotFederating = 'StaticError 403 "team-not-federating" "The target user is owned by a federated backend, but is not in an allow-listed team"

type instance MapError 'PasswordIsStale = 'StaticError 403 "password-is-stale" "The password is too old, please update your password."

type instance MapError 'TooManyProperties = 'StaticError 403 "too-many-properties" "Too many properties"

type instance MapError 'PropertyKeyTooLarge = 'StaticError 403 "property-key-too-large" "The property key is too large."

type instance MapError 'PropertyValueTooLarge = 'StaticError 403 "property-value-too-large" "The property value is too large"
19 changes: 4 additions & 15 deletions libs/wire-api/src/Wire/API/Properties.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ module Wire.API.Properties
( PropertyKeysAndValues (..),
PropertyKey (..),
RawPropertyValue (..),
PropertyValue (..),
)
where

Expand All @@ -35,9 +34,10 @@ import Data.OpenApi qualified as S
import Data.Text.Ascii
import Imports
import Servant
import Wire.Arbitrary (Arbitrary)
import Test.QuickCheck

newtype PropertyKeysAndValues = PropertyKeysAndValues (Map PropertyKey PropertyValue)
newtype PropertyKeysAndValues = PropertyKeysAndValues (Map PropertyKey Value)
deriving stock (Eq, Show)
deriving newtype (ToJSON)

instance S.ToSchema PropertyKeysAndValues where
Expand Down Expand Up @@ -72,6 +72,7 @@ deriving instance C.Cql PropertyKey

-- | A raw, unparsed property value.
newtype RawPropertyValue = RawPropertyValue {rawPropertyBytes :: LByteString}
deriving (Eq, Show)

instance C.Cql RawPropertyValue where
ctype = C.Tagged C.BlobColumn
Expand All @@ -89,15 +90,3 @@ instance S.ToSchema RawPropertyValue where
declareNamedSchema _ =
pure . S.NamedSchema (Just "PropertyValue") $
mempty & S.description ?~ "An arbitrary JSON value for a property"

-- | A property value together with its original serialisation.
data PropertyValue = PropertyValue
{ propertyRaw :: RawPropertyValue,
propertyValue :: Value
}

instance ToJSON PropertyValue where
toJSON = propertyValue

instance Show PropertyValue where
show = show . propertyValue
2 changes: 2 additions & 0 deletions libs/wire-subsystems/default.nix
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,7 @@
, resource-pool
, resourcet
, retry
, scientific
, servant
, servant-client-core
, stomp-queue
Expand Down Expand Up @@ -174,6 +175,7 @@ mkDerivation {
QuickCheck
quickcheck-instances
random
scientific
servant-client-core
streaming-commons
string-conversions
Expand Down
14 changes: 14 additions & 0 deletions libs/wire-subsystems/src/Wire/Events.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,14 @@
{-# LANGUAGE TemplateHaskell #-}

module Wire.Events where

import Data.Id
import Imports
import Polysemy
import Wire.API.UserEvent

data Events m a where
GenerateUserEvent :: UserId -> Maybe ConnId -> UserEvent -> Events m ()
GeneratePropertyEvent :: UserId -> ConnId -> PropertyEvent -> Events m ()

makeSem ''Events
19 changes: 19 additions & 0 deletions libs/wire-subsystems/src/Wire/PropertyStore.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,19 @@
{-# LANGUAGE TemplateHaskell #-}

module Wire.PropertyStore where

import Data.Id
import Imports
import Polysemy
import Wire.API.Properties

data PropertyStore m a where
InsertProperty :: UserId -> PropertyKey -> RawPropertyValue -> PropertyStore m ()
LookupProperty :: UserId -> PropertyKey -> PropertyStore m (Maybe RawPropertyValue)
CountProperties :: UserId -> PropertyStore m Int
DeleteProperty :: UserId -> PropertyKey -> PropertyStore m ()
ClearProperties :: UserId -> PropertyStore m ()
GetPropertyKeys :: UserId -> PropertyStore m [PropertyKey]
GetAllProperties :: UserId -> PropertyStore m [(PropertyKey, RawPropertyValue)]

makeSem ''PropertyStore
Loading

0 comments on commit a9e8c5f

Please sign in to comment.