{-# 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 (Eq, Ord)
instance Show SPKIHash where
show (SPKIHash bs) = "SPKIHash " <> T.unpack (T.decodeLatin1 (Base64.encode 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 requiredHash swissnum =
(mkManagerSettings (gbsTLSSettings requiredHash) sockSettings)
{ managerModifyRequest = addAuthorization swissnum
}
where
sockSettings = 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 requiredHash =
TLSSettings
( ClientParams
{ clientUseMaxFragmentLength = Nothing
, clientServerIdentification = ("", "")
, clientUseServerNameIndication = True
, clientWantSessionResume = Nothing
, clientShared = def
, clientHooks =
def
{ onServerCertificate = validateGBSCertificate requiredHash
}
, clientSupported = def{supportedCiphers = ciphersuite_default}
, clientDebug = def
, clientEarlyData = 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 _ _ _ _ (CertificateChain []) = pure [EmptyChain]
validateGBSCertificate requiredSPKIFingerprint _ _ _ (CertificateChain [signedExactCert]) =
-- Nothing is valid unless the signature on the certificate is valid
-- so do that first.
case verifySignedSignature signedExactCert pubKey of
SignatureFailed failure -> pure [InvalidSignature failure]
SignaturePass -> do
-- The certificates SubjectPublicKeyInfo must match the hash we
-- expect, too.
if spkiFingerprint cert == requiredSPKIFingerprint
then pure []
else do
pure [InvalidSignature SignaturePubkeyMismatch]
where
pubKey = certPubKey cert
cert = signedObject . getSigned $ signedExactCert
validateGBSCertificate _ _ _ _ _ = pure [AuthorityTooDeep]
sha256 :: B.ByteString -> B.ByteString
sha256 = convert . (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 = certPubKey
{- | Construct the bytes which can be hashed to produce the SPKI Fingerprint
for the given Certificate.
-}
spkiBytes :: Certificate -> B.ByteString
spkiBytes = encodeASN1' DER . flip toASN1 [] . spki
-- | Compute the SPKI Fingerprint (RFC 7469) for the given Certificate.
spkiFingerprint :: Certificate -> SPKIHash
spkiFingerprint = SPKIHash . sha256 . 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 swissnum req =
pure
req
{ requestHeaders = addHeader authz . requestHeaders $ req
}
where
enc = Base64.encode . T.encodeUtf8
authz = ("Authorization", "Tahoe-LAFS " <> enc swissnum)
addHeader :: Header -> [Header] -> [Header]
addHeader (name, value) [] = [(name, value)]
addHeader (name, value) (o@(name', _) : xs)
| name == name' = o : xs
| otherwise = o : addHeader (name, value) xs
addAuthorizationPrint :: T.Text -> Request -> IO Request
addAuthorizationPrint swissnum req = do
p "Before"
print req
p "--------"
r <- addAuthorization swissnum req
p "After"
print r
p "--------"
pure r
where
p = print :: String -> IO ()