-- 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 Wire.API.MLS.CommitBundle (CommitBundle (..)) where

import Control.Applicative
import Data.OpenApi qualified as S
import Data.Text qualified as T
import Imports
import Wire.API.MLS.GroupInfo
import Wire.API.MLS.Message
import Wire.API.MLS.Serialisation
import Wire.API.MLS.Welcome

data CommitBundle = CommitBundle
  { CommitBundle -> RawMLS Message
commitMsg :: RawMLS Message,
    CommitBundle -> Maybe (RawMLS Welcome)
welcome :: Maybe (RawMLS Welcome),
    CommitBundle -> RawMLS GroupInfo
groupInfo :: RawMLS GroupInfo
  }
  deriving stock (CommitBundle -> CommitBundle -> Bool
(CommitBundle -> CommitBundle -> Bool)
-> (CommitBundle -> CommitBundle -> Bool) -> Eq CommitBundle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommitBundle -> CommitBundle -> Bool
== :: CommitBundle -> CommitBundle -> Bool
$c/= :: CommitBundle -> CommitBundle -> Bool
/= :: CommitBundle -> CommitBundle -> Bool
Eq, Int -> CommitBundle -> ShowS
[CommitBundle] -> ShowS
CommitBundle -> String
(Int -> CommitBundle -> ShowS)
-> (CommitBundle -> String)
-> ([CommitBundle] -> ShowS)
-> Show CommitBundle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommitBundle -> ShowS
showsPrec :: Int -> CommitBundle -> ShowS
$cshow :: CommitBundle -> String
show :: CommitBundle -> String
$cshowList :: [CommitBundle] -> ShowS
showList :: [CommitBundle] -> ShowS
Show, (forall x. CommitBundle -> Rep CommitBundle x)
-> (forall x. Rep CommitBundle x -> CommitBundle)
-> Generic CommitBundle
forall x. Rep CommitBundle x -> CommitBundle
forall x. CommitBundle -> Rep CommitBundle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommitBundle -> Rep CommitBundle x
from :: forall x. CommitBundle -> Rep CommitBundle x
$cto :: forall x. Rep CommitBundle x -> CommitBundle
to :: forall x. Rep CommitBundle x -> CommitBundle
Generic)

data CommitBundleF f = CommitBundleF
  { forall (f :: * -> *). CommitBundleF f -> f (RawMLS Message)
commitMsg :: f (RawMLS Message),
    forall (f :: * -> *). CommitBundleF f -> f (RawMLS Welcome)
welcome :: f (RawMLS Welcome),
    forall (f :: * -> *). CommitBundleF f -> f (RawMLS GroupInfo)
groupInfo :: f (RawMLS GroupInfo)
  }

deriving instance Show (CommitBundleF [])

instance (Alternative f) => Semigroup (CommitBundleF f) where
  CommitBundleF f
cb1 <> :: CommitBundleF f -> CommitBundleF f -> CommitBundleF f
<> CommitBundleF f
cb2 =
    f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
forall (f :: * -> *).
f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
CommitBundleF
      (CommitBundleF f
cb1.commitMsg f (RawMLS Message) -> f (RawMLS Message) -> f (RawMLS Message)
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommitBundleF f
cb2.commitMsg)
      (CommitBundleF f
cb1.welcome f (RawMLS Welcome) -> f (RawMLS Welcome) -> f (RawMLS Welcome)
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommitBundleF f
cb2.welcome)
      (CommitBundleF f
cb1.groupInfo f (RawMLS GroupInfo)
-> f (RawMLS GroupInfo) -> f (RawMLS GroupInfo)
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommitBundleF f
cb2.groupInfo)

instance (Alternative f) => Monoid (CommitBundleF f) where
  mempty :: CommitBundleF f
mempty = f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
forall (f :: * -> *).
f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
CommitBundleF f (RawMLS Message)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty f (RawMLS Welcome)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty f (RawMLS GroupInfo)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty

