module Wire.UserKeyStore.Cassandra (interpretUserKeyStoreCassandra) where

import Cassandra
import Data.Id
import Imports
import Polysemy
import Polysemy.Embed
import Wire.UserKeyStore
import Wire.UserStore

interpretUserKeyStoreCassandra :: (Member (Embed IO) r, Member UserStore r) => ClientState -> InterpreterFor UserKeyStore r
interpretUserKeyStoreCassandra :: forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> InterpreterFor UserKeyStore r
interpretUserKeyStoreCassandra ClientState
casClient =
  (forall (rInitial :: EffectRow) x.
 UserKeyStore (Sem rInitial) x -> Sem r x)
-> Sem (UserKeyStore : 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.
  UserKeyStore (Sem rInitial) x -> Sem r x)
 -> Sem (UserKeyStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    UserKeyStore (Sem rInitial) x -> Sem r x)
-> Sem (UserKeyStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
    (forall x. Client x -> IO x) -> Sem (Embed Client : r) x -> Sem r x
forall (m1 :: * -> *) (m2 :: * -> *) (r :: EffectRow) a.
Member (Embed m2) r =>
(forall x. m1 x -> m2 x) -> Sem (Embed m1 : r) a -> Sem r a
runEmbedded (ClientState -> Client x -> IO x
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
casClient) (Sem (Embed Client : r) x -> Sem r x)
-> (UserKeyStore (Sem rInitial) x -> Sem (Embed Client : r) x)
-> UserKeyStore (Sem rInitial) x
-> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      LookupKey EmailKey
key -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ EmailKey -> Client (Maybe UserId)
forall (m :: * -> *). MonadClient m => EmailKey -> m (Maybe UserId)
lookupKeyImpl EmailKey
key
      InsertKey UserId
uid EmailKey
key -> Client () -> Sem (Embed Client : r) ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client () -> Sem (Embed Client : r) ())
-> Client () -> Sem (Embed Client : r) ()
forall a b. (a -> b) -> a -> b
$ UserId -> EmailKey -> Client ()
insertKeyImpl UserId
uid EmailKey
key
      DeleteKey EmailKey
key -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ EmailKey -> Client ()
forall (m :: * -> *). MonadClient m => EmailKey -> m ()
deleteKeyImpl EmailKey
key
      DeleteKeyForUser UserId
uid EmailKey
key -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> EmailKey -> Client ()
forall (m :: * -> *). MonadClient m => UserId -> EmailKey -> m ()
deleteKeyForUserImpl UserId
uid EmailKey
key
      ClaimKey EmailKey
key UserId
uid -> ClientState -> EmailKey -> UserId -> Sem (Embed Client : r) Bool
forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> EmailKey -> UserId -> Sem r Bool
claimKeyImpl ClientState
casClient EmailKey
key UserId
uid
      KeyAvailable EmailKey
key Maybe UserId
uid -> ClientState
-> EmailKey -> Maybe UserId -> Sem (Embed Client : r) Bool
forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> EmailKey -> Maybe UserId -> Sem r Bool
keyAvailableImpl ClientState
casClient EmailKey
key Maybe UserId
uid

-- | Claim an 'EmailKey' for a user.
claimKeyImpl ::
  (Member (Embed IO) r, Member UserStore r) =>
  ClientState ->
  -- | The key to claim.
  EmailKey ->
  -- | The user claiming the key.
  UserId ->
  Sem r Bool
claimKeyImpl :: forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> EmailKey -> UserId -> Sem r Bool
claimKeyImpl ClientState
client EmailKey
k UserId
u = do
  Bool
free <- ClientState -> EmailKey -> Maybe UserId -> Sem r Bool
forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> EmailKey -> Maybe UserId -> Sem r Bool
keyAvailableImpl ClientState
client EmailKey
k (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
u)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
free (ClientState -> Client () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
client (Client () -> Sem r ()) -> Client () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ UserId -> EmailKey -> Client ()
insertKeyImpl UserId
u EmailKey
k)
  Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
free

-- | Check whether an 'EmailKey' is available.
-- A key is available if it is not already activated for another user or
-- if the other user and the user looking to claim the key are the same.
keyAvailableImpl ::
  (Member (Embed IO) r, Member UserStore r) =>
  ClientState ->
  -- | The key to check.
  EmailKey ->
  -- | The user looking to claim the key, if any.
  Maybe UserId ->
  Sem r Bool
keyAvailableImpl :: forall (r :: EffectRow).
(Member (Embed IO) r, Member UserStore r) =>
ClientState -> EmailKey -> Maybe UserId -> Sem r Bool
keyAvailableImpl ClientState
client EmailKey
k Maybe UserId
u = do
  Maybe UserId
