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