-- 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.Intra.Client
  ( lookupClients,
    lookupClientsFull,
    notifyClientsAboutLegalHoldRequest,
    addLegalHoldClientToUser,
    removeLegalHoldClientFromUser,
    getLegalHoldAuthToken,
    getLocalMLSClients,
  )
where

import Bilge hiding (getHeader, options, statusCode)
import Bilge.RPC
import Brig.Types.Intra
import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..))
import Data.ByteString.Conversion
import Data.Id
import Data.Misc
import Data.Qualified
import Data.Set qualified as Set
import Data.Text.Encoding
import Galley.API.Error
import Galley.Effects
import Galley.Env
import Galley.External.LegalHoldService.Types
import Galley.Intra.Util
import Galley.Monad
import Imports
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Network.Wai.Utilities.Error hiding (Error)
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import Servant.API
import System.Logger.Class qualified as Logger
import Wire.API.Error.Galley
import Wire.API.MLS.CipherSuite
import Wire.API.User.Auth.LegalHold
import Wire.API.User.Client
import Wire.API.User.Client.Prekey

-- | Calls 'Brig.API.internalListClientsH'.
lookupClients :: [UserId] -> App UserClients
lookupClients :: [UserId] -> App UserClients
lookupClients [UserId]
uids = do
  Response (Maybe ByteString)
r <-
    IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request) -> App (Response (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$
      StdMethod -> Request -> Request
method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
path ByteString
"/i/clients"
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserSet -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
json (Set UserId -> UserSet
UserSet (Set UserId -> UserSet) -> Set UserId -> UserSet
forall a b. (a -> b) -> a -> b
$ [UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
uids)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx
  UserClients
clients <- (LText -> Error) -> Response (Maybe ByteString) -> App UserClients
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, FromJSON a) =>
(LText -> e) -> Response (Maybe ByteString) -> m a
parseResponse (Status -> LText -> LText -> Error
mkError Status
status502 LText
"server-error") Response (Maybe ByteString)
r
  UserClients -> App UserClients
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserClients -> App UserClients) -> UserClients -> App UserClients
forall a b. (a -> b) -> a -> b
$ (Set ClientId -> Bool) -> UserClients -> UserClients
filterClients (Bool -> Bool
not (Bool -> Bool) -> (Set ClientId -> Bool) -> Set ClientId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ClientId -> Bool
forall a. Set a -> Bool
Set.null) UserClients
clients

-- | Calls 'Brig.API.internalListClientsFullH'.
lookupClientsFull ::
  [UserId] ->
  App UserClientsFull
lookupClientsFull :: [UserId] -> App UserClientsFull
lookupClientsFull [UserId]
uids = do
  Response (Maybe ByteString)
r <-
    IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request) -> App (Response (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$
      StdMethod -> Request -> Request
method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
path ByteString
"/i/clients/full"
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserSet -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
json (Set UserId -> UserSet
UserSet (Set UserId -> UserSet) -> Set UserId -> UserSet
forall a b. (a -> b) -> a -> b
$ [UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
uids)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx
  UserClientsFull
clients <- (LText -> Error)
-> Response (Maybe ByteString) -> App UserClientsFull
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, FromJSON a) =>
(LText -> e) -> Response (Maybe ByteString) -> m a
parseResponse (Status -> LText -> LText -> Error
mkError Status
status502 LText
"server-error") Response (Maybe ByteString)
r
  UserClientsFull -> App UserClientsFull
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserClientsFull -> App UserClientsFull)
-> UserClientsFull -> App UserClientsFull
forall a b. (a -> b) -> a -> b
$ (Set Client -> Bool) -> UserClientsFull -> UserClientsFull
filterClientsFull (Bool -> Bool
not (Bool -> Bool) -> (Set Client -> Bool) -> Set Client -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Client -> Bool
forall a. Set a -> Bool
Set.null) UserClientsFull
clients

-- | Calls 'Brig.API.legalHoldClientRequestedH'.
notifyClientsAboutLegalHoldRequest ::
  UserId ->
  UserId ->
  LastPrekey ->
  App ()
notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> App ()
notifyClientsAboutLegalHoldRequest UserId
requesterUid UserId
targetUid LastPrekey
lastPrekey' = do
  App (Response (Maybe ByteString)) -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App (Response (Maybe ByteString)) -> App ())
-> ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request)
-> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> App ()) -> (Request -> Request) -> App ()
forall a b. (a -> b) -> a -> b
$
    StdMethod -> Request -> Request