o <- ClientState -> Client (Maybe UserId) -> Sem r (Maybe UserId)
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
client (Client (Maybe UserId) -> Sem r (Maybe UserId))
-> Client (Maybe UserId) -> Sem r (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ EmailKey -> Client (Maybe UserId)
forall (m :: * -> *). MonadClient m => EmailKey -> m (Maybe UserId)
lookupKeyImpl EmailKey
k
  case (Maybe UserId
o, Maybe UserId
u) of
    (Maybe UserId
Nothing, Maybe UserId
_) -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    (Just UserId
x, Just UserId
y) | UserId
x UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
y -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    (Just UserId
x, Maybe UserId
_) -> Bool -> Bool
not (Bool -> Bool) -> Sem r Bool -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserId -> Sem r Bool
forall (r :: EffectRow). Member UserStore r => UserId -> Sem r Bool
isActivated UserId
x

lookupKeyImpl :: (MonadClient m) => EmailKey -> m (Maybe UserId)
lookupKeyImpl :: forall (m :: * -> *). MonadClient m => EmailKey -> m (Maybe UserId)
lookupKeyImpl EmailKey
k =
  (Identity UserId -> UserId)
-> Maybe (Identity UserId) -> Maybe UserId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity UserId -> UserId
forall a. Identity a -> a
runIdentity
    (Maybe (Identity UserId) -> Maybe UserId)
-> m (Maybe (Identity UserId)) -> m (Maybe UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetrySettings
-> m (Maybe (Identity UserId)) -> m (Maybe (Identity UserId))
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R (Identity Text) (Identity UserId)
-> QueryParams (Identity Text) -> m (Maybe (Identity UserId))
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m (Maybe b)
query1 PrepQuery R (Identity Text) (Identity UserId)
keySelect (Consistency -> Identity Text -> QueryParams (Identity Text)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Text -> Identity Text
forall a. a -> Identity a
Identity (Text -> Identity Text) -> Text -> Identity Text
forall a b. (a -> b) -> a -> b
$ EmailKey -> Text
emailKeyUniq EmailKey
k)))

insertKeyImpl :: UserId -> EmailKey -> Client ()
insertKeyImpl :: UserId -> EmailKey -> Client ()
insertKeyImpl UserId
u EmailKey
k = do
  RetrySettings -> Client () -> Client ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (Client () -> Client ()) -> Client () -> Client ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Text, UserId) ()
-> QueryParams (Text, UserId) -> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Text, UserId) ()
keyInsert (Consistency -> (Text, UserId) -> QueryParams (Text, UserId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (EmailKey -> Text
emailKeyUniq EmailKey
k, UserId
u))

deleteKeyImpl :: (MonadClient m) => EmailKey -> m ()
deleteKeyImpl :: forall (m :: * -> *). MonadClient m => EmailKey -> m ()
deleteKeyImpl EmailKey
k = do
  RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Identity Text) ()
-> QueryParams (Identity Text) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Identity Text) ()
keyDelete (Consistency -> Identity Text -> QueryParams (Identity Text)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Text -> Identity Text
forall a. a -> Identity a
Identity (Text -> Identity Text) -> Text -> Identity Text
forall a b. (a -> b) -> a -> b
$ EmailKey -> Text
emailKeyUniq EmailKey
k))

-- | Delete `EmailKey` for `UserId`
--
-- This function ensures that keys of other users aren't accidentally deleted.
-- E.g. the email address or phone number of a partially deleted user could
-- already belong to a new user. To not interrupt deletion flows (that may be
-- executed several times due to cassandra not supporting transactions)
-- `deleteKeyImplForUser` does not fail for missing keys or keys that belong to
-- another user: It always returns `()` as result.
deleteKeyForUserImpl :: (MonadClient m) => UserId -> EmailKey -> m ()
deleteKeyForUserImpl :: forall (m :: * -> *). MonadClient m => UserId -> EmailKey -> m ()
deleteKeyForUserImpl UserId
uid EmailKey
k = do
  Maybe UserId
mbKeyUid <- EmailKey -> m (Maybe UserId)
forall (m :: * -> *). MonadClient m => EmailKey -> m (Maybe UserId)
lookupKeyImpl EmailKey
k
  case Maybe UserId
mbKeyUid of
    Just UserId
keyUid | UserId
keyUid UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
uid -> EmailKey -> m ()
forall (m :: * -> *). MonadClient m => EmailKey -> m ()
deleteKeyImpl EmailKey
k
    Maybe UserId
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

--------------------------------------------------------------------------------
-- Queries

keyInsert :: PrepQuery W (Text, UserId) ()
keyInsert :: PrepQuery W (Text, UserId) ()
keyInsert = PrepQuery W (Text, UserId) ()
"INSERT INTO user_keys (key, user) VALUES (?, ?)"

keySelect :: PrepQuery R (Identity Text) (Identity UserId)
keySelect :: PrepQuery R (Identity Text) (Identity UserId)
keySelect = PrepQuery R (Identity Text) (Identity UserId)
"SELECT user FROM user_keys WHERE key = ?"

keyDelete :: PrepQuery W (Identity Text) ()
keyDelete :: PrepQuery W (Identity Text) ()
keyDelete = PrepQuery W (Identity Text) ()
"DELETE FROM user_keys WHERE key = ?"