content: -- 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 Federator.Validation
    ( ensureCanFederateWith,
      parseDomain,
      decodeCertificate,
      validateDomain,
      validateDomainName,
      ValidationError (..),
    )
  where
  
  import Data.ByteString.Char8 qualified as B8
  import Data.ByteString.Conversion
  import Data.Domain
  import Data.List.NonEmpty (NonEmpty)
  import Data.PEM qualified as X509
  import Data.Text qualified as Text
  import Data.Text.Encoding qualified as Text
  import Data.Text.Encoding.Error qualified as Text
  import Data.Text.Lazy qualified as LText
  import Data.X509 qualified as X509
  import Data.X509.Validation qualified as X509
  import Federator.Discovery
  import Federator.Error
  import Imports
  import Network.HTTP.Types qualified as HTTP
  import Network.Wai.Utilities.Error qualified as Wai
  import Polysemy
  import Polysemy.Error
  import Polysemy.Input
  import System.Logger qualified as Log
  import Wire.API.Routes.FederationDomainConfig
  import Wire.Network.DNS.SRV (SrvTarget (..))
  
  data ValidationError
    = NoClientCertificate
    | CertificateParseError Text
    | DomainParseError Text
    | AuthenticationFailure (NonEmpty [X509.FailedReason])
    | FederationDenied Domain
    deriving (Eq, Show, Typeable)
  
  instance Exception ValidationError
  
  instance AsWai ValidationError where
    errorLogLevel (FederationDenied _) = Log.Warn
    errorLogLevel _ = Log.Error
    toWai err =
      Wai.mkError (validationErrorStatus err) (validationErrorLabel err)
        . LText.fromStrict
        $ validationErrorDescription err
  
  validationErrorDescription :: ValidationError -> Text
  validationErrorDescription NoClientCertificate = "no client certificate provided"
  validationErrorDescription (CertificateParseError reason) =
    "certificate parse failure: " <> reason
  validationErrorDescription (DomainParseError domain) =
    "domain parse failure for [" <> domain <> "]"
  validationErrorDescription (AuthenticationFailure errs) =
    "none of the domain names match the certificate, errors: "
      <> Text.pack (show (toList errs))
  validationErrorDescription (FederationDenied domain) =
    "origin domain [" <> domainText domain <> "] not in the federation allow list"
  
  validationErrorLabel :: ValidationError -> LText
  validationErrorLabel NoClientCertificate = "no-client-certificate"
  validationErrorLabel (CertificateParseError _) = "certificate-parse-error"
  validationErrorLabel (DomainParseError _) = "domain-parse-error"
  validationErrorLabel (AuthenticationFailure _) = "authentication-failure"
  validationErrorLabel (FederationDenied _) = "federation-denied"
  
  validationErrorStatus :: ValidationError -> HTTP.Status
  -- the FederationDenied case is handled differently, because it may be caused
  -- by wrong input in the original request, so we let this error propagate to the
  -- client
  validationErrorStatus (FederationDenied _) = HTTP.status400
  validationErrorStatus _ = HTTP.status403
  
  -- | Validates an already-parsed domain against the allow list (stored in
  -- `brig.federation_remotes`, cached in `Env`).
  ensureCanFederateWith ::
    ( Member (Input FederationDomainConfigs) r,
      Member (Error ValidationError) r
    ) =>
    Domain ->
    Sem r ()
  ensureCanFederateWith targetDomain = do
    FederationDomainConfigs strategy domains _ <- input
    case strategy of
      AllowNone -> throw (FederationDenied targetDomain)
      AllowAll -> pure ()
      AllowDynamic -> do
        unless (targetDomain `elem` fmap domain domains) $
          throw (FederationDenied targetDomain)
  
  decodeCertificate ::
    ByteString ->
    Either String X509.Certificate
  decodeCertificate =
    (pure . X509.getCertificate)
      <=< X509.decodeSignedCertificate
      <=< (pure . X509.pemContent)
      <=< expectOne "certificate"
      <=< X509.pemParseBS
    where
      expectOne :: String -> [a] -> Either String a
      expectOne label [] = Left $ "no " <> label <> " found"
      expectOne _ [x] = pure x
      expectOne label _ = Left $ "found multiple " <> label <> "s"
  
  parseDomain :: (Member (Error ValidationError) r) => ByteString -> Sem r Domain
  parseDomain domain =
    note (DomainParseError (Text.decodeUtf8With Text.lenientDecode domain)) $
      fromByteString domain
  
  -- | Validates an unknown domain string against the allow list using the
  -- federator startup configuration and checks that it matches the names reported
  -- by the client certificate
  validateDomain ::
    ( Member (Input FederationDomainConfigs) r,
      Member (Error ValidationError) r,
      Member (Error DiscoveryFailure) r,
      Member DiscoverFederator r
    ) =>
    X509.Certificate ->
    Domain ->
    Sem r Domain
  validateDomain certificate targetDomain = do
    ensureCanFederateWith targetDomain
  
    -- run discovery to find the hostname of the client federator
    hostnames <- srvTargetDomain <$$> discoverAllFederatorsWithError targetDomain
    let validationErrors = (\h -> validateDomainName (B8.unpack h) certificate) <$> hostnames
    unless (any null validationErrors) $
      throw $
        AuthenticationFailure validationErrors
  
    pure targetDomain
  
  -- | Match a hostname against the domain names of a certificate.
  --
  -- We strip the trailing dot from the domain, as the certificate is not
  -- expected to have the trailing dot.
  validateDomainName :: String -> X509.Certificate -> [X509.FailedReason]
  validateDomainName hostname =
    X509.hookValidateName X509.defaultHooks (stripDot hostname)
    where
      stripDot h
        | "." `isSuffixOf` h = take (length h - 1) h
        | otherwise = h
  