-- 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.External.LegalHoldService
  ( -- * api
    checkLegalHoldServiceStatus,
    requestNewDevice,
    confirmLegalHold,
    removeLegalHold,

    -- * helpers
    validateServiceKey,
  )
where

import Bilge qualified
import Bilge.Response
import Brig.Types.Team.LegalHold
import Data.Aeson
import Data.ByteString.Conversion.To
import Data.ByteString.Lazy.Char8 qualified as LC8
import Data.Id
import Data.Misc
import Galley.Effects.LegalHoldStore as LegalHoldData
import Galley.External.LegalHoldService.Types
import Imports
import Network.HTTP.Client qualified as Http
import Network.HTTP.Types
import Polysemy
import Polysemy.TinyLog qualified as P
import System.Logger.Class qualified as Log
import Wire.API.Error (ErrorS, throwS)
import Wire.API.Error.Galley
import Wire.API.Team.LegalHold.External

----------------------------------------------------------------------
-- api

-- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong.
checkLegalHoldServiceStatus ::
  ( Member (ErrorS 'LegalHoldServiceBadResponse) r,
    Member LegalHoldStore r,
    Member P.TinyLog r
  ) =>
  Fingerprint Rsa ->
  HttpsUrl ->
  Sem r ()
checkLegalHoldServiceStatus :: forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceBadResponse) r,
 Member LegalHoldStore r, Member TinyLog r) =>
Fingerprint Rsa -> HttpsUrl -> Sem r ()
checkLegalHoldServiceStatus Fingerprint Rsa
fpr HttpsUrl
url = do
  Response ByteString
resp <- Fingerprint Rsa
-> HttpsUrl -> (Request -> Request) -> Sem r (Response ByteString)
forall (r :: EffectRow).
Member LegalHoldStore r =>
Fingerprint Rsa
-> HttpsUrl -> (Request -> Request) -> Sem r (Response ByteString)
makeVerifiedRequestFreshManager Fingerprint Rsa
fpr HttpsUrl
url Request -> Request
reqBuilder
  if Response ByteString -> Int
forall a. Response a -> Int
Bilge.statusCode Response ByteString
resp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400
    then () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.info ((Msg -> Msg) -> Sem r ())
-> (String -> Msg -> Msg) -> String -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Response ByteString -> String
forall a. Show a => Response a -> String
showResponse Response ByteString
resp
      forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'LegalHoldServiceBadResponse
  where
    reqBuilder :: Http.Request -> Http.Request
    reqBuilder :: Request -> Request
reqBuilder =
      [ByteString] -> Request -> Request
Bilge.paths [ByteString
"status"]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
Bilge.method StdMethod
GET
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.expect2xx

-- | @POST /initiate@.
requestNewDevice ::
  ( Member (ErrorS 'LegalHoldServiceBadResponse) r,
    Member (ErrorS 'LegalHoldServiceNotRegistered) r,
    Member LegalHoldStore r,
    Member P.TinyLog r
  ) =>
  TeamId ->
  UserId ->
  Sem r NewLegalHoldClient
requestNewDevice :: forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceBadResponse) r,
 Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r, Member TinyLog r) =>
TeamId -> UserId -> Sem r NewLegalHoldClient
requestNewDevice TeamId
tid UserId
uid = do
  Response ByteString
resp <- TeamId -> (Request -> Request) -> Sem r (Response ByteString)
forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
TeamId -> (Request -> Request) -> Sem r (Response ByteString)
makeLegalHoldServiceRequest TeamId
tid Request -> Request
reqParams
  case ByteString -> Either String NewLegalHoldClient
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) of
    Left String
e -> do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.info ((Msg -> Msg) -> Sem r ())
-> (String -> Msg -> Msg) -> String -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String
"Error decoding NewLegalHoldClient: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
      forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'LegalHoldServiceBadResponse
    Right NewLegalHoldClient
client -> NewLegalHoldClient -> Sem r NewLegalHoldClient
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewLegalHoldClient
client
  where
    reqParams :: Request -> Request
reqParams =
      [ByteString] -> Request -> Request
Bilge.paths [ByteString
"initiate"]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestNewLegalHoldClient -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
Bilge.json (UserId -> TeamId -> RequestNewLegalHoldClient
RequestNewLegalHoldClient UserId
uid TeamId
tid)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
Bilge.method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.acceptJson
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.expect2xx

-- | @POST /confirm@
-- Confirm that a device has been linked to a user and provide an authorization token
confirmLegalHold ::
  ( Member (ErrorS 'LegalHoldServiceNotRegistered) r,
    Member LegalHoldStore r
  ) =>
  ClientId ->
  TeamId ->
  UserId ->
  -- | TODO: Replace with 'LegalHold' token type
  OpaqueAuthToken ->
  Sem r ()
confirmLegalHold :: forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
ClientId -> TeamId -> UserId -> OpaqueAuthToken -> Sem r ()
confirmLegalHold ClientId
clientId TeamId
tid UserId
uid OpaqueAuthToken
legalHoldAuthToken = do
  Sem r (Response ByteString) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Response ByteString) -> Sem r ())
