{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- 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.Env where

import Cassandra
import Control.Lens hiding ((.=))
import Data.ByteString.Conversion (toByteString')
import Data.Id
import Data.Misc (Fingerprint, HttpsUrl, Rsa)
import Data.Range
import Data.Time.Clock.DiffTime (millisecondsToDiffTime)
import Galley.Aws qualified as Aws
import Galley.Options
import Galley.Options qualified as O
import Galley.Queue qualified as Q
import HTTP2.Client.Manager (Http2Manager)
import Imports
import Network.AMQP qualified as Q
import Network.HTTP.Client
import Network.HTTP.Client.OpenSSL
import OpenSSL.EVP.Digest
import OpenSSL.Session as Ssl
import Ssl.Util
import System.Logger
import Util.Options
import Wire.API.MLS.Keys
import Wire.API.Team.Member
import Wire.NotificationSubsystem.Interpreter

data DeleteItem = TeamItem TeamId UserId (Maybe ConnId)
  deriving (DeleteItem -> DeleteItem -> Bool
(DeleteItem -> DeleteItem -> Bool)
-> (DeleteItem -> DeleteItem -> Bool) -> Eq DeleteItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeleteItem -> DeleteItem -> Bool
== :: DeleteItem -> DeleteItem -> Bool
$c/= :: DeleteItem -> DeleteItem -> Bool
/= :: DeleteItem -> DeleteItem -> Bool
Eq, Eq DeleteItem
Eq DeleteItem =>
(DeleteItem -> DeleteItem -> Ordering)
-> (DeleteItem -> DeleteItem -> Bool)
-> (DeleteItem -> DeleteItem -> Bool)
-> (DeleteItem -> DeleteItem -> Bool)
-> (DeleteItem -> DeleteItem -> Bool)
-> (DeleteItem -> DeleteItem -> DeleteItem)
-> (DeleteItem -> DeleteItem -> DeleteItem)
-> Ord DeleteItem
DeleteItem -> DeleteItem -> Bool
DeleteItem -> DeleteItem -> Ordering
DeleteItem -> DeleteItem -> DeleteItem
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeleteItem -> DeleteItem -> Ordering
compare :: DeleteItem -> DeleteItem -> Ordering
$c< :: DeleteItem -> DeleteItem -> Bool
< :: DeleteItem -> DeleteItem -> Bool
$c<= :: DeleteItem -> DeleteItem -> Bool
<= :: DeleteItem -> DeleteItem -> Bool
$c> :: DeleteItem -> DeleteItem -> Bool
> :: DeleteItem -> DeleteItem -> Bool
$c>= :: DeleteItem -> DeleteItem -> Bool
>= :: DeleteItem -> DeleteItem -> Bool
$cmax :: DeleteItem -> DeleteItem -> DeleteItem
max :: DeleteItem -> DeleteItem -> DeleteItem
$cmin :: DeleteItem -> DeleteItem -> DeleteItem
min :: DeleteItem -> DeleteItem -> DeleteItem
Ord, Int -> DeleteItem -> ShowS
[DeleteItem] -> ShowS
DeleteItem -> String
(Int -> DeleteItem -> ShowS)
-> (DeleteItem -> String)
-> ([DeleteItem] -> ShowS)
-> Show DeleteItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeleteItem -> ShowS
showsPrec :: Int -> DeleteItem -> ShowS
$cshow :: DeleteItem -> String
show :: DeleteItem -> String
$cshowList :: [DeleteItem] -> ShowS
showList :: [DeleteItem] -> ShowS
Show)

-- | Main application environment.
data Env = Env
  { Env -> RequestId
_reqId :: RequestId,
    Env -> Opts
_options :: Opts,
    Env -> Logger
_applog :: Logger,
    Env -> Manager
_manager :: Manager,
    Env -> Http2Manager
_http2Manager :: Http2Manager,
    Env -> Maybe Endpoint
_federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time?
    Env -> Endpoint
_brig :: Endpoint, -- FUTUREWORK: see _federator
    Env -> ClientState
_cstate :: ClientState,
    Env -> Queue DeleteItem
_deleteQueue :: Q.Queue DeleteItem,
    Env -> ExtEnv
_extEnv :: ExtEnv,
    Env -> Maybe Env
_aEnv :: Maybe Aws.Env,
    Env -> Maybe (MLSKeysByPurpose MLSPrivateKeys)
_mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys),
    Env -> Maybe (MVar Channel)
_rabbitmqChannel :: Maybe (MVar Q.Channel),
    Env -> Either HttpsUrl (Map Text HttpsUrl)
_convCodeURI :: Either HttpsUrl (Map Text HttpsUrl)
  }

-- | Environment specific to the communication with external
-- service providers.
data ExtEnv = ExtEnv
  { ExtEnv -> (Manager, [Fingerprint Rsa] -> SSL -> IO ())
_extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ())
  }