method StdMethod
POST
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Request -> Request
paths [ByteString
"i", ByteString
"clients", ByteString
"legalhold", UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' UserId
targetUid, ByteString
"request"]
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LegalHoldClientRequest -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
json (UserId -> LastPrekey -> LegalHoldClientRequest
LegalHoldClientRequest UserId
requesterUid LastPrekey
lastPrekey')
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx

-- | Calls 'Brig.User.API.Auth.legalHoldLoginH'.
getLegalHoldAuthToken ::
  ( Member (Embed IO) r,
    Member (Error InternalError) r,
    Member P.TinyLog r,
    Member (Input Env) r
  ) =>
  UserId ->
  Maybe PlainTextPassword6 ->
  Sem r OpaqueAuthToken
getLegalHoldAuthToken :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error InternalError) r,
 Member TinyLog r, Member (Input Env) r) =>
UserId -> Maybe PlainTextPassword6 -> Sem r OpaqueAuthToken
getLegalHoldAuthToken UserId
uid Maybe PlainTextPassword6
pw = do
  Response (Maybe ByteString)
r <-
    App (Response (Maybe ByteString))
-> Sem r (Response (Maybe ByteString))
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App (Response (Maybe ByteString))
 -> Sem r (Response (Maybe ByteString)))
-> ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request)
-> Sem r (Response (Maybe ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> Sem r (Response (Maybe ByteString)))
-> (Request -> Request) -> Sem r (Response (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$
      StdMethod -> Request -> Request
method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
path ByteString
"/i/legalhold-login"
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Request -> Request
queryItem ByteString
"persist" ByteString
"true"
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LegalHoldLogin -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
json (UserId
-> Maybe PlainTextPassword6 -> Maybe CookieLabel -> LegalHoldLogin
LegalHoldLogin UserId
uid Maybe PlainTextPassword6
pw Maybe CookieLabel
forall a. Maybe a
Nothing)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx
  case ByteString -> Response (Maybe ByteString) -> Maybe ByteString
forall a. ByteString -> Response a -> Maybe ByteString
getCookieValue ByteString
"zuid" Response (Maybe ByteString)
r of
    Maybe ByteString
Nothing -> do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.warn ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall a. ToBytes a => a -> Msg -> Msg
Logger.msg @Text Text
"Response from login missing auth cookie"
      InternalError -> Sem r OpaqueAuthToken
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (InternalError -> Sem r OpaqueAuthToken)
-> InternalError -> Sem r OpaqueAuthToken
forall a b. (a -> b) -> a -> b
$ LText -> InternalError
InternalErrorWithDescription LText
"internal error"
    Just ByteString
c -> OpaqueAuthToken -> Sem r OpaqueAuthToken
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpaqueAuthToken -> Sem r OpaqueAuthToken)
-> (ByteString -> OpaqueAuthToken)
-> ByteString
-> Sem r OpaqueAuthToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> OpaqueAuthToken
OpaqueAuthToken (Text -> OpaqueAuthToken)
-> (ByteString -> Text) -> ByteString -> OpaqueAuthToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Sem r OpaqueAuthToken)
-> ByteString -> Sem r OpaqueAuthToken
forall a b. (a -> b) -> a -> b
$ ByteString
c

-- | Calls 'Brig.API.addClientInternalH'.
addLegalHoldClientToUser ::
  UserId ->
  ConnId ->
  [Prekey] ->
  LastPrekey ->
  App (Either AuthenticationError ClientId)
addLegalHoldClientToUser :: UserId
-> ConnId
-> [Prekey]
-> LastPrekey
-> App (Either AuthenticationError ClientId)
addLegalHoldClientToUser UserId
uid ConnId
connId [Prekey]
prekeys LastPrekey
lastPrekey' = do
  (Client -> ClientId)
-> Either AuthenticationError Client
-> Either AuthenticationError ClientId
forall a b.
(a -> b)
-> Either AuthenticationError a -> Either AuthenticationError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Client -> ClientId
clientId (Either AuthenticationError Client
 -> Either AuthenticationError ClientId)
-> App (Either AuthenticationError Client)
-> App (Either AuthenticationError ClientId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserId
-> ConnId -> NewClient -> App (Either AuthenticationError Client)
brigAddClient UserId
uid ConnId
connId NewClient
lhClient
  where
    lhClient :: NewClient
lhClient =
      [Prekey]
-> LastPrekey
-> ClientType
-> Maybe Text
-> Maybe ClientClass
-> Maybe CookieLabel
-> Maybe PlainTextPassword6
-> Maybe Text
-> Maybe (Set ClientCapability)
-> MLSPublicKeys
-> Maybe Value
-> NewClient
NewClient
        [Prekey]
prekeys
        LastPrekey
lastPrekey'
        ClientType
LegalHoldClientType
        Maybe Text
forall a. Maybe a
Nothing
        (ClientClass -> Maybe ClientClass
forall a. a -> Maybe a
Just ClientClass
LegalHoldClient)
        Maybe CookieLabel
forall a. Maybe a
Nothing
        Maybe PlainTextPassword6
forall a. Maybe a
Nothing
        Maybe Text
forall a. Maybe a
Nothing
        Maybe (Set ClientCapability)
forall a. Maybe a
Nothing
        MLSPublicKeys
forall a. Monoid a => a
mempty
        Maybe Value
forall a. Maybe a
Nothing

-- | Calls 'Brig.API.removeLegalHoldClientH'.
removeLegalHoldClientFromUser ::
  UserId ->
  App ()
removeLegalHoldClientFromUser :: UserId -> App ()
removeLegalHoldClientFromUser UserId
targetUid = do
  App (Response (Maybe ByteString)) -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App (Response (Maybe ByteString)) -> App ())
-> ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request)
-> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> App ()) -> (Request -> Request) -> App ()
forall a b. (a -> b) -> a -> b
$
    StdMethod -> Request -> Request