checkCommitBundleF :: CommitBundleF [] -> Either Text CommitBundle
checkCommitBundleF :: CommitBundleF [] -> Either Text CommitBundle
checkCommitBundleF CommitBundleF []
cb =
  RawMLS Message
-> Maybe (RawMLS Welcome) -> RawMLS GroupInfo -> CommitBundle
CommitBundle
    (RawMLS Message
 -> Maybe (RawMLS Welcome) -> RawMLS GroupInfo -> CommitBundle)
-> Either Text (RawMLS Message)
-> Either
     Text (Maybe (RawMLS Welcome) -> RawMLS GroupInfo -> CommitBundle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [RawMLS Message] -> Either Text (RawMLS Message)
forall a. Text -> [a] -> Either Text a
check Text
"commit" CommitBundleF []
cb.commitMsg
    Either
  Text (Maybe (RawMLS Welcome) -> RawMLS GroupInfo -> CommitBundle)
-> Either Text (Maybe (RawMLS Welcome))
-> Either Text (RawMLS GroupInfo -> CommitBundle)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> [RawMLS Welcome] -> Either Text (Maybe (RawMLS Welcome))
forall a. Text -> [a] -> Either Text (Maybe a)
checkOpt Text
"welcome" CommitBundleF []
cb.welcome
    Either Text (RawMLS GroupInfo -> CommitBundle)
-> Either Text (RawMLS GroupInfo) -> Either Text CommitBundle
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> [RawMLS GroupInfo] -> Either Text (RawMLS GroupInfo)
forall a. Text -> [a] -> Either Text a
check Text
"group info" CommitBundleF []
cb.groupInfo
  where
    check :: Text -> [a] -> Either Text a
    check :: forall a. Text -> [a] -> Either Text a
check Text
_ [a
x] = a -> Either Text a
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    check Text
name [] = Text -> Either Text a
forall a b. a -> Either a b
Left (Text
"Missing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
    check Text
name [a]
_ = Text -> Either Text a
forall a b. a -> Either a b
Left (Text
"Redundant occurrence of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)

    checkOpt :: Text -> [a] -> Either Text (Maybe a)
    checkOpt :: forall a. Text -> [a] -> Either Text (Maybe a)
checkOpt Text
_ [] = Maybe a -> Either Text (Maybe a)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    checkOpt Text
_ [a
x] = Maybe a -> Either Text (Maybe a)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    checkOpt Text
name [a]
_ = Text -> Either Text (Maybe a)
forall a b. a -> Either a b
Left (Text
"Redundant occurrence of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)

findMessageInStream :: (Alternative f) => RawMLS Message -> Either Text (CommitBundleF f)
findMessageInStream :: forall (f :: * -> *).
Alternative f =>
RawMLS Message -> Either Text (CommitBundleF f)
findMessageInStream RawMLS Message
msg = case RawMLS Message
msg.value.content of
  MessagePublic PublicMessage
mp -> case PublicMessage
mp.content.value.content of
    FramedContentCommit RawMLS Commit
_ -> CommitBundleF f -> Either Text (CommitBundleF f)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
forall (f :: * -> *).
f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
CommitBundleF (RawMLS Message -> f (RawMLS Message)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMLS Message
msg) f (RawMLS Welcome)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty f (RawMLS GroupInfo)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty)
    FramedContentData
_ -> Text -> Either Text (CommitBundleF f)
forall a b. a -> Either a b
Left Text
"unexpected public message"
  MessageWelcome RawMLS Welcome
w -> CommitBundleF f -> Either Text (CommitBundleF f)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
forall (f :: * -> *).
f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
CommitBundleF f (RawMLS Message)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty (RawMLS Welcome -> f (RawMLS Welcome)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMLS Welcome
w) f (RawMLS GroupInfo)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty)
  MessageGroupInfo RawMLS GroupInfo
gi -> CommitBundleF f -> Either Text (CommitBundleF f)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
forall (f :: * -> *).
f (RawMLS Message)
-> f (RawMLS Welcome) -> f (RawMLS GroupInfo) -> CommitBundleF f
CommitBundleF f (RawMLS Message)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty f (RawMLS Welcome)
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty (RawMLS GroupInfo -> f (RawMLS GroupInfo)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMLS GroupInfo
gi))
  MessageContent
_ -> Text -> Either Text (CommitBundleF f)
forall a b. a -> Either a b
Left Text
"unexpected message type"

findMessagesInStream :: (Alternative f) => [RawMLS Message] -> Either Text (CommitBundleF f)
findMessagesInStream :: forall (f :: * -> *).
Alternative f =>
[RawMLS Message] -> Either Text (CommitBundleF f)
findMessagesInStream = Ap (Either Text) (CommitBundleF f) -> Either Text (CommitBundleF f)
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (Either Text) (CommitBundleF f)
 -> Either Text (CommitBundleF f))
