-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.Cassandra.Proposal
  ( interpretProposalStoreToCassandra,
    ProposalOrigin (..),
  )
where

import Cassandra
import Data.Timeout
import Galley.Cassandra.Instances ()
import Galley.Cassandra.Store
import Galley.Cassandra.Util
import Galley.Effects.ProposalStore
import Imports
import Polysemy
import Polysemy.Input
import Polysemy.TinyLog
import Wire.API.MLS.Epoch
import Wire.API.MLS.Group
import Wire.API.MLS.Proposal
import Wire.API.MLS.Serialisation

-- | Proposals in the database expire after this timeout
defaultTTL :: Timeout
defaultTTL :: Timeout
defaultTTL = Word64
28 Word64 -> TimeoutUnit -> Timeout
# TimeoutUnit
Day

interpretProposalStoreToCassandra ::
  ( Member (Embed IO) r,
    Member (Input ClientState) r,
    Member TinyLog r
  ) =>
  Sem (ProposalStore ': r) a ->
  Sem r a
interpretProposalStoreToCassandra :: forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r,
 Member TinyLog r) =>
Sem (ProposalStore : r) a -> Sem r a
interpretProposalStoreToCassandra = (forall (rInitial :: EffectRow) x.
 ProposalStore (Sem rInitial) x -> Sem r x)
-> Sem (ProposalStore : 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.
  ProposalStore (Sem rInitial) x -> Sem r x)
 -> Sem (ProposalStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    ProposalStore (Sem rInitial) x -> Sem r x)
-> Sem (ProposalStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  StoreProposal GroupId
groupId Epoch
epoch ProposalRef
ref ProposalOrigin
origin RawMLS Proposal
raw -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ProposalStore.StoreProposal"
    Client x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client x -> Sem r x)
-> (Client x -> Client x) -> Client x -> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetrySettings -> Client x -> Client x
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (Client x -> Sem r x) -> Client x -> Sem r x
forall a b. (a -> b) -> a -> b
$
      PrepQuery
  W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
-> QueryParams
     (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal)
-> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write (Timeout
-> PrepQuery
     W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
storeQuery Timeout
defaultTTL) (Consistency
-> (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal)
-> QueryParams
     (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (GroupId
groupId, Epoch
epoch, ProposalRef
ref, ProposalOrigin
origin, RawMLS Proposal
raw))
  GetProposal GroupId
groupId Epoch
epoch ProposalRef
ref -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ProposalStore.GetProposal"
    Client x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Identity (RawMLS Proposal) -> RawMLS Proposal
forall a. Identity a -> a
runIdentity (Identity (RawMLS Proposal) -> RawMLS Proposal)
-> Client (Maybe (Identity (RawMLS Proposal)))
-> Client (Maybe (RawMLS Proposal))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> RetrySettings
-> Client (Maybe (Identity (RawMLS Proposal)))
-> Client (Maybe (Identity (RawMLS Proposal)))
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery
  R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal))
-> QueryParams (GroupId, Epoch, ProposalRef)
-> Client (Maybe (Identity (RawMLS Proposal)))
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 (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal))
getQuery (Consistency
-> (GroupId, Epoch, ProposalRef)
-> QueryParams (GroupId, Epoch, ProposalRef)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (GroupId
groupId, Epoch
epoch, ProposalRef
ref))))
  GetAllPendingProposalRefs GroupId
groupId Epoch
epoch -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ProposalStore.GetAllPendingProposalRefs"
    Client x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Identity ProposalRef -> ProposalRef
forall a. Identity a -> a
runIdentity (Identity ProposalRef -> ProposalRef)
-> Client [Identity ProposalRef] -> Client [ProposalRef]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> RetrySettings
-> Client [Identity ProposalRef] -> Client [Identity ProposalRef]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R (GroupId, Epoch) (Identity ProposalRef)
-> QueryParams (GroupId, Epoch) -> Client [Identity ProposalRef]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R (GroupId, Epoch) (Identity ProposalRef)
getAllPendingRef (Consistency -> (GroupId, Epoch) -> QueryParams (GroupId, Epoch)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (GroupId
groupId, Epoch
epoch))))
  GetAllPendingProposals GroupId
groupId Epoch
epoch -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ProposalStore.GetAllPendingProposals"
    Client x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client x -> Sem r x) -> Client x -> Sem r x
forall a b. (a -> b) -> a -> b
$ RetrySettings -> Client x -> Client x
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery
  R (GroupId, Epoch) (Maybe ProposalOrigin, RawMLS Proposal)
-> QueryParams (GroupId, Epoch)
-> Client [(Maybe ProposalOrigin, RawMLS Proposal)]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery
  R (GroupId, Epoch) (Maybe ProposalOrigin, RawMLS Proposal)
getAllPending (Consistency -> (GroupId, Epoch) -> QueryParams (GroupId, Epoch)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (GroupId
groupId, Epoch
epoch)))
  DeleteAllProposals GroupId
groupId -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ProposalStore.DeleteAllProposals"
    Client x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client x -> Sem r x) -> Client x -> Sem r x
forall a b. (a -> b) -> a -> b
$ RetrySettings -> Client x -> Client x
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (PrepQuery W (Identity GroupId) ()
-> QueryParams (Identity GroupId) -> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Identity GroupId) ()
deleteAllProposalsForGroup (Consistency -> Identity GroupId -> QueryParams (Identity GroupId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (GroupId -> Identity GroupId
forall a. a -> Identity a
Identity GroupId
groupId)))

storeQuery :: Timeout -> PrepQuery W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
storeQuery :: Timeout
-> PrepQuery
     W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
storeQuery Timeout
ttl =
  String
-> PrepQuery
     W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
forall a. IsString a => String -> a
fromString (String
 -> PrepQuery
      W
      (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal)
      ())
-> String
-> PrepQuery
     W (GroupId, Epoch, ProposalRef, ProposalOrigin, RawMLS Proposal) ()
forall a b. (a -> b) -> a -> b
$
    String
"insert into mls_proposal_refs (group_id, epoch, ref, origin, proposal)\
    \ values (?, ?, ?, ?, ?) using ttl "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show (Timeout
ttl Timeout -> TimeoutUnit -> Word64
#> TimeoutUnit
Second)

getQuery :: PrepQuery R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal))
getQuery :: PrepQuery
  R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal))
getQuery = PrepQuery
  R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal))
"select proposal from mls_proposal_refs where group_id = ? and epoch = ? and ref = ?"

getAllPendingRef :: PrepQuery R (GroupId, Epoch) (Identity ProposalRef)
getAllPendingRef :: PrepQuery R (GroupId, Epoch) (Identity ProposalRef)
getAllPendingRef = PrepQuery R (GroupId, Epoch) (Identity ProposalRef)
"select ref from mls_proposal_refs where group_id = ? and epoch = ?"

getAllPending :: PrepQuery R (GroupId, Epoch) (Maybe ProposalOrigin, RawMLS Proposal)
getAllPending :: PrepQuery
  R (GroupId, Epoch) (Maybe ProposalOrigin, RawMLS Proposal)
getAllPending = PrepQuery
  R (GroupId, Epoch) (Maybe ProposalOrigin, RawMLS Proposal)
"select origin, proposal from mls_proposal_refs where group_id = ? and epoch = ?"

deleteAllProposalsForGroup :: PrepQuery W (Identity GroupId) ()
deleteAllProposalsForGroup :: PrepQuery W (Identity GroupId) ()
deleteAllProposalsForGroup = PrepQuery W (Identity GroupId) ()
"delete from mls_proposal_refs where group_id = ?"