method StdMethod
DELETE
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Request -> Request
paths [ByteString
"i", ByteString
"clients", ByteString
"legalhold", UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' UserId
targetUid]
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
contentJson
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx

-- | Calls 'Brig.API.addClientInternalH'.
brigAddClient :: UserId -> ConnId -> NewClient -> App (Either AuthenticationError Client)
brigAddClient :: UserId
-> ConnId -> NewClient -> App (Either AuthenticationError Client)
brigAddClient UserId
uid ConnId
connId NewClient
client = do
  Response (Maybe ByteString)
r <-
    IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call IntraComponent
Brig ((Request -> Request) -> App (Response (Maybe ByteString)))
-> (Request -> Request) -> App (Response (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$
      StdMethod -> Request -> Request
method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> Request -> Request
header HeaderName
"Z-Connection" (ConnId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' ConnId
connId)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Request -> Request
paths [ByteString
"i", ByteString
"clients", UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' UserId
uid]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
contentJson
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewClient -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
json NewClient
client
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Request -> Request
expectStatus ((Int -> [Int] -> Bool) -> [Int] -> Int -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Int
201, Int
403])
  if Status -> Int
statusCode (Response (Maybe ByteString) -> Status
forall body. Response body -> Status
responseStatus Response (Maybe ByteString)
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
201
    then Client -> Either AuthenticationError Client
forall a b. b -> Either a b
Right (Client -> Either AuthenticationError Client)
-> App Client -> App (Either AuthenticationError Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LText -> Error) -> Response (Maybe ByteString) -> App Client
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, FromJSON a) =>
(LText -> e) -> Response (Maybe ByteString) -> m a
parseResponse (Status -> LText -> LText -> Error
mkError Status
status502 LText
"server-error") Response (Maybe ByteString)
r
    else Either AuthenticationError Client
-> App (Either AuthenticationError Client)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthenticationError -> Either AuthenticationError Client
forall a b. a -> Either a b
Left AuthenticationError
ReAuthFailed)

-- | Calls 'Brig.API.Internal.getMLSClients'.
getLocalMLSClients :: Local UserId -> CipherSuiteTag -> App (Set ClientInfo)
getLocalMLSClients :: Local UserId -> CipherSuiteTag -> App (Set ClientInfo)
getLocalMLSClients Local UserId
lusr CipherSuiteTag
suite =
  IntraComponent
-> (Request -> Request) -> App (Response (Maybe ByteString))
call
    IntraComponent
Brig
    ( StdMethod -> Request -> Request
method StdMethod
GET
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Request -> Request
paths
          [ ByteString
"i",
            ByteString
"mls",
            ByteString
"clients",
            UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)
          ]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Request -> Request
queryItem
          ByteString
"ciphersuite"
          (CipherSuite -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader (CipherSuiteTag -> CipherSuite
tagCipherSuite CipherSuiteTag
suite))
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
expect2xx
    )
    App (Response (Maybe ByteString))
-> (Response (Maybe ByteString) -> App (Set ClientInfo))
-> App (Set ClientInfo)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LText -> Error)
-> Response (Maybe ByteString) -> App (Set ClientInfo)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, FromJSON a) =>
(LText -> e) -> Response (Maybe ByteString) -> m a
parseResponse (Status -> LText -> LText -> Error
mkError Status
status502 LText
"server-error")