{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}

{- | Implement the correct HTTPS client configuration for using Great Black
 Swamp.  This is necessary and correct for authenticating Great Black
 Swamp's self-authenticating URLs.
-}
module TahoeLAFS.Internal.Client where

import qualified "base64-bytestring" Data.ByteString.Base64 as Base64

import Crypto.Hash (Digest, hash)
import Crypto.Hash.Algorithms (SHA256)
import Data.ASN1.BinaryEncoding (DER (DER))
import Data.ASN1.Encoding (encodeASN1')
import Data.ASN1.Types (ASN1Object (toASN1))
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import Data.Default.Class (Default (def))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.X509 (
    Certificate (certPubKey),
    CertificateChain (CertificateChain),
    PubKey,
    Signed (signedObject),
    SignedExact (getSigned),
 )
import Data.X509.CertificateStore (CertificateStore)
import Data.X509.Validation (
    FailedReason (AuthorityTooDeep, EmptyChain, InvalidSignature),
    ServiceID,
    SignatureFailure (SignaturePubkeyMismatch),
    SignatureVerification (SignatureFailed, SignaturePass),
    verifySignedSignature,
 )
import Network.Connection (TLSSettings (..))
import Network.HTTP.Client (ManagerSettings, Request (requestHeaders), managerModifyRequest)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types (Header)
import Network.TLS (
    ClientHooks (onServerCertificate),
    ClientParams (..),
    Supported (..),
    ValidationCache,
 )
import Network.TLS.Extra.Cipher (ciphersuite_default)

newtype SPKIHash = SPKIHash B.ByteString deriving (SPKIHash -> SPKIHash -> Bool
(SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool) -> Eq SPKIHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SPKIHash -> SPKIHash -> Bool
$c/= :: SPKIHash -> SPKIHash -> Bool
== :: SPKIHash -> SPKIHash -> Bool
$c== :: SPKIHash -> SPKIHash -> Bool
Eq, Eq SPKIHash
Eq SPKIHash
-> (SPKIHash -> SPKIHash -> Ordering)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> SPKIHash)
-> (SPKIHash -> SPKIHash -> SPKIHash)
-> Ord SPKIHash
SPKIHash -> SPKIHash -> Bool
SPKIHash -> SPKIHash -> Ordering
SPKIHash -> SPKIHash -> SPKIHash
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
min :: SPKIHash -> SPKIHash -> SPKIHash
$cmin :: SPKIHash -> SPKIHash -> SPKIHash
max :: SPKIHash -> SPKIHash -> SPKIHash
$cmax :: SPKIHash -> SPKIHash -> SPKIHash
>= :: SPKIHash -> SPKIHash -> Bool
$c>= :: SPKIHash -> SPKIHash -> Bool
> :: SPKIHash -> SPKIHash -> Bool
$c> :: SPKIHash -> SPKIHash -> Bool
<= :: SPKIHash -> SPKIHash -> Bool
$c<= :: SPKIHash -> SPKIHash -> Bool
< :: SPKIHash -> SPKIHash -> Bool
$c< :: SPKIHash -> SPKIHash -> Bool
compare :: SPKIHash -> SPKIHash -> Ordering
$ccompare :: SPKIHash -> SPKIHash -> Ordering
$cp1Ord :: Eq SPKIHash
Ord)

instance Show SPKIHash where
    show :: SPKIHash -> String
show (SPKIHash ByteString
bs) = String
"SPKIHash " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (ByteString -> Text
T.decodeLatin1 (ByteString -> ByteString
Base64.encode ByteString
bs))

{- | Create a ManagerSettings suitable for use with Great Black Swamp client
 requests.
-}
mkGBSManagerSettings ::
    -- | The SPKI hash of the certificate of the storage service to access.
    SPKIHash ->
    -- | The secret capability identifying the storage service to access.
    T.Text ->
    -- | The settings.
    ManagerSettings
mkGBSManagerSettings :: SPKIHash -> Text -> ManagerSettings
mkGBSManagerSettings SPKIHash
requiredHash Text
swissnum =
    (TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings (SPKIHash -> TLSSettings
gbsTLSSettings SPKIHash
requiredHash) Maybe SockSettings
forall a. Maybe a
sockSettings)
        { managerModifyRequest :: Request -> IO Request
managerModifyRequest = Text -> Request -> IO Request
forall (f :: * -> *). Applicative f => Text -> Request -> f Request
addAuthorization Text
swissnum
        }
  where
    sockSettings :: Maybe a