makeLenses ''Env

makeLenses ''ExtEnv

-- TODO: somewhat duplicates Brig.App.initExtGetManager
initExtEnv :: IO ExtEnv
initExtEnv :: IO ExtEnv
initExtEnv = do
  SSLContext
ctx <- IO SSLContext
Ssl.context
  SSLContext -> VerificationMode -> IO ()
Ssl.contextSetVerificationMode SSLContext
ctx VerificationMode
Ssl.VerifyNone
  SSLContext -> SSLOption -> IO ()
Ssl.contextAddOption SSLContext
ctx SSLOption
SSL_OP_NO_SSLv2
  SSLContext -> SSLOption -> IO ()
Ssl.contextAddOption SSLContext
ctx SSLOption
SSL_OP_NO_SSLv3
  SSLContext -> SSLOption -> IO ()
Ssl.contextAddOption SSLContext
ctx SSLOption
SSL_OP_NO_TLSv1
  SSLContext -> String -> IO ()
Ssl.contextSetCiphers SSLContext
ctx String
rsaCiphers
  SSLContext -> IO ()
Ssl.contextSetDefaultVerifyPaths SSLContext
ctx
  Manager
mgr <-
    ManagerSettings -> IO Manager
newManager
      (IO SSLContext -> ManagerSettings
opensslManagerSettings (SSLContext -> IO SSLContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SSLContext
ctx))
        { managerResponseTimeout = responseTimeoutMicro 10000000,
          managerConnCount = 100
        }
  Just Digest
sha <- String -> IO (Maybe Digest)
getDigestByName String
"SHA256"
  ExtEnv -> IO ExtEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtEnv -> IO ExtEnv) -> ExtEnv -> IO ExtEnv
forall a b. (a -> b) -> a -> b
$ (Manager, [Fingerprint Rsa] -> SSL -> IO ()) -> ExtEnv
ExtEnv (Manager
mgr, Digest -> [Fingerprint Rsa] -> SSL -> IO ()
forall {a}. ToByteString a => Digest -> [a] -> SSL -> IO ()
mkVerify Digest
sha)
  where
    mkVerify :: Digest -> [a] -> SSL -> IO ()
mkVerify Digest
sha [a]
fprs =
      let pinset :: [ByteString]
pinset = (a -> ByteString) -> [a] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map a -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' [a]
fprs
       in Digest -> [ByteString] -> SSL -> IO ()
verifyRsaFingerprint Digest
sha [ByteString]
pinset

reqIdMsg :: RequestId -> Msg -> Msg
reqIdMsg :: RequestId -> Msg -> Msg
reqIdMsg = (ByteString
"request" .=) (ByteString -> Msg -> Msg)
-> (RequestId -> ByteString) -> RequestId -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> ByteString
unRequestId
{-# INLINE reqIdMsg #-}

currentFanoutLimit :: Opts -> Range 1 HardTruncationLimit Int32
currentFanoutLimit :: Opts -> Range 1 HardTruncationLimit Int32
currentFanoutLimit Opts
o = do
  let optFanoutLimit :: Int32
optFanoutLimit = Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32)
-> (Range 1 HardTruncationLimit Int32 -> Int32)
-> Range 1 HardTruncationLimit Int32
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range 1 HardTruncationLimit Int32 -> Int32
forall (n :: Nat) (m :: Nat) a. Range n m a -> a
fromRange (Range 1 HardTruncationLimit Int32 -> Int32)
-> Range 1 HardTruncationLimit Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Range 1 HardTruncationLimit Int32
-> Maybe (Range 1 HardTruncationLimit Int32)
-> Range 1 HardTruncationLimit Int32
forall a. a -> Maybe a -> a
fromMaybe Range 1 HardTruncationLimit Int32
defaultFanoutLimit (Opts
o Opts
-> Getting
     (Maybe (Range 1 HardTruncationLimit Int32))
     Opts
     (Maybe (Range 1 HardTruncationLimit Int32))
-> Maybe (Range 1 HardTruncationLimit Int32)
forall s a. s -> Getting a s a -> a
^. ((Settings
 -> Const (Maybe (Range 1 HardTruncationLimit Int32)) Settings)
-> Opts -> Const (Maybe (Range 1 HardTruncationLimit Int32)) Opts
Lens' Opts Settings
O.settings ((Settings
  -> Const (Maybe (Range 1 HardTruncationLimit Int32)) Settings)
 -> Opts -> Const (Maybe (Range 1 HardTruncationLimit Int32)) Opts)
-> ((Maybe (Range 1 HardTruncationLimit Int32)
     -> Const
          (Maybe (Range 1 HardTruncationLimit Int32))
          (Maybe (Range 1 HardTruncationLimit Int32)))
    -> Settings
    -> Const (Maybe (Range 1 HardTruncationLimit Int32)) Settings)
-> Getting
     (Maybe (Range 1 HardTruncationLimit Int32))
     Opts
     (Maybe (Range 1 HardTruncationLimit Int32))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Range 1 HardTruncationLimit Int32)
 -> Const
      (Maybe (Range 1 HardTruncationLimit Int32))
      (Maybe (Range 1 HardTruncationLimit Int32)))