-> ([RawMLS Message] -> Ap (Either Text) (CommitBundleF f))
-> [RawMLS Message]
-> Either Text (CommitBundleF f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawMLS Message -> Ap (Either Text) (CommitBundleF f))
-> [RawMLS Message] -> Ap (Either Text) (CommitBundleF f)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Either Text (CommitBundleF f) -> Ap (Either Text) (CommitBundleF f)
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (Either Text (CommitBundleF f)
 -> Ap (Either Text) (CommitBundleF f))
-> (RawMLS Message -> Either Text (CommitBundleF f))
-> RawMLS Message
-> Ap (Either Text) (CommitBundleF f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawMLS Message -> Either Text (CommitBundleF f)
forall (f :: * -> *).
Alternative f =>
RawMLS Message -> Either Text (CommitBundleF f)
findMessageInStream)

instance ParseMLS CommitBundle where
  parseMLS :: Get CommitBundle
parseMLS = do
    [RawMLS Message]
msgs <- Get (RawMLS Message) -> Get [RawMLS Message]
forall a. Get a -> Get [a]
parseMLSStream Get (RawMLS Message)
forall a. ParseMLS a => Get a
parseMLS
    (Text -> Get CommitBundle)
-> (CommitBundle -> Get CommitBundle)
-> Either Text CommitBundle
-> Get CommitBundle
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get CommitBundle
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get CommitBundle)
-> (Text -> String) -> Text -> Get CommitBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) CommitBundle -> Get CommitBundle
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text CommitBundle -> Get CommitBundle)
-> Either Text CommitBundle -> Get CommitBundle
forall a b. (a -> b) -> a -> b
$
      [RawMLS Message] -> Either Text (CommitBundleF [])
forall (f :: * -> *).
Alternative f =>
[RawMLS Message] -> Either Text (CommitBundleF f)
findMessagesInStream [RawMLS Message]
msgs Either Text (CommitBundleF [])
-> (CommitBundleF [] -> Either Text CommitBundle)
-> Either Text CommitBundle
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CommitBundleF [] -> Either Text CommitBundle
checkCommitBundleF

instance SerialiseMLS CommitBundle where
  serialiseMLS :: CommitBundle -> Put
serialiseMLS CommitBundle
cb = do
    RawMLS Message -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS CommitBundle
cb.commitMsg
    (RawMLS Welcome -> Put) -> Maybe (RawMLS Welcome) -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Message -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS (Message -> Put)
-> (RawMLS Welcome -> Message) -> RawMLS Welcome -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageContent -> Message
mkMessage (MessageContent -> Message)
-> (RawMLS Welcome -> MessageContent) -> RawMLS Welcome -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawMLS Welcome -> MessageContent
MessageWelcome) CommitBundle
cb.welcome
    Message -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS (Message -> Put) -> Message -> Put
forall a b. (a -> b) -> a -> b
$ MessageContent -> Message
mkMessage (RawMLS GroupInfo -> MessageContent
MessageGroupInfo CommitBundle
cb.groupInfo)

instance S.ToSchema CommitBundle where
  declareNamedSchema :: Proxy CommitBundle -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy CommitBundle
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> NamedSchema
mlsSwagger Text
"CommitBundle")