sockSettings = Maybe a
forall a. Maybe a
Nothing

{- | The TLSSettings suitable for use with Great Black Swamp client requests.
 These ensure we can authenticate the server before using it.
-}
gbsTLSSettings :: SPKIHash -> TLSSettings
gbsTLSSettings :: SPKIHash -> TLSSettings
gbsTLSSettings SPKIHash
requiredHash =
    ClientParams -> TLSSettings
TLSSettings
        ( ClientParams :: Maybe MaxFragmentEnum
-> (String, ByteString)
-> Bool
-> Maybe (ByteString, SessionData)
-> Shared
-> ClientHooks
-> Supported
-> DebugParams
-> Maybe ByteString
-> ClientParams
ClientParams
            { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientUseMaxFragmentLength = Maybe MaxFragmentEnum
forall a. Maybe a
Nothing
            , clientServerIdentification :: (String, ByteString)
clientServerIdentification = (String
"", ByteString
"")
            , clientUseServerNameIndication :: Bool
clientUseServerNameIndication = Bool
True
            , clientWantSessionResume :: Maybe (ByteString, SessionData)
clientWantSessionResume = Maybe (ByteString, SessionData)
forall a. Maybe a
Nothing
            , clientShared :: Shared
clientShared = Shared
forall a. Default a => a
def
            , clientHooks :: ClientHooks
clientHooks =
                ClientHooks
forall a. Default a => a
def
                    { onServerCertificate :: OnServerCertificate
onServerCertificate = SPKIHash -> OnServerCertificate
validateGBSCertificate SPKIHash
requiredHash
                    }
            , clientSupported :: Supported
clientSupported = Supported
forall a. Default a => a
def{supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_default}
            , clientDebug :: DebugParams
clientDebug = DebugParams
forall a. Default a => a
def
            , clientEarlyData :: Maybe ByteString
clientEarlyData = Maybe ByteString
forall a. Maybe a
Nothing
            }
        )

{- | Determine the validity of an x509 certificate presented during a TLS
 handshake for a GBS connection.

 The certificate is considered valid if its signature can be validated and
 the sha256 hash of its SPKI fields match the expected value.

 If not exactly one certificate is presented then validation fails.
-}
validateGBSCertificate :: SPKIHash -> CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]
validateGBSCertificate :: SPKIHash -> OnServerCertificate
validateGBSCertificate SPKIHash
_ CertificateStore
_ ValidationCache
_ (String, ByteString)
_ (CertificateChain []) = [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
EmptyChain]
validateGBSCertificate SPKIHash
requiredSPKIFingerprint CertificateStore
_ ValidationCache
_ (String, ByteString)
_ (CertificateChain [SignedExact Certificate
signedExactCert]) =
    -- Nothing is valid unless the signature on the certificate is valid
    -- so do that first.
    case SignedExact Certificate -> PubKey -> SignatureVerification
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedExact Certificate
signedExactCert PubKey
pubKey of
        SignatureFailed SignatureFailure
failure -> [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
failure]
        SignatureVerification
SignaturePass -> do
            -- The certificates SubjectPublicKeyInfo must match the hash we
            -- expect, too.
            if Certificate -> SPKIHash
spkiFingerprint Certificate
cert SPKIHash -> SPKIHash -> Bool
forall a. Eq a => a -> a -> Bool
== SPKIHash
requiredSPKIFingerprint
                then [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                else do
                    [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
SignaturePubkeyMismatch]
  where
    pubKey :: PubKey
pubKey = Certificate -> PubKey
certPubKey Certificate
cert
    cert :: Certificate
cert = Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
signedObject (Signed Certificate -> Certificate)
-> (SignedExact Certificate -> Signed Certificate)
-> SignedExact Certificate
-> Certificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
getSigned (SignedExact Certificate -> Certificate)
-> SignedExact Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate
signedExactCert
validateGBSCertificate SPKIHash
_ CertificateStore
_ ValidationCache
_ (String, ByteString)
_ CertificateChain
_ = [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
AuthorityTooDeep]

sha256 :: B.ByteString -> B.ByteString
sha256 :: ByteString -> ByteString
sha256 = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash :: B.ByteString -> Digest SHA256)