-> Sem r (Response ByteString) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TeamId -> (Request -> Request) -> Sem r (Response ByteString)
forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
TeamId -> (Request -> Request) -> Sem r (Response ByteString)
makeLegalHoldServiceRequest TeamId
tid Request -> Request
reqParams
  where
    reqParams :: Request -> Request
reqParams =
      [ByteString] -> Request -> Request
Bilge.paths [ByteString
"confirm"]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LegalHoldServiceConfirm -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
Bilge.json (ClientId -> UserId -> TeamId -> Text -> LegalHoldServiceConfirm
LegalHoldServiceConfirm ClientId
clientId UserId
uid TeamId
tid (OpaqueAuthToken -> Text
opaqueAuthTokenToText OpaqueAuthToken
legalHoldAuthToken))
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
Bilge.method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.acceptJson
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.expect2xx

-- | @POST /remove@
-- Inform the LegalHold Service that a user's legalhold has been disabled.
removeLegalHold ::
  ( Member (ErrorS 'LegalHoldServiceNotRegistered) r,
    Member LegalHoldStore r
  ) =>
  TeamId ->
  UserId ->
  Sem r ()
removeLegalHold :: forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
TeamId -> UserId -> Sem r ()
removeLegalHold TeamId
tid UserId
uid = do
  Sem r (Response ByteString) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Response ByteString) -> Sem r ())
-> Sem r (Response ByteString) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TeamId -> (Request -> Request) -> Sem r (Response ByteString)
forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
TeamId -> (Request -> Request) -> Sem r (Response ByteString)
makeLegalHoldServiceRequest TeamId
tid Request -> Request
reqParams
  where
    reqParams :: Request -> Request
reqParams =
      [ByteString] -> Request -> Request
Bilge.paths [ByteString
"remove"]
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LegalHoldServiceRemove -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
Bilge.json (UserId -> TeamId -> LegalHoldServiceRemove
LegalHoldServiceRemove UserId
uid TeamId
tid)
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
Bilge.method StdMethod
POST
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.acceptJson
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
Bilge.expect2xx

----------------------------------------------------------------------
-- helpers

-- | Lookup legal hold service settings for a team and make a request to the service.  Pins
-- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can
-- authenticate the request.
makeLegalHoldServiceRequest ::
  ( Member (ErrorS 'LegalHoldServiceNotRegistered) r,
    Member LegalHoldStore r
  ) =>
  TeamId ->
  (Http.Request -> Http.Request) ->
  Sem r (Http.Response LC8.ByteString)
makeLegalHoldServiceRequest :: forall (r :: EffectRow).
(Member (ErrorS 'LegalHoldServiceNotRegistered) r,
 Member LegalHoldStore r) =>
TeamId -> (Request -> Request) -> Sem r (Response ByteString)
makeLegalHoldServiceRequest TeamId
tid Request -> Request
reqBuilder = do
  Maybe LegalHoldService
maybeLHSettings <- TeamId -> Sem r (Maybe LegalHoldService)
forall (r :: EffectRow).
Member LegalHoldStore r =>
TeamId -> Sem r (Maybe LegalHoldService)
LegalHoldData.getSettings TeamId
tid
  LegalHoldService
lhSettings <- case Maybe LegalHoldService
maybeLHSettings of
    Maybe LegalHoldService
Nothing -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'LegalHoldServiceNotRegistered
    Just LegalHoldService
lhSettings -> LegalHoldService -> Sem r LegalHoldService
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LegalHoldService
lhSettings
  let LegalHoldService
        { $sel:legalHoldServiceUrl:LegalHoldService :: LegalHoldService -> HttpsUrl
legalHoldServiceUrl = HttpsUrl
baseUrl,
          $sel:legalHoldServiceFingerprint:LegalHoldService :: LegalHoldService -> Fingerprint Rsa
legalHoldServiceFingerprint = Fingerprint Rsa
fpr,
          $sel:legalHoldServiceToken:LegalHoldService :: LegalHoldService -> ServiceToken
legalHoldServiceToken = ServiceToken
serviceToken
        } = LegalHoldService
lhSettings
  Fingerprint Rsa
-> HttpsUrl -> (Request -> Request) -> Sem r (Response ByteString)
forall (r :: EffectRow).
Member LegalHoldStore r =>
Fingerprint Rsa
-> HttpsUrl -> (Request -> Request) -> Sem r (Response ByteString)
makeVerifiedRequest Fingerprint Rsa
fpr HttpsUrl
baseUrl ((Request -> Request) -> Sem r (Response ByteString))
-> (Request -> Request) -> Sem r (Response ByteString)
forall a b. (a -> b) -> a -> b
$ ServiceToken -> Request -> Request
mkReqBuilder ServiceToken
serviceToken
  where
    mkReqBuilder :: ServiceToken -> Request -> Request
mkReqBuilder ServiceToken
token =
      Request -> Request
reqBuilder
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> Request -> Request
Bilge.header HeaderName
"Authorization" (ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ServiceToken -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' ServiceToken
token)