-> Settings
-> Const (Maybe (Range 1 HardTruncationLimit Int32)) Settings
Lens' Settings (Maybe (Range 1 HardTruncationLimit Int32))
maxFanoutSize))
  let maxSize :: Int32
maxSize = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Opts
o Opts -> Getting Word32 Opts Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. ((Settings -> Const Word32 Settings) -> Opts -> Const Word32 Opts
Lens' Opts Settings
O.settings ((Settings -> Const Word32 Settings) -> Opts -> Const Word32 Opts)
-> ((Word32 -> Const Word32 Word32)
    -> Settings -> Const Word32 Settings)
-> Getting Word32 Opts Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Const Word32 Word32)
-> Settings -> Const Word32 Settings
Lens' Settings Word32
maxTeamSize))
  Int32 -> Range 1 HardTruncationLimit Int32
forall a (n :: Nat) (m :: Nat).
(Show a, KnownNat n, KnownNat m, Within a n m) =>
a -> Range n m a
unsafeRange (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
min Int32
maxSize Int32
optFanoutLimit)

notificationSubssystemConfig :: Env -> NotificationSubsystemConfig
notificationSubssystemConfig :: Env -> NotificationSubsystemConfig
notificationSubssystemConfig Env
env =
  NotificationSubsystemConfig
    { $sel:chunkSize:NotificationSubsystemConfig :: Nat
chunkSize = Nat
defaultChunkSize,
      $sel:fanoutLimit:NotificationSubsystemConfig :: Range 1 HardTruncationLimit Int32
fanoutLimit = Opts -> Range 1 HardTruncationLimit Int32
currentFanoutLimit Env
env._options,
      $sel:slowPushDelay:NotificationSubsystemConfig :: DiffTime
slowPushDelay =
        DiffTime -> (Int -> DiffTime) -> Maybe Int -> DiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          DiffTime
defaultSlowPushDelay
          (Integer -> DiffTime
millisecondsToDiffTime (Integer -> DiffTime) -> (Int -> Integer) -> Int -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger)
          (Env
env Env -> Getting (Maybe Int) Env (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. (Opts -> Const (Maybe Int) Opts) -> Env -> Const (Maybe Int) Env
Lens' Env Opts
options ((Opts -> Const (Maybe Int) Opts) -> Env -> Const (Maybe Int) Env)
-> ((Maybe Int -> Const (Maybe Int) (Maybe Int))
    -> Opts -> Const (Maybe Int) Opts)
-> Getting (Maybe Int) Env (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> Const (Maybe Int) Settings)
-> Opts -> Const (Maybe Int) Opts
Lens' Opts Settings
O.settings ((Settings -> Const (Maybe Int) Settings)
 -> Opts -> Const (Maybe Int) Opts)
-> ((Maybe Int -> Const (Maybe Int) (Maybe Int))
    -> Settings -> Const (Maybe Int) Settings)
-> (Maybe Int -> Const (Maybe Int) (Maybe Int))
-> Opts
-> Const (Maybe Int) Opts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int -> Const (Maybe Int) (Maybe Int))
-> Settings -> Const (Maybe Int) Settings
Lens' Settings (Maybe Int)
deleteConvThrottleMillis),
      $sel:requestId:NotificationSubsystemConfig :: RequestId
requestId = Env
env Env -> Getting RequestId Env RequestId -> RequestId
forall s a. s -> Getting a s a -> a
^. Getting RequestId Env RequestId
Lens' Env RequestId
reqId
    }