{- | Extract the SubjectPublicKeyInfo from a Certificate.

 The PubKey type contains all of the values related to the
 SubjectPublicKeyInfo and serializes correctly for this type so we just
 extract that.
-}
spki :: Certificate -> PubKey
spki :: Certificate -> PubKey
spki = Certificate -> PubKey
certPubKey

{- | Construct the bytes which can be hashed to produce the SPKI Fingerprint
 for the given Certificate.
-}
spkiBytes :: Certificate -> B.ByteString
spkiBytes :: Certificate -> ByteString
spkiBytes = DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER ([ASN1] -> ByteString)
-> (Certificate -> [ASN1]) -> Certificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PubKey -> [ASN1] -> [ASN1]) -> [ASN1] -> PubKey -> [ASN1]
forall a b c. (a -> b -> c) -> b -> a -> c
flip PubKey -> [ASN1] -> [ASN1]
forall a. ASN1Object a => a -> [ASN1] -> [ASN1]
toASN1 [] (PubKey -> [ASN1])
-> (Certificate -> PubKey) -> Certificate -> [ASN1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> PubKey
spki

-- | Compute the SPKI Fingerprint (RFC 7469) for the given Certificate.
spkiFingerprint :: Certificate -> SPKIHash
spkiFingerprint :: Certificate -> SPKIHash
spkiFingerprint = ByteString -> SPKIHash
SPKIHash (ByteString -> SPKIHash)
-> (Certificate -> ByteString) -> Certificate -> SPKIHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
sha256 (ByteString -> ByteString)
-> (Certificate -> ByteString) -> Certificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> ByteString
spkiBytes

-- Add the necessary authorization header.  Since this is used with
-- `managerModifyRequest`, it may be called more than once per request so it
-- needs to take care not to double up headers.
-- https://github.com/snoyberg/http-client/issues/350
addAuthorization :: Applicative f => T.Text -> Request -> f Request
addAuthorization :: Text -> Request -> f Request
addAuthorization Text
swissnum Request
req =
    Request -> f Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Request
req
            { requestHeaders :: RequestHeaders
requestHeaders = Header -> RequestHeaders -> RequestHeaders
addHeader Header
authz (RequestHeaders -> RequestHeaders)
-> (Request -> RequestHeaders) -> Request -> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RequestHeaders
requestHeaders (Request -> RequestHeaders) -> Request -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request
req
            }
  where
    enc :: Text -> ByteString
enc = ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
    authz :: Header
authz = (HeaderName
"Authorization", ByteString
"Tahoe-LAFS " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
enc Text
swissnum)

    addHeader :: Header -> [Header] -> [Header]
    addHeader :: Header -> RequestHeaders -> RequestHeaders
addHeader (HeaderName
name, ByteString
value) [] = [(HeaderName
name, ByteString
value)]
    addHeader (HeaderName
name, ByteString
value) (o :: Header
o@(HeaderName
name', ByteString
_) : RequestHeaders
xs)
        | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name' = Header
o Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
xs
        | Bool
otherwise = Header
o Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Header -> RequestHeaders -> RequestHeaders
addHeader (HeaderName
name, ByteString
value) RequestHeaders
xs

addAuthorizationPrint :: T.Text -> Request -> IO Request
addAuthorizationPrint :: Text -> Request -> IO Request
addAuthorizationPrint Text
swissnum Request
req = do
    String -> IO ()
p String
"Before"
    Request -> IO ()
forall a. Show a => a -> IO ()
print Request
req
    String -> IO ()
p String
"--------"
    Request
r <- Text -> Request -> IO Request
forall (f :: * -> *). Applicative f => Text -> Request -> f Request
addAuthorization Text
swissnum Request
req
    String -> IO ()
p String
"After"
    Request -> IO ()
forall a. Show a => a -> IO ()
print Request
r
    String -> IO ()
p String
"--------"
    Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r
  where
    p :: String -> IO ()
p = String -> IO ()
forall a. Show a => a -> IO ()
print :: String -> IO ()