module Wire.PropertySubsystem.Interpreter where import Data.Aeson (Value) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.Id import Data.Map qualified as Map import Data.Text qualified as Text import Data.Text.Ascii qualified as Ascii import Imports import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger.Message qualified as Log import Wire.API.Properties import Wire.API.UserEvent import Wire.Events import Wire.PropertyStore (PropertyStore) import Wire.PropertyStore qualified as PropertyStore import Wire.PropertySubsystem data PropertySubsystemConfig = PropertySubsystemConfig { PropertySubsystemConfig -> Int64 maxKeyLength :: Int64, PropertySubsystemConfig -> Int64 maxValueLength :: Int64, PropertySubsystemConfig -> Int maxProperties :: Int } interpretPropertySubsystem :: ( Member PropertyStore r, Member (Error PropertySubsystemError) r, Member Events r, Member TinyLog r ) => PropertySubsystemConfig -> InterpreterFor PropertySubsystem r interpretPropertySubsystem :: forall (r :: EffectRow). (Member PropertyStore r, Member (Error PropertySubsystemError) r, Member Events r, Member TinyLog r) => PropertySubsystemConfig -> InterpreterFor PropertySubsystem r interpretPropertySubsystem PropertySubsystemConfig cfg = (forall (rInitial :: EffectRow) x. PropertySubsystem (Sem rInitial) x -> Sem r x) -> Sem (PropertySubsystem : r) a -> Sem r a forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a. FirstOrder e "interpret" => (forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x) -> Sem (e : r) a -> Sem r a interpret ((forall (rInitial :: EffectRow) x. PropertySubsystem (Sem rInitial) x -> Sem r x) -> Sem (PropertySubsystem : r) a -> Sem r a) -> (forall (rInitial :: EffectRow) x. PropertySubsystem (Sem rInitial) x -> Sem r x) -> Sem (PropertySubsystem : r) a -> Sem r a forall a b. (a -> b) -> a -> b $ PropertySubsystemConfig -> Sem (Input PropertySubsystemConfig : r) x -> Sem r x forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a runInputConst PropertySubsystemConfig cfg (Sem (Input PropertySubsystemConfig : r) x -> Sem r x) -> (PropertySubsystem (Sem rInitial) x -> Sem (Input PropertySubsystemConfig : r) x) -> PropertySubsystem (Sem rInitial) x -> Sem r x forall b c a. (b -> c) -> (a -> b) -> a -> c . \case SetProperty UserId uid ConnId connId PropertyKey key RawPropertyValue val -> UserId -> ConnId -> PropertyKey -> RawPropertyValue -> Sem (Input PropertySubsystemConfig : r) () forall (r :: EffectRow). (Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r, Member Events r) => UserId -> ConnId -> PropertyKey -> RawPropertyValue -> Sem r () setPropertyImpl UserId uid ConnId connId PropertyKey key RawPropertyValue val DeleteProperty UserId uid ConnId connId PropertyKey key -> UserId -> ConnId -> PropertyKey -> Sem (Input PropertySubsystemConfig : r) () forall (r :: EffectRow). (Member PropertyStore r, Member Events r) => UserId -> ConnId -> PropertyKey -> Sem r () deletePropertyImpl UserId uid ConnId connId PropertyKey key ClearProperties UserId uid ConnId connId -> UserId -> ConnId -> Sem (Input PropertySubsystemConfig : r) () forall (r :: EffectRow). (Member PropertyStore r, Member Events r) => UserId -> ConnId -> Sem r () clearPropertiesImpl UserId uid ConnId connId OnUserDeleted UserId uid -> UserId -> Sem (Input PropertySubsystemConfig : r) () forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r () onUserDeletdImpl UserId uid LookupProperty UserId uid PropertyKey key -> UserId -> PropertyKey -> Sem (Input PropertySubsystemConfig : r) (Maybe RawPropertyValue) forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) lookupPropertyImpl UserId uid PropertyKey key GetPropertyKeys UserId uid -> UserId -> Sem (Input PropertySubsystemConfig : r) [PropertyKey] forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r [PropertyKey] getPropertyKeysImpl UserId uid GetAllProperties UserId uid -> UserId -> Sem (Input PropertySubsystemConfig : r) PropertyKeysAndValues forall (r :: EffectRow). (Member PropertyStore r, Member TinyLog r, Member (Error PropertySubsystemError) r) => UserId -> Sem r PropertyKeysAndValues getAllPropertiesImpl UserId uid setPropertyImpl :: ( Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r, Member Events r ) => UserId -> ConnId -> PropertyKey -> RawPropertyValue -> Sem r () setPropertyImpl :: forall (r :: EffectRow). (Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r, Member Events r) => UserId -> ConnId -> PropertyKey -> RawPropertyValue -> Sem r () setPropertyImpl UserId uid ConnId connId PropertyKey key RawPropertyValue val = do PropertyKey -> Sem r () forall (r :: EffectRow). (Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => PropertyKey -> Sem r () validatePropertyKey PropertyKey key UserId -> PropertyKey -> Sem r () forall (r :: EffectRow). (Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => UserId -> PropertyKey -> Sem r () checkMaxProperties UserId uid PropertyKey key Value parsedVal <- RawPropertyValue -> Sem r Value forall (r :: EffectRow). (Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => RawPropertyValue -> Sem r Value validatePropertyValue RawPropertyValue val UserId -> PropertyKey -> RawPropertyValue -> Sem r () forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> RawPropertyValue -> Sem r () PropertyStore.insertProperty UserId uid PropertyKey key RawPropertyValue val UserId -> ConnId -> PropertyEvent -> Sem r () forall (r :: EffectRow). Member Events r => UserId -> ConnId -> PropertyEvent -> Sem r () generatePropertyEvent UserId uid ConnId connId (PropertyEvent -> Sem r ()) -> PropertyEvent -> Sem r () forall a b. (a -> b) -> a -> b $ PropertyKey -> Value -> PropertyEvent PropertySet PropertyKey key Value parsedVal checkMaxProperties :: ( Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r ) => UserId -> PropertyKey -> Sem r () checkMaxProperties :: forall (r :: EffectRow). (Member PropertyStore r, Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => UserId -> PropertyKey -> Sem r () checkMaxProperties UserId uid PropertyKey key = do Bool propExists <- Maybe RawPropertyValue -> Bool forall a. Maybe a -> Bool isJust (Maybe RawPropertyValue -> Bool) -> Sem r (Maybe RawPropertyValue) -> Sem r Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) PropertyStore.lookupProperty UserId uid PropertyKey key Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool propExists (Sem r () -> Sem r ()) -> Sem r () -> Sem r () forall a b. (a -> b) -> a -> b $ do PropertySubsystemConfig cfg <- Sem r PropertySubsystemConfig forall i (r :: EffectRow). Member (Input i) r => Sem r i input Int count <- UserId -> Sem r Int forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r Int PropertyStore.countProperties UserId uid Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Int count Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= PropertySubsystemConfig cfg.maxProperties) (Sem r () -> Sem r ()) -> Sem r () -> Sem r () forall a b. (a -> b) -> a -> b $ PropertySubsystemError -> Sem r () forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a throw PropertySubsystemError TooManyProperties validatePropertyKey :: ( Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r ) => PropertyKey -> Sem r () validatePropertyKey :: forall (r :: EffectRow). (Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => PropertyKey -> Sem r () validatePropertyKey PropertyKey key = do PropertySubsystemConfig cfg <- Sem r PropertySubsystemConfig forall i (r :: EffectRow). Member (Input i) r => Sem r i input let keyText :: Text keyText = AsciiText Printable -> Text forall {k} (c :: k). AsciiText c -> Text Ascii.toText (AsciiText Printable -> Text) -> AsciiText Printable -> Text forall a b. (a -> b) -> a -> b $ PropertyKey -> AsciiText Printable propertyKeyName PropertyKey key Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Text -> Int -> Ordering Text.compareLength Text keyText (Int64 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral PropertySubsystemConfig cfg.maxKeyLength) Ordering -> Ordering -> Bool forall a. Eq a => a -> a -> Bool == Ordering GT) (Sem r () -> Sem r ()) -> Sem r () -> Sem r () forall a b. (a -> b) -> a -> b $ PropertySubsystemError -> Sem r () forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a throw PropertySubsystemError PropertyKeyTooLarge validatePropertyValue :: ( Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r ) => RawPropertyValue -> Sem r Value validatePropertyValue :: forall (r :: EffectRow). (Member (Input PropertySubsystemConfig) r, Member (Error PropertySubsystemError) r) => RawPropertyValue -> Sem r Value validatePropertyValue (RawPropertyValue LByteString bs) = do PropertySubsystemConfig cfg <- Sem r PropertySubsystemConfig forall i (r :: EffectRow). Member (Input i) r => Sem r i input Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (LByteString -> Int64 -> Ordering LBS.compareLength LByteString bs PropertySubsystemConfig cfg.maxValueLength Ordering -> Ordering -> Bool forall a. Eq a => a -> a -> Bool == Ordering GT) (Sem r () -> Sem r ()) -> Sem r () -> Sem r () forall a b. (a -> b) -> a -> b $ PropertySubsystemError -> Sem r () forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a throw PropertySubsystemError PropertyValueTooLarge case forall a. FromJSON a => LByteString -> Either String a Aeson.eitherDecode @Value LByteString bs of Left String e -> PropertySubsystemError -> Sem r Value forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a throw (PropertySubsystemError -> Sem r Value) -> PropertySubsystemError -> Sem r Value forall a b. (a -> b) -> a -> b $ String -> PropertySubsystemError PropertyValueInvalid String e Right Value val -> Value -> Sem r Value forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure Value val deletePropertyImpl :: (Member PropertyStore r, Member Events r) => UserId -> ConnId -> PropertyKey -> Sem r () deletePropertyImpl :: forall (r :: EffectRow). (Member PropertyStore r, Member Events r) => UserId -> ConnId -> PropertyKey -> Sem r () deletePropertyImpl UserId uid ConnId connId PropertyKey key = do UserId -> PropertyKey -> Sem r () forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> Sem r () PropertyStore.deleteProperty UserId uid PropertyKey key UserId -> ConnId -> PropertyEvent -> Sem r () forall (r :: EffectRow). Member Events r => UserId -> ConnId -> PropertyEvent -> Sem r () generatePropertyEvent UserId uid ConnId connId (PropertyEvent -> Sem r ()) -> PropertyEvent -> Sem r () forall a b. (a -> b) -> a -> b $ PropertyKey -> PropertyEvent PropertyDeleted PropertyKey key onUserDeletdImpl :: (Member PropertyStore r) => UserId -> Sem r () onUserDeletdImpl :: forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r () onUserDeletdImpl UserId uid = do UserId -> Sem r () forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r () PropertyStore.clearProperties UserId uid clearPropertiesImpl :: (Member PropertyStore r, Member Events r) => UserId -> ConnId -> Sem r () clearPropertiesImpl :: forall (r :: EffectRow). (Member PropertyStore r, Member Events r) => UserId -> ConnId -> Sem r () clearPropertiesImpl UserId uid ConnId connId = do UserId -> Sem r () forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r () PropertyStore.clearProperties UserId uid UserId -> ConnId -> PropertyEvent -> Sem r () forall (r :: EffectRow). Member Events r => UserId -> ConnId -> PropertyEvent -> Sem r () generatePropertyEvent UserId uid ConnId connId PropertyEvent PropertiesCleared lookupPropertyImpl :: (Member PropertyStore r) => UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) lookupPropertyImpl :: forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) lookupPropertyImpl UserId uid PropertyKey key = UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) forall (r :: EffectRow). Member PropertyStore r => UserId -> PropertyKey -> Sem r (Maybe RawPropertyValue) PropertyStore.lookupProperty UserId uid PropertyKey key getPropertyKeysImpl :: (Member PropertyStore r) => UserId -> Sem r [PropertyKey] getPropertyKeysImpl :: forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r [PropertyKey] getPropertyKeysImpl UserId uid = UserId -> Sem r [PropertyKey] forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r [PropertyKey] PropertyStore.getPropertyKeys UserId uid getAllPropertiesImpl :: ( Member PropertyStore r, Member TinyLog r, Member (Error PropertySubsystemError) r ) => UserId -> Sem r PropertyKeysAndValues getAllPropertiesImpl :: forall (r :: EffectRow). (Member PropertyStore r, Member TinyLog r, Member (Error PropertySubsystemError) r) => UserId -> Sem r PropertyKeysAndValues getAllPropertiesImpl UserId uid = do Map PropertyKey RawPropertyValue rawProps <- [(PropertyKey, RawPropertyValue)] -> Map PropertyKey RawPropertyValue forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([(PropertyKey, RawPropertyValue)] -> Map PropertyKey RawPropertyValue) -> Sem r [(PropertyKey, RawPropertyValue)] -> Sem r (Map PropertyKey RawPropertyValue) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> UserId -> Sem r [(PropertyKey, RawPropertyValue)] forall (r :: EffectRow). Member PropertyStore r => UserId -> Sem r [(PropertyKey, RawPropertyValue)] PropertyStore.getAllProperties UserId uid Map PropertyKey Value -> PropertyKeysAndValues PropertyKeysAndValues (Map PropertyKey Value -> PropertyKeysAndValues) -> Sem r (Map PropertyKey Value) -> Sem r PropertyKeysAndValues forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (RawPropertyValue -> Sem r Value) -> Map PropertyKey RawPropertyValue -> Sem r (Map PropertyKey Value) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> Map PropertyKey a -> f (Map PropertyKey b) traverse RawPropertyValue -> Sem r Value forall (r :: EffectRow). (Member TinyLog r, Member (Error PropertySubsystemError) r) => RawPropertyValue -> Sem r Value parseStoredPropertyValue Map PropertyKey RawPropertyValue rawProps parseStoredPropertyValue :: (Member TinyLog r, Member (Error PropertySubsystemError) r) => RawPropertyValue -> Sem r Value parseStoredPropertyValue :: forall (r :: EffectRow). (Member TinyLog r, Member (Error PropertySubsystemError) r) => RawPropertyValue -> Sem r Value parseStoredPropertyValue RawPropertyValue raw = case LByteString -> Either String Value forall a. FromJSON a => LByteString -> Either String a Aeson.eitherDecode RawPropertyValue raw.rawPropertyBytes of Right Value value -> Value -> Sem r Value forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure Value value Left String e -> do (Msg -> Msg) -> Sem r () forall msg (r :: EffectRow). Member (Logger msg) r => msg -> Sem r () Log.err ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r () forall a b. (a -> b) -> a -> b $ Builder -> Msg -> Msg forall a. ToBytes a => a -> Msg -> Msg Log.msg (ByteString -> Builder Log.val ByteString "Failed to parse a stored property value") (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> LByteString -> Msg -> Msg forall a. ToBytes a => ByteString -> a -> Msg -> Msg Log.field ByteString "raw_value" RawPropertyValue raw.rawPropertyBytes (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> String -> Msg -> Msg forall a. ToBytes a => ByteString -> a -> Msg -> Msg Log.field ByteString "parse_error" String e PropertySubsystemError -> Sem r Value forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a throw PropertySubsystemError StoredPropertyValueInvalid