diff --git a/ChangeLog.md b/ChangeLog.md
index a9eb21b10669bc1ad8681521111012ba23c40e9d..c0c0bd621c150e9d111c3099bdf67bb5c3b242cf 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,9 @@
# Changelog for tahoe-great-black-swamp
+## X.Y.Z
+
+* ``TahoeLAFS.Storage.Client.runGBS`` is a new high-level API for performing an interaction with a GBS server.
+
## 0.3.0.1
* Package metadata improvements.
diff --git a/README.rst b/README.rst
index d6225c39c30928e2fafb8ac781d4a76653a871d3..0a126dbb6c8dce31f47a2c5ba4a12e450cbe34f9 100644
--- a/README.rst
+++ b/README.rst
@@ -21,6 +21,31 @@ Run Unit Tests
stack test
+Write a Client
+--------------
+
+Here's a client program that shows two things:
+
+* a server's version response
+* all of the share numbers it claims to hold for a particular storage index
+
+The server details are encoded in the NURL and the storage index is hard-coded in another string.
+
+::
+
+ import Control.Monad.IO.Class (liftIO)
+ import TahoeLAFS.Storage.Client (runGBS, version, getImmutableShareNumbers, parseNURL)
+
+ main :: IO ()
+ main =
+ let
+ Just nURL = parseNURL "pb://..."
+ storageIndex = "aaabbbcccdddeeefffggg"
+ in
+ runGBS nURL $ do
+ version >>= liftIO . print
+ getImmutableShareNumbers storageIndex >>= liftIO . print
+
Generate GBS Clients
--------------------
diff --git a/Setup.hs b/Setup.hs
index 9a994af677b0dfd41b4e3b76b3e7e604003d64e1..e8ef27dbba9992f80d9271a60892aadc63c9ef36 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
diff --git a/client-test/Main.hs b/client-test/Main.hs
index 643afa4b29284634ded287a12359238d950fca64..dff9a2712ed3c84af8ea54c6e0d59a90bdcde338 100644
--- a/client-test/Main.hs
+++ b/client-test/Main.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{- | Demonstrate the use of some GBS client APIs.
@@ -11,112 +10,46 @@
module Main where
import Data.ByteString.Base32 (encodeBase32Unpadded)
-
-import qualified Data.ByteString.Base64 as Base64
-
-import Data.Text
-import Data.Text.Encoding (encodeUtf8)
-
-import Network.Connection (TLSSettings (TLSSettingsSimple))
-import Network.HTTP.Client (
- ManagerSettings (managerModifyRequest),
- Request (requestHeaders),
- )
-import Network.HTTP.Client.TLS (
- mkManagerSettings,
- newTlsManagerWith,
- )
-import Network.HTTP.Types ()
-import Network.URI (
- URI (URI, uriAuthority, uriPath),
- URIAuth (URIAuth, uriPort, uriRegName),
- parseURI,
- )
-import Servant.Client (
- BaseUrl (BaseUrl),
- ClientError,
- ClientM,
- Scheme (Https),
- mkClientEnv,
- runClientM,
- )
+import qualified Data.Text as T
import System.Environment (getArgs)
import Tahoe.CHK.Capability (
CHK (CHKReader),
Reader (Reader, verifier),
- Verifier (
- Verifier,
- fingerprint,
- required,
- size,
- storageIndex,
- total
- ),
+ Verifier (Verifier, storageIndex),
pCapability,
)
-import TahoeLAFS.Storage.Client
-import Text.Megaparsec
-
-import TahoeLAFS.Storage.API
+import TahoeLAFS.Storage.API (ShareNumber (..))
+import TahoeLAFS.Storage.Client (
+ getImmutableShareNumbers,
+ parseNURL,
+ readImmutableShare,
+ runGBS,
+ version,
+ )
+import Text.Megaparsec (parse)
main :: IO ()
main = do
- [storageFURLStr, capStr, shareNumStr] <- getArgs
- let Right (CHKReader Reader{verifier = Verifier{..}}) = parse pCapability "argv[2]" (Data.Text.pack capStr)
- Just URI{uriAuthority = Just URIAuth{uriRegName = hostname, uriPort = (':' : port)}, uriPath = ('/' : swissnum)} = parseFURL storageFURLStr
-
- run (Data.Text.unpack . Data.Text.toLower . encodeBase32Unpadded $ storageIndex) hostname (read port) swissnum (ShareNumber (read shareNumStr))
-
--- Parse it like a regular URI after removing the confusing "tcp:" prefix on
--- the netloc.
-parseFURL :: String -> Maybe URI
-parseFURL = parseURI . Data.Text.unpack . Data.Text.replace "tcp:" "" . Data.Text.pack
-
--- Add the necessary authorization header.
-fixAccept :: Applicative f => String -> Request -> f Request
-fixAccept swissnum req =
- pure req{requestHeaders = ("Authorization", "Tahoe-LAFS " <> enc swissnum) : requestHeaders req}
- where
- enc = Base64.encode . encodeUtf8 . Data.Text.pack
-
-fixAcceptPrint :: String -> Request -> IO Request
-fixAcceptPrint swissnum req = do
- print req
- fixAccept swissnum req
-
--- Do some API calls and report the results.
-run ::
- -- | The base32-encoded storage index for which to request share info.
- String ->
- -- | The hostname or IP address of the storage server to query.
- String ->
- -- | The port number of the storage server to query.
- Int ->
- -- | The swissnum of the storage service
- String ->
- -- | A share number to download from the server.
- ShareNumber ->
- IO ()
-run storageIndex hostname port swissnum shareNum = do
- manager' <- newTlsManagerWith managerSettings
- let callIt :: ClientM a -> IO (Either ClientError a)
- callIt = flip runClientM (mkClientEnv manager' (BaseUrl Https hostname port ""))
-
- putStrLn "getVersion"
- ver <- callIt version
- showIt ver
- putStrLn "getImmutableShareNumbers:"
- sharez <- callIt $ getImmutableShareNumbers storageIndex
- showIt sharez
- putStrLn "readImmutableShare - succeeds!"
- chk <- callIt $ readImmutableShare storageIndex shareNum Nothing
- showIt chk
- where
- tlsSettings = TLSSettingsSimple True True True
- sockSettings = Nothing
- managerSettings = (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = fixAccept swissnum}
-
-showIt :: (Show a1, Show a2) => Either a1 a2 -> IO ()
-showIt what = case what of
- Left err -> putStrLn $ "Error: " <> show err
- Right it -> print it
+ [storageNURLStr, capStr, shareNumStr] <- getArgs
+ let Right (CHKReader Reader{verifier = Verifier{..}}) = parse pCapability "argv[2]" (T.pack capStr)
+ nurlM = parseNURL . T.pack $ storageNURLStr
+
+ case nurlM of
+ Nothing ->
+ print ("Failed to parse NURL" :: T.Text)
+ Just nurl -> do
+ result <- runGBS nurl $ do
+ ver <- version
+ sharez <- getImmutableShareNumbers storageIndexS
+ chk <- readImmutableShare storageIndexS shareNum Nothing
+ pure (ver, sharez, chk)
+
+ case result of
+ Left err -> print $ "Request error: " <> show err
+ Right (ver, sharez, chk) -> do
+ print $ "version: " <> show ver
+ print $ "share numbers: " <> show sharez
+ print $ "share bytes: " <> show chk
+ where
+ storageIndexS = T.unpack . T.toLower . encodeBase32Unpadded $ storageIndex
+ shareNum = ShareNumber $ read shareNumStr
diff --git a/src/TahoeLAFS/Internal/Client.hs b/src/TahoeLAFS/Internal/Client.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a6ab6292ccd81713b5b9e26f67c730e13d35723f
--- /dev/null
+++ b/src/TahoeLAFS/Internal/Client.hs
@@ -0,0 +1,171 @@
+{-# 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', value') : xs)
+ | name == name' = o : xs
+ | otherwise = o : addHeader (name, value) xs
+
+addAuthorizationPrint :: T.Text -> Request -> IO Request
+addAuthorizationPrint swissnum req = do
+ print "Before"
+ print req
+ print "--------"
+ r <- addAuthorization swissnum req
+ print "After"
+ print r
+ print "--------"
+ pure r
diff --git a/src/TahoeLAFS/Internal/ServantUtil.hs b/src/TahoeLAFS/Internal/ServantUtil.hs
index baffc0df31cd11816f3f8b151354658ada7fc935..ad1dd955c859efdc7f22d36060bd5d333fb6a35e 100644
--- a/src/TahoeLAFS/Internal/ServantUtil.hs
+++ b/src/TahoeLAFS/Internal/ServantUtil.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TahoeLAFS.Internal.ServantUtil (
@@ -14,8 +15,7 @@ import Network.HTTP.Media (
import Data.ByteString (
ByteString,
)
-import qualified Data.ByteString.Base64 as Base64
-import qualified Data.Text as T
+import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import Data.Text.Encoding (
decodeLatin1,
encodeUtf8,
diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs
index b899f88495973b6f6acea9e8d32f4d8744eb2836..6caa42da142844a40e4cdf1b359c795ada75203c 100644
--- a/src/TahoeLAFS/Storage/API.hs
+++ b/src/TahoeLAFS/Storage/API.hs
@@ -8,6 +8,7 @@
-- Supports derivations for ShareNumber
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeOperators #-}
module TahoeLAFS.Storage.API (
@@ -69,7 +70,7 @@ import Data.Aeson.Types (
)
import Data.Bifunctor (Bifunctor (bimap))
import qualified Data.ByteString as B
-import qualified Data.ByteString.Base64 as Base64
+import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import qualified Data.Map as Map
import Data.Map.Strict (
Map,
diff --git a/src/TahoeLAFS/Storage/Client.hs b/src/TahoeLAFS/Storage/Client.hs
index 004177988675b97f874aca8b3f7d33d12efb2855..d0333011b33717fc96ba78996a127a0520d488f8 100644
--- a/src/TahoeLAFS/Storage/Client.hs
+++ b/src/TahoeLAFS/Storage/Client.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
module TahoeLAFS.Storage.Client (
-- General server info
@@ -16,16 +19,43 @@ module TahoeLAFS.Storage.Client (
readMutableShares,
getMutableShareNumbers,
adviseCorruptMutableShare,
+ parseNURL,
+ runGBS,
+ NURL (..),
) where
-import Data.Proxy
-import Servant
+import Control.Monad ((>=>))
+import qualified "base64" Data.ByteString.Base64.URL as Base64URL
+import Data.Proxy (Proxy (..))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.HTTP.Client.TLS (
+ newTlsManagerWith,
+ )
+import Network.Socket (HostName, PortNumber)
+import Network.URI (
+ -- URI (URI, uriAuthority, uriPath),
+ URIAuth (URIAuth, uriPort, uriRegName, uriUserInfo),
+ parseURI,
+ )
+import Servant (
+ URI (URI, uriAuthority, uriFragment, uriPath),
+ type (:<|>) ((:<|>)),
+ )
import Servant.Client (
+ BaseUrl (BaseUrl),
+ ClientError,
+ ClientM,
+ Scheme (Https),
client,
+ mkClientEnv,
+ runClientM,
)
+import TahoeLAFS.Internal.Client (SPKIHash (SPKIHash), mkGBSManagerSettings)
import TahoeLAFS.Storage.API (
StorageAPI,
)
+import Text.Read (readMaybe)
newApi :: Proxy StorageAPI
newApi = Proxy
@@ -41,3 +71,42 @@ newApi = Proxy
:<|> getMutableShareNumbers
:<|> adviseCorruptMutableShare
) = client newApi
+
+-- | Represent a "new" style service URL.
+data NURL = NURLv1
+ { -- | The cryptographic fingerprint of the server hosting the service.
+ nurlv1Fingerprint :: SPKIHash
+ , -- | A hint about the network location of the server hosting the service.
+ nurlv1Address :: (HostName, PortNumber)
+ , -- | The secret identifier for the service within the scope of the server.
+ nurlv1Swissnum :: T.Text
+ }
+ deriving (Ord, Eq, Show)
+
+-- | Parse a Great Black Swamp NURL from text.
+parseNURL :: T.Text -> Maybe NURL
+parseNURL = parseURI . T.unpack >=> uriToNURL
+
+uriToNURL :: URI -> Maybe NURL
+uriToNURL URI{uriAuthority = Just URIAuth{uriUserInfo, uriRegName = hostname, uriPort = (':' : port)}, uriPath = ('/' : swissnum), uriFragment = "#v=1"} =
+ case (requiredHashE, portM) of
+ (Left _, _) -> Nothing
+ (_, Nothing) -> Nothing
+ (Right requiredHash, Just portNum) -> Just NURLv1{nurlv1Fingerprint = requiredHash, nurlv1Address = (hostname, portNum), nurlv1Swissnum = T.pack swissnum}
+ where
+ requiredHashE = fmap SPKIHash . Base64URL.decodeBase64 . T.encodeUtf8 . T.pack . dropLast 1 $ uriUserInfo
+ portM = readMaybe port
+uriToNURL _ = Nothing
+
+{- | Execute some client operations against the Great Black Swamp server at
+ the location indicated by the given NURL.
+-}
+runGBS :: NURL -> ClientM a -> IO (Either ClientError a)
+runGBS NURLv1{nurlv1Fingerprint, nurlv1Address = (hostname, port), nurlv1Swissnum} action = do
+ manager <- newTlsManagerWith (mkGBSManagerSettings nurlv1Fingerprint nurlv1Swissnum)
+ let clientEnv = mkClientEnv manager (BaseUrl Https hostname (fromIntegral port) "")
+ runClientM action clientEnv
+
+dropLast :: Int -> [a] -> [a]
+dropLast n xs =
+ take (length xs - n) xs
diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal
index e276a2e85b7e1b7528f8d51c4453861b81017497..c30e0336df5980eabe588a603ee63e860896e61e 100644
--- a/tahoe-great-black-swamp.cabal
+++ b/tahoe-great-black-swamp.cabal
@@ -40,7 +40,7 @@ source-repository head
gitlab@whetstone.private.storage:privatestorage/tahoe-great-black-swamp.git
common executable-opts
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ ghc-options:
common common-opts
default-extensions:
@@ -81,6 +81,8 @@ library
import: common-opts
hs-source-dirs: src
exposed-modules:
+ TahoeLAFS.Internal.Client
+ TahoeLAFS.Internal.ServantUtil
TahoeLAFS.Storage.API
TahoeLAFS.Storage.APIDocs
TahoeLAFS.Storage.Backend
@@ -90,24 +92,38 @@ library
TahoeLAFS.Storage.Client
TahoeLAFS.Storage.Server
- other-modules: TahoeLAFS.Internal.ServantUtil
default-language: Haskell2010
build-depends:
- , base >=4.7 && <5
- , base64-bytestring >=1.0.0.3 && <1.3
- , cborg >=0.2.4 && <0.3
- , cborg-json >=0.2.2 && <0.3
- , http-api-data >=0.4.1.1 && <0.7
- , http-media >=0.8 && <0.9
- , scientific >=0.3.6.2 && <0.4
- , serialise >=0.2.3 && <0.3
- , servant-client >=0.16.0.1 && <0.21
- , servant-docs >=0.11.4 && <0.14
- , servant-server >=0.16.2 && <0.21
- , utf8-string >=1.0.1.1 && <1.1
- , wai >=3.2.2.1 && <3.3
- , warp >=3.3.13 && <3.4
- , warp-tls >=3.2.12 && <3.5
+ , asn1-encoding >=0.9.6 && <0.10
+ , asn1-types >=0.3.4 && <0.4
+ , base >=4.7 && <5
+ , base64
+ , base64-bytestring >=1.0.0.3 && <1.3
+ , cborg >=0.2.4 && <0.3
+ , cborg-json >=0.2.2 && <0.3
+ , connection >=0.3.1 && <0.4
+ , cryptonite
+ , data-default-class
+ , http-api-data >=0.4.1.1 && <0.7
+ , http-client >=0.6.4.1 && <0.8
+ , http-client-tls >=0.3.5.3 && <0.4
+ , http-media >=0.8 && <0.9
+ , memory
+ , network
+ , network-uri >=2.6.3 && <2.7
+ , scientific >=0.3.6.2 && <0.4
+ , serialise >=0.2.3 && <0.3
+ , servant-client >=0.16.0.1 && <0.21
+ , servant-docs >=0.11.4 && <0.14
+ , servant-server >=0.16.2 && <0.21
+ , tls
+ , utf8-string >=1.0.1.1 && <1.1
+ , wai >=3.2.2.1 && <3.3
+ , warp >=3.3.13 && <3.4
+ , warp-tls >=3.2.12 && <3.5
+ , x509
+ , x509-store
+ , x509-validation
-- executable gbs-generate-apidocs
-- hs-source-dirs: generate-apidocs
@@ -130,7 +146,6 @@ executable client-test
, aeson >=1.4.7 && <2.2
, base >=4.7 && <5
, base32 >=0.2.1 && <0.3
- , base64-bytestring >=1.0.0.3 && <1.3
, bytestring >=0.10.8.2 && <0.11
, cborg >=0.2.4 && <0.3
, connection >=0.3.1 && <0.4
@@ -139,7 +154,6 @@ executable client-test
, http-client-tls >=0.3.5.3 && <0.4
, http-types >=0.12.3 && <0.13
, megaparsec >=8.0 && <9.3
- , network-uri >=2.6.3 && <2.7
, serialise >=0.2.3 && <0.3
, servant >=0.16.2 && <0.21
, servant-client >=0.16.0.1 && <0.21
@@ -175,26 +189,41 @@ test-suite http-tests
main-is: Main.hs
other-modules:
CBORSpec
+ ClientSpec
HTTPSpec
Lib
MiscSpec
SemanticSpec
Spec
+ Vectors
default-language: Haskell2010
ghc-options: -Wall
build-depends:
, base >=4.7 && <5
, base32string >=0.9.1 && <0.10
+ , base64
, cborg >=0.2.4 && <0.3
+ , connection
+ , data-default-class
, hspec <2.12
, hspec-expectations <0.9
, hspec-wai <0.12
+ , http-client >=0.6.4.1 && <0.8
+ , network
+ , network-simple-tls
, QuickCheck <2.15
, quickcheck-instances <0.4
, serialise >=0.2.3 && <0.3
, servant >=0.16.2 && <0.21
+ , servant-client >=0.16.0.1 && <0.21
, tahoe-great-black-swamp
, temporary >=1.3 && <1.4
+ , tls
, vector >=0.12.1.2 && <0.13
, wai-extra >=3.0.29.2 && <3.2
+ , warp
+ , warp-tls
+ , x509
+ , x509-store
+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
diff --git a/test/ClientSpec.hs b/test/ClientSpec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..52baf8c2cf7b23cfaeae56cbf0bc6277fafe7ee5
--- /dev/null
+++ b/test/ClientSpec.hs
@@ -0,0 +1,241 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ClientSpec where
+
+import qualified Control.Concurrent.Async as Async
+import Control.Exception (Exception, SomeException, throwIO, try)
+import Control.Monad (forM_)
+import Data.Bifunctor (Bifunctor (bimap))
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Default.Class (Default (def))
+import Data.Either (isRight)
+import qualified Data.Text as T
+import Data.X509 (CertificateChain (..), getSigned, signedObject)
+import GHC.IO (unsafePerformIO)
+import Network.HTTP.Client (
+ defaultRequest,
+ managerModifyRequest,
+ newManager,
+ parseRequest,
+ requestHeaders,
+ withConnection,
+ )
+import Network.HTTP.Client.Internal (Connection (connectionRead))
+import qualified Network.Simple.TCP.TLS as SimpleTLS
+import Network.Socket (
+ AddrInfoFlag (AI_NUMERICHOST, AI_NUMERICSERV),
+ Family (AF_INET),
+ SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix),
+ Socket,
+ SocketType (Stream),
+ addrAddress,
+ addrFlags,
+ addrSocketType,
+ bind,
+ close',
+ defaultHints,
+ getAddrInfo,
+ getSocketName,
+ hostAddress6ToTuple,
+ hostAddressToTuple,
+ listen,
+ openSocket,
+ socket,
+ )
+import qualified Network.TLS as TLS
+import Network.TLS.Extra.Cipher (ciphersuite_default)
+import Network.Wai.Handler.Warp (defaultSettings)
+import Network.Wai.Handler.WarpTLS (
+ runTLSSocket,
+ tlsSettings,
+ )
+import Servant.Client (ClientError (ConnectionError))
+import TahoeLAFS.Internal.Client (
+ SPKIHash (SPKIHash),
+ mkGBSManagerSettings,
+ spkiBytes,
+ spkiFingerprint,
+ )
+import TahoeLAFS.Storage.Backend.Memory (memoryBackend)
+import TahoeLAFS.Storage.Client (NURL (NURLv1, nurlv1Address), runGBS, version)
+import qualified TahoeLAFS.Storage.Server as Server
+import Test.Hspec (
+ Spec,
+ describe,
+ expectationFailure,
+ it,
+ runIO,
+ shouldBe,
+ shouldContain,
+ shouldReturn,
+ shouldSatisfy,
+ shouldThrow,
+ )
+import Text.Printf (printf)
+import Vectors (SPKICase (..), loadSPKITestVector)
+
+-- Paths to pre-generated test data - an RSA private key and associated
+-- self-signed certificate.
+privateKeyPath :: FilePath
+privateKeyPath = "test/data/private-key.pem"
+certificatePath :: FilePath
+certificatePath = "test/data/certificate.pem"
+
+spkiTestVectorPath :: FilePath
+spkiTestVectorPath = "test/data/spki-hash-test-vectors.yaml"
+
+credentialE :: Either String TLS.Credential
+{-# NOINLINE credentialE #-}
+credentialE = unsafePerformIO $ TLS.credentialLoadX509 certificatePath privateKeyPath
+
+credential :: TLS.Credential
+credential = either (error . ("Failed to load test credentials: " <>) . show) id credentialE
+
+spec :: Spec
+spec = do
+ describe "mkGBSManagerSettings" $ do
+ describe "Authorization header" $ do
+ it "includes the Tahoe-LAFS realm and encoded swissnum" $ do
+ modified <- managerModifyRequest settings request
+ requestHeaders modified
+ -- Should contain the base64 encoding of the swissnum
+ `shouldContain` [("authorization", "Tahoe-LAFS c3dpc3NudW0=")]
+ it "does not duplicate the header" $ do
+ modified <- managerModifyRequest settings request
+ modified' <- managerModifyRequest settings modified
+ let authorizations = filter (("authorization" ==) . fst) (requestHeaders modified')
+ length authorizations `shouldBe` 1
+
+ describe "SPKI Fingerprints" $ do
+ vectorE <- runIO $ loadSPKITestVector <$> B.readFile spkiTestVectorPath
+ case vectorE of
+ Left loadErr ->
+ it "test suite bug" $ expectationFailure $ "could not load test vectors: " <> show loadErr
+ Right vector -> do
+ describe "spkiBytes" $ do
+ it "agrees with the test vectors" $ do
+ forM_ vector $ \(SPKICase{spkiExpected, spkiCertificate}) -> do
+ spkiBytes spkiCertificate `shouldBe` spkiExpected
+
+ describe "spkiFingerprint" $ do
+ it "agrees with the test vectors" $ do
+ forM_ vector $ \(SPKICase{spkiExpectedHash, spkiCertificate}) -> do
+ spkiFingerprint spkiCertificate `shouldBe` spkiExpectedHash
+
+ describe "TLS connections" $ do
+ let CertificateChain [signedExactCert] = fst credential
+ requiredHash = spkiFingerprint . signedObject . getSigned $ signedExactCert
+ it "makes a connection to a server using the correct certificate" $ do
+ withTlsServer (TLS.Credentials [credential]) "Hello!" expectServerSuccess $ \serverAddr -> do
+ let (host, port) = addrToHostPort serverAddr
+ manager <- newManager (mkGBSManagerSettings requiredHash "swissnum")
+ req <- parseRequest $ printf "https://%s:%d/" host port
+ withConnection req manager $ \clientConn -> do
+ connectionRead clientConn `shouldReturn` "Hello!"
+
+ it "refuses to make a connection to a server not using the correct certificate" $ do
+ withTlsServer (TLS.Credentials [credential]) "Hello!" expectServerFailure $ \serverAddr -> do
+ let (host, port) = addrToHostPort serverAddr
+ manager <- newManager (mkGBSManagerSettings (SPKIHash "wrong spki hash") "swissnum")
+ req <- parseRequest $ printf "https://%s:%d/" host port
+ withConnection req manager connectionRead
+ `shouldThrow` (\(TLS.HandshakeFailed _) -> True)
+
+ describe "runGBS" $ do
+ let swissnum = "hello world"
+ let CertificateChain [signedExactCert] = fst credential
+ let certificate = signedObject . getSigned $ signedExactCert
+ let nurl = NURLv1 (spkiFingerprint certificate) ("127.0.0.1", 0) swissnum
+ it "returns Left on connection errors" $ do
+ result <- runGBS nurl version
+ result
+ `shouldSatisfy` ( \case
+ Left (ConnectionError _) -> True
+ _ -> False
+ )
+
+ it "returns Right on success" $ do
+ backend <- memoryBackend
+ ver <- withServerSocket $ \sock -> do
+ Async.withAsync (runTLSSocket (tlsSettings certificatePath privateKeyPath) defaultSettings sock (Server.app backend)) $
+ const $ do
+ addr <- getSocketName sock
+ runGBS nurl{nurlv1Address = bimap T.unpack fromIntegral $ addrToHostPort addr} version
+ ver `shouldSatisfy` isRight
+ where
+ settings = mkGBSManagerSettings (SPKIHash "just any hash") "swissnum"
+ request = defaultRequest
+
+ expectServerSuccess = id
+ expectServerFailure server = do
+ result <- try server
+ case result of
+ Left (_ :: SomeException) -> pure ()
+ Right r -> throwIO $ ExpectedFailure ("Expect the server to fail but it succeed with " <> show r)
+
+withServerSocket :: (Socket -> IO a) -> IO a
+withServerSocket action = do
+ sock <- socket AF_INET Stream 0
+ listen sock 1
+ r <- action sock
+ close' sock
+ pure r
+
+newtype ExpectedFailure = ExpectedFailure String deriving (Eq, Ord, Show)
+instance Exception ExpectedFailure
+
+addrToHostPort :: SockAddr -> (T.Text, Int)
+addrToHostPort (SockAddrInet port host) = (T.pack $ uncurry4 (printf "%d.%d.%d.%d") (hostAddressToTuple host), fromIntegral port)
+addrToHostPort (SockAddrInet6 port _flow host _scope) = (T.pack $ uncurry8 (printf "%x:%x:%x:%x:%x:%x:%x:%x") (hostAddress6ToTuple host), fromIntegral port)
+addrToHostPort (SockAddrUnix _path) = error "Cannot do TLS over a Unix socket"
+
+-- XXX get a Credential here and then use it to set up the TLS.Context
+-- ServerParams -> serverShared (Shared) -> sharedCredentials -> Credentials ([Credential]) -> (CertificateChain, PrivKey)
+-- ServerParams -> serverHooks (ServerHooks) -> onServerNameIndication -> return Credentials ([Credential]) -> (CertificateChain, PrivKey)
+withTlsServer :: TLS.Credentials -> LB.ByteString -> (IO () -> IO ()) -> (SockAddr -> IO a) -> IO a
+withTlsServer serverCredentials expectedBytes runServer clientApp = do
+ -- XXX safely clean up
+ bindAddr : _ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")
+ sock <- openSocket bindAddr
+ bind sock (addrAddress bindAddr)
+ listen sock 1
+ boundAddr <- getSocketName sock
+
+ -- The server socket is bound and listening so it is safe to initiate a
+ -- connection now. We'll get to handling the TLS connection next.
+ client <- Async.async (clientApp boundAddr)
+
+ -- Tests cover success and failure codepaths. Let them make whatever
+ -- assertion they want about the server result.
+ () <- runServer $ SimpleTLS.accept serverParams sock serverApp
+
+ -- Let the client finish
+ Async.wait client
+ where
+ -- Serve a connection to the TLS server.
+ serverApp (ctx, _) = TLS.sendData ctx expectedBytes
+
+ hints =
+ defaultHints
+ { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]
+ , addrSocketType = Stream
+ }
+ serverParams =
+ def
+ { TLS.serverShared =
+ def
+ { TLS.sharedCredentials = serverCredentials
+ }
+ , TLS.serverSupported =
+ def
+ { TLS.supportedCiphers = ciphersuite_default
+ }
+ }
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 z (a, b, c, d) = z a b c d
+
+uncurry8 :: (a -> b -> c -> d -> e -> f -> g -> h -> i) -> (a, b, c, d, e, f, g, h) -> i
+uncurry8 z (a, b, c, d, e, f, g, h) = z a b c d e f g h
diff --git a/test/Spec.hs b/test/Spec.hs
index 8d9d31a7463636c9b3b20018e4d15b8b707c39e3..53f227449651481a6b8236df6528e652b15e8408 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -3,13 +3,15 @@ module Spec where
import Test.Hspec
import qualified CBORSpec as C
+import qualified ClientSpec as Client
import qualified HTTPSpec as H
import qualified MiscSpec as M
import qualified SemanticSpec as S
spec :: Spec
-spec = do
- parallel $ describe "HTTP" H.spec
- parallel $ describe "Misc" M.spec
- parallel $ describe "Semantic" S.spec
- parallel $ describe "CBOR" C.spec
+spec = parallel $ do
+ describe "HTTP" H.spec
+ describe "Misc" M.spec
+ describe "Semantic" S.spec
+ describe "CBOR" C.spec
+ describe "Client" Client.spec
diff --git a/test/Vectors.hs b/test/Vectors.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b9f85cf464ff8b19bbc3659510949f4879a2bff6
--- /dev/null
+++ b/test/Vectors.hs
@@ -0,0 +1,64 @@
+module Vectors where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Base64.URL as Base64URL
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.X509 (Certificate, getSigned, signedObject)
+import Data.X509.Memory (readSignedObjectFromMemory)
+import Data.Yaml (FromJSON (..), ParseException, decodeEither', withObject, (.:))
+import TahoeLAFS.Internal.Client (SPKIHash (SPKIHash))
+
+-- | A single case of expected SPKI fingerprint calculation behavior.
+data SPKICase = SPKICase
+ { -- | The expected bytes representation of the SPKI information.
+ spkiExpected :: B.ByteString
+ , -- | The expected SPKI Fingerprint.
+ spkiExpectedHash :: SPKIHash
+ , -- | The certificate to operate on for this case.
+ spkiCertificate :: Certificate
+ }
+ deriving (Eq, Show)
+
+-- | A single possibly-successfully loaded SPKI fingerprint test case.
+data SPKICase' = SPKICase'
+ { spkiExpected' :: Either T.Text B.ByteString
+ , spkiExpectedHash' :: Either T.Text B.ByteString
+ , spkiCertificates' :: [Certificate]
+ }
+ deriving (Eq, Show)
+
+instance FromJSON SPKICase' where
+ parseJSON = withObject "SPKICase" $ \o ->
+ SPKICase'
+ <$> (Base64.decodeBase64 . T.encodeUtf8 <$> o .: "expected-spki")
+ <*> (Base64URL.decodeBase64 . T.encodeUtf8 <$> o .: "expected-hash")
+ <*> (fmap (signedObject . getSigned) . readSignedObjectFromMemory . T.encodeUtf8 <$> o .: "certificate")
+
+-- | Some possibly-successfully loaded SPKI fingerprint test cases.
+newtype SPKITestVector = SPKITestVector
+ { spkiTestVector :: [SPKICase']
+ }
+ deriving (Eq, Show)
+
+instance FromJSON SPKITestVector where
+ parseJSON = withObject "SPKITestVector" $ \o -> SPKITestVector <$> o .: "vector"
+
+-- | Attempt to load the SPKI Fingerprint test cases.
+loadSPKITestVector ::
+ -- | The YAML-serialized representation of the test cases.
+ B.ByteString ->
+ -- | The cases or an error if something went wrong.
+ Either LoadError [SPKICase]
+loadSPKITestVector = either (Left . YamlParseError) (traverse toSPKICase . spkiTestVector) . decodeEither'
+
+-- | Convert a possibly-successfully loaded SPKI fingerprint test case to a canonical form.
+toSPKICase :: SPKICase' -> Either LoadError SPKICase
+toSPKICase (SPKICase' (Right expected) (Right hash) [cert]) = Right $ SPKICase expected (SPKIHash hash) cert
+toSPKICase (SPKICase' (Left err) _ _) = Left $ TestVectorDataError $ "Error loading expected field: " <> T.pack (show err)
+toSPKICase (SPKICase' _ (Left err) _) = Left $ TestVectorDataError $ "Error loading hash field: " <> T.pack (show err)
+toSPKICase (SPKICase' _ _ certs) = Left $ TestVectorDataError $ "Error loading certs field: " <> T.pack (show certs)
+
+-- | Represent an error that was encountered while trying to load the test data.
+data LoadError = YamlParseError ParseException | TestVectorDataError T.Text deriving (Show)
diff --git a/test/data/certificate.pem b/test/data/certificate.pem
new file mode 100644
index 0000000000000000000000000000000000000000..d81466c35263984a1e0453352e7585083b96f437
--- /dev/null
+++ b/test/data/certificate.pem
@@ -0,0 +1,32 @@
+-----BEGIN CERTIFICATE-----
+MIIFbTCCA1WgAwIBAgIUKCE7U2P4crsJcoC352pjvYOV4YAwDQYJKoZIhvcNAQEL
+BQAwRTELMAkGA1UEBhMCVVMxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM
+GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAgFw0yMzA4MjExNzE5NTVaGA8yMTIz
+MDcyODE3MTk1NVowRTELMAkGA1UEBhMCVVMxEzARBgNVBAgMClNvbWUtU3RhdGUx
+ITAfBgNVBAoMGEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDCCAiIwDQYJKoZIhvcN
+AQEBBQADggIPADCCAgoCggIBAN4WMHMG+rMEkVw6pXh247YohAh4Hwx3ctWUF5iS
+vI/m30Ib4rOkNaVeRuZftyDwmdnEhHtS1whs/k++PQsS1go2oqkTleyzVfYlfxYz
+Nd+db0OOYNBDZQ5+26e1KBq5l+cachhbRnm6l1UfrzLoN5Kvfv1uwyo+457wag98
+HWfgvNRI0Kwq8TI6c4AqSkFMIfvtsNqQONK1vNZG5tQcaIyA2lHPfYE34nWOJnVN
+5xheNcN3G/SuTVgRQ3jy7Bo9lvnbq3SjJulUazUrLWG+PwHvPv/FwGCFOybBCa2j
+n7qk1Gil44B6bw4rrIj/zbXxkO34d2aH2JsVTUgXmOhR27XQpz2Uuj15pDrFrIdC
+q0M+JGblI94KRYCiDCvOQX3YuzkpYkTXqmmhBC5DOqyj4Ov9Q0Q70FI+c1gE8mQh
+7eUMk0qG76jCeqnguyCKfhpX84kkQBycByBN/qgXUa71+XDErrLnAlgVh9nCAQFJ
+Vx6DAUtIILvuNkCB41AJG4Hz/WEztORaewRDehH99P4ULOG0VeF1BXoDnpWptD6w
+CON6ZpEgXdSEsZnlnWiBUvkFTQLpcUgeP6Naf1Dxwfbp/YDLPQ5s4DIoB/1lhBeT
+f2JZlgjy3Ya/LM9dQ35Le/D9omvjecy4aVvqPOihBHNNAIauInc0QRaSmM7g64D4
+Hh/9AgMBAAGjUzBRMB0GA1UdDgQWBBSogQZaLNNgPwIr0IkvhZKuwAg/TTAfBgNV
+HSMEGDAWgBSogQZaLNNgPwIr0IkvhZKuwAg/TTAPBgNVHRMBAf8EBTADAQH/MA0G
+CSqGSIb3DQEBCwUAA4ICAQCTDExMH2N+TQgV9XUyeFP01/Brm9UcP6m9Jz7ge8PI
+L6foOuN3kMOMX/dDo5rux2oq+8NkNTw4w7nd5PX5KmLV9KHXwNcfuOrXIHm4dbPC
+l/aoOUQFLuusQ1aBsBvVsn5AUYULOB8BaBG0iyvS6pdYVEZG1y6mfss2hIAOf6nF
+CesqGj84mDaUVnDtenvyOdeitJDMF0ueYQE7psp2ToySD85HRScNI2L1qNmcshAr
+Xk+qnahtwqNaq9Et0H0Fcvf+wjuHxWlUjZaFbz+vJLAc0vuSNjqZRTw5ZKQdqbRF
+rPdet73v8DeJIzwszaA6fwO7R8jOR5AwHDijdaf0Y7S6xJdNhqEEeEttR3FlccFX
+bNkIob1OG7kOY4ckTtTn7uQwdgdvYo3cfJZ9ZKUt7FAw2PwlbArbw2IysmobPksO
+X2Q96OQn91vV0p9y838s8dfKwDpOSsx6eCIF5FiV9X3DSxNVN3nwXZApdbYcJT/E
+sRkecWcM7dS5wvvnhxxEnq2cEnXm2S5lONOJc8ae/9hp0Z5SsIKgYpO0oTWwiMMS
+fo6BOYpQRf1iXdYb3x60O8wIATyxXU+9Ckh63cFQexxkXrlInvf+Iht5NA/qA6kw
+qMhAh80khUX2tXzHZLt+aH6aGKYfaBJHFr4/sfY/VyePZG7La2RgA8B+Pl6yyq6k
+gQ==
+-----END CERTIFICATE-----
diff --git a/test/data/private-key.pem b/test/data/private-key.pem
new file mode 100644
index 0000000000000000000000000000000000000000..7f36378609a9ebabe3f17434bf91bcf333e65290
--- /dev/null
+++ b/test/data/private-key.pem
@@ -0,0 +1,52 @@
+-----BEGIN PRIVATE KEY-----
+MIIJQQIBADANBgkqhkiG9w0BAQEFAASCCSswggknAgEAAoICAQDeFjBzBvqzBJFc
+OqV4duO2KIQIeB8Md3LVlBeYkryP5t9CG+KzpDWlXkbmX7cg8JnZxIR7UtcIbP5P
+vj0LEtYKNqKpE5Xss1X2JX8WMzXfnW9DjmDQQ2UOftuntSgauZfnGnIYW0Z5updV
+H68y6DeSr379bsMqPuOe8GoPfB1n4LzUSNCsKvEyOnOAKkpBTCH77bDakDjStbzW
+RubUHGiMgNpRz32BN+J1jiZ1TecYXjXDdxv0rk1YEUN48uwaPZb526t0oybpVGs1
+Ky1hvj8B7z7/xcBghTsmwQmto5+6pNRopeOAem8OK6yI/8218ZDt+Hdmh9ibFU1I
+F5joUdu10Kc9lLo9eaQ6xayHQqtDPiRm5SPeCkWAogwrzkF92Ls5KWJE16ppoQQu
+Qzqso+Dr/UNEO9BSPnNYBPJkIe3lDJNKhu+ownqp4Lsgin4aV/OJJEAcnAcgTf6o
+F1Gu9flwxK6y5wJYFYfZwgEBSVcegwFLSCC77jZAgeNQCRuB8/1hM7TkWnsEQ3oR
+/fT+FCzhtFXhdQV6A56VqbQ+sAjjemaRIF3UhLGZ5Z1ogVL5BU0C6XFIHj+jWn9Q
+8cH26f2Ayz0ObOAyKAf9ZYQXk39iWZYI8t2GvyzPXUN+S3vw/aJr43nMuGlb6jzo
+oQRzTQCGriJ3NEEWkpjO4OuA+B4f/QIDAQABAoICAFI+iWavuPu+v04Wcdzwuldl
+HbA9O9JUEfTCSRK5lJb9+sPyq7u3Hh7FkSATZjAOqgsZWa6J+RQnuO4zF0wYh6d0
+oDxZAnaL21OygyPnhxXuqZutCHFX4/7AP/wVfGqZPIXbJ1GZy7mcvhpKB4mksZ/i
+2fZkpGXqsETV55Egd4tWkNdUt+JqbLQbLVbTUnhoB1XSqmHmcwSlRO9dhnIaqyUN
+Osx9OI838Odz4w4h8Wj2ypY+b93nBsGMcx5BZ+o30Mdq8E3bdbeHCcTA3qeJ2q+O
+uBfkVd/otwUdC8aAB9EI5ZhzhpK3xJTM27JIeRfeA7v8/cq8mBymgN4nzvqKBgDY
+FffeMbeLM3AIg6OgqMhUqQOsBCZNQSypdW3/tJZZyNydmxLP+CjtTBOHBlWSGZfH
+FUXczOASx3kODzXrsUc/OBTt8qbIgvmrW6uilzGZQR6s7h28MOR0pYwrnaiWqR4+
+i+C4aa1Cvxa/VR7Fs5rBg3CYNMyoY6gVig7Je8Z5rBC6wX+8aHpdWdDtoJYYJ871
+WK/Q7Euc6U/RTPmc9iewEzwyMi+I1WNMGITRMF+YtHio3qt01Vo7qaD4JpZn66Ep
+bFu4Smt/BwEM3bfhZFylkdOSftCUjYDZc04NgEuPzWyMXJ4D3Fa1qaGAG4/BtAgg
+Jc3js0vFeJ2JEX3rfLMBAoIBAQD6zwbN7BpoiWKacyLcRIN9yhJBGMCdgxreR8WZ
+uOw2Qbv3fFA2F0LzZFnU+08NH770QgWI+/rOkqUvL0bp9iPc6ujIWv/CF6+MvpTS
+z67QmOFCmadDl8HC2IGrqdHDF+roG1/bifp4NiByBDrSVkyDQSyzeFHHC5Hb/C8E
+tEy8MchsnTBj/6eKMsor1uefybUtRlvk+/eybROKwdXTaXOQop75BKo/rewVwB3f
+q/vCz7buCu517QzAqdn3GQ+xMBu26HmSyVWWNgu96iT1yFXtpcU8FhiPCzpUO2RJ
+WQ8/DCAcM2GtneJTNqLHgSYgG5eXldYtYzueHIF6c27EaLUdAoIBAQDirvjGEjzW
+IZUFUXCsuyovxIul9wyeG8LVZwi3gyrvdlIHDjk0CLsSv3x4RQNV6g+u+iWNJOtI
+DaKC+oiWdxnuip0hH+LVoKkgRB0xWrWHXh3D8E739NY/REQ87gxdtXxqBdzBpqzD
+JAOhFPM+NXMz8J43Gn4jtCOHRRu0sk9iALDx76hXA9L3+U6JAP/PkLrECCWfRGyu
+V/Vncg1I49LUct8BKRcVI0eF3JCL8/s+hc4hVmXwzMlDR0Vif70xe0yDN08qO0aK
+aP2TRx3vgG45Mplx2rNpIbcNljWityIg4lKCozHC8CenLjIARrGvOkTiNfzB6ZGz
+nHv2ZW7S/4BhAoIBABc164pJDFSaSj7C4voBeS298pyFnuW0yVrCx52nSGzo/m0z
+2vR2iKKfqdSVAUbUpkZSidKYhyhw18qbFHP4bG84ahyIl1yt9ngO9xTfVW1GiKoy
+MBGITM0sXiu1xozIfNvIFMHrbfuL/squa4clp2UKNgnR27eQ8YmrN+q2iNdtv/+V
+OHI4qZeXhbAy7jKSZyrudPim/NBNWd6ge5paCvDaq92duee0v8FvixQ1BVKNCH/V
+ESZmrqRx05MThak/K4Fs2DtmWH5TOBj2Pz9jr9gTXEJoRROP1XEQIgLLtCaAh8Q0
+WRjJILXUu5G8+PtFsmy72BtRMKY8OxtK7XhNvF0CggEAJttbZYiGySXkh47YQ6Op
+rZqBXaelkAyuLyqEQgDIAVhE41S61YKRnrsYOP2LftSqb5INkc48TpOXwd/0PeaY
+mV1FZgIzPe9WTmOepXEpINUvQQEWaEad2yZ2lAMyN3X+p6Xtm3xYrPKldJ1EvOso
+nkSmukdeS/x7ApsEDstp9CCuNCqirpfHOB6SKcX0E755ZVUILe7quk/1jw/r2wzC
+fQxb0bUbcdIkVnvigzsFXEhPd0N6IfbYoSG8cQ/4fFzoVq3KcjDK/LrWjMJqDT30
+pvVXfD7C9kiDOl7/Pq8puH1TK3WR+Bp2kZ/HjmiP2LuiRyx98Td6dFFkpm3ou150
+wQKCAQBOs+jN6udmM/TSn8Bb2TDNdZSyidOmug4xRiEH0H9F9BoPPZnfCLzyMy9s
+efuHIuANfxY5Fk0ILzfwxqJHXjCsXV8cB6OXpZn2xy59pnZAzsDhEZb2cR8aIcgx
+KnDx6K9MFoGW61cuUaB0C4en58lxMQumL+KR6FLcP4lQgV8oLwDM80ezXmvybYd0
+5wLDCHeC8vJbxf+054Clu0PwWpJua6DlYgpaPPbfgcsaTyUG6XJMAxUVQTRFknlP
+04Yw5m0O57y7RTEFoGAaxX3hSrK7gTtw38+5mHNPXPE3mQTxglrjih3Hz09Lw3wy
+GmRLxqaoXjQIQuVYicGLUQ4ls59u
+-----END PRIVATE KEY-----
diff --git a/test/data/spki-hash-test-vectors.yaml b/test/data/spki-hash-test-vectors.yaml
new file mode 100644
index 0000000000000000000000000000000000000000..33837a1eae816c8eaabd3813b0dfb7d9e9ca5138
--- /dev/null
+++ b/test/data/spki-hash-test-vectors.yaml
@@ -0,0 +1,80 @@
+vector:
+- expected-hash: >-
+ JIj6ezHkdSBlHhrnezAgIC_mrVQHy4KAFyL-8ZNPGPM
+ expected-spki: >-
+ MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAv9vqtA8Toy9D6xLGq41iUafSiAXnuirWxML2ct/LAcGJzATg6JctmJxxZQL7vkmaFFPBF6Y39bOGbbECM2iQYn2Qemj5fl3IzKTnYLqzryGM0ZwwnNbPyetSe/sksAIYRLzn49d6l+AHR+DjGyvoLzIyGUTn41MTDafMNtPgWx1i+65lFW3GHYpEmugu4bjeUPizNja2LrqwvwFuYXwmKxbIMdioCoRvDGX9SI3/euFstuR4rbOEUDxniYRF5g6reP8UMF30zJzF5j0kyDg8Z5b1XpKFNZAeyRYxcs9wJCqVlP6BLPDnvNVpMXodnWLeTK+r6YWvGadGVufkYNC1PwIDAQAB
+ certificate: |
+ -----BEGIN CERTIFICATE-----
+ MIIDWTCCAkECFCf+I+3oEhTfqt+6ruH4qQ4Wst1DMA0GCSqGSIb3DQEBCwUAMGkx
+ CzAJBgNVBAYTAlpaMRAwDgYDVQQIDAdOb3doZXJlMRQwEgYDVQQHDAtFeGFtcGxl
+ dG93bjEcMBoGA1UECgwTRGVmYXVsdCBDb21wYW55IEx0ZDEUMBIGA1UEAwwLZXhh
+ bXBsZS5jb20wHhcNMjIwMzAyMTUyNTQ3WhcNMjMwMzAyMTUyNTQ3WjBpMQswCQYD
+ VQQGEwJaWjEQMA4GA1UECAwHTm93aGVyZTEUMBIGA1UEBwwLRXhhbXBsZXRvd24x
+ HDAaBgNVBAoME0RlZmF1bHQgQ29tcGFueSBMdGQxFDASBgNVBAMMC2V4YW1wbGUu
+ Y29tMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAv9vqtA8Toy9D6xLG
+ q41iUafSiAXnuirWxML2ct/LAcGJzATg6JctmJxxZQL7vkmaFFPBF6Y39bOGbbEC
+ M2iQYn2Qemj5fl3IzKTnYLqzryGM0ZwwnNbPyetSe/sksAIYRLzn49d6l+AHR+Dj
+ GyvoLzIyGUTn41MTDafMNtPgWx1i+65lFW3GHYpEmugu4bjeUPizNja2LrqwvwFu
+ YXwmKxbIMdioCoRvDGX9SI3/euFstuR4rbOEUDxniYRF5g6reP8UMF30zJzF5j0k
+ yDg8Z5b1XpKFNZAeyRYxcs9wJCqVlP6BLPDnvNVpMXodnWLeTK+r6YWvGadGVufk
+ YNC1PwIDAQABMA0GCSqGSIb3DQEBCwUAA4IBAQByrhn78GSS3dJ0pJ6czmhMX5wH
+ +fauCtt1+Wbn+ctTodTycS+pfULO4gG7wRzhl8KNoOqLmWMjyA2A3mon8kdkD+0C
+ i8McpoPaGS2wQcqC28Ud6kP9YO81YFyTl4nHVKQ0nmplT+eoLDTCIWMVxHHzxIgs
+ 2ybUluAc+THSjpGxB6kWSAJeg3N+f2OKr+07Yg9LiQ2b8y0eZarpiuuuXCzWeWrQ
+ PudP0aniyq/gbPhxq0tYF628IBvhDAnr/2kqEmVF2TDr2Sm/Y3PDBuPY6MeIxjnr
+ ox5zO3LrQmQw11OaIAs2/kviKAoKTFFxeyYcpS5RuKNDZfHQCXlLwt9bySxG
+ -----END CERTIFICATE-----
+
+- expected-hash: >-
+ jIvdTaNKVK_iyt2EOMb0PwF23vpY3yfsQwbr5V2Rt1k
+ expected-spki: >-
+ MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAxMjhLl8R6KX+/itDHCT/T7LQM1i9F6LHe3TW0KWY2FKC2Ov6sJi1pn4NM2qrlW3EUPhX4l0Ru0VE9ZJuwQB1nzFkZIP70Kr8MLmYBoDjWWXsxTiNG4Lj3ydMxBMq/LLSpgHYgb3+Hh+OQeByboW1nVWWm8+QjZNXHhMvRhJmYvyFi0VWoITe/L5R0ubMtGwZ5mal/z9OnvYcE+Jb4PUxiujDhhvAxr4acHscPDn8e4+HBswDSvIHwyxKkE/w6G0yiw736YUbGmxsThSqRqilujh3dAdIVJJxlxhHwrdUkdK/Eq96SOx/BB6M/M8n8KrRNgwuF25MsabRPphgT/l4M46ddyq4209skSnoa1uJdzfx7HQuWep2n0Nagu6WtcKtrzPI3/BKiOMzOcTNOI63VavCtn995CYY9aUoTpz/x/rlp/5TPM1KiaYMBaq+MneBtqlHyYEQUZP9l8QNtvMUO7nLYaYZhcs/QA+qmpJnxcK07njvmw6gh2oLXuvbUbohPVq/3dmRBdJh4tOZWtJsjFP0XYe41Hhw/sUSWXlJAPghLXBBbgAkkeyK5KatuvD7Lpfs/iuz17No1mo8MhLr3+EnzZ1JBuRo8Nksw4FX5ivZmJxt/HQ2UcQ9HZLejIZJbYBEpUu5hvaC0rOmWDWfftLAjD7DzDPu+u46ZNGa8ykCAwEAAQ==
+ certificate: |
+ -----BEGIN CERTIFICATE-----
+ MIIFazCCA1OgAwIBAgIUWcQFI0lueRJyK4txfA/Ydn0bPRIwDQYJKoZIhvcNAQEL
+ BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM
+ GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMzA4MjIxMjUxNDFaFw0yNDA4
+ MjExMjUxNDFaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw
+ HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggIiMA0GCSqGSIb3DQEB
+ AQUAA4ICDwAwggIKAoICAQDEyOEuXxHopf7+K0McJP9PstAzWL0Xosd7dNbQpZjY
+ UoLY6/qwmLWmfg0zaquVbcRQ+FfiXRG7RUT1km7BAHWfMWRkg/vQqvwwuZgGgONZ
+ ZezFOI0bguPfJ0zEEyr8stKmAdiBvf4eH45B4HJuhbWdVZabz5CNk1ceEy9GEmZi
+ /IWLRVaghN78vlHS5sy0bBnmZqX/P06e9hwT4lvg9TGK6MOGG8DGvhpwexw8Ofx7
+ j4cGzANK8gfDLEqQT/DobTKLDvfphRsabGxOFKpGqKW6OHd0B0hUknGXGEfCt1SR
+ 0r8Sr3pI7H8EHoz8zyfwqtE2DC4XbkyxptE+mGBP+Xgzjp13KrjbT2yRKehrW4l3
+ N/HsdC5Z6nafQ1qC7pa1wq2vM8jf8EqI4zM5xM04jrdVq8K2f33kJhj1pShOnP/H
+ +uWn/lM8zUqJpgwFqr4yd4G2qUfJgRBRk/2XxA228xQ7ucthphmFyz9AD6qakmfF
+ wrTueO+bDqCHagte69tRuiE9Wr/d2ZEF0mHi05la0myMU/Rdh7jUeHD+xRJZeUkA
+ +CEtcEFuACSR7Irkpq268Psul+z+K7PXs2jWajwyEuvf4SfNnUkG5Gjw2SzDgVfm
+ K9mYnG38dDZRxD0dkt6MhkltgESlS7mG9oLSs6ZYNZ9+0sCMPsPMM+767jpk0Zrz
+ KQIDAQABo1MwUTAdBgNVHQ4EFgQUl/JLslQ7ISm+9JR1dMaq2I54KAIwHwYDVR0j
+ BBgwFoAUl/JLslQ7ISm+9JR1dMaq2I54KAIwDwYDVR0TAQH/BAUwAwEB/zANBgkq
+ hkiG9w0BAQsFAAOCAgEAwcorbUP98LPyDmOdTe/Y9yLWSgD/xJV/L1oQpB8HhbXA
+ J3mEnlXtPMNFZULSdHxJycexeHe1tiDcFgatQv/YwURHW67s0TFHBXTvSitWz9tU
+ CL/t7pEIdKgzbUL2yQry7voWVUaXOf7//l/4P9x2/egn78L6+KuRek6umtIECsN0
+ HoOiZzqTrXn2WNtnU1Br9m0cxFFzMzP/g2Rd9MUKjIDag7DLfvRCmTMK8825vTJI
+ L3nzGfWk5R+ZWO4BudfvQWpI7iMj2/7lRWxYvmS+SSJh+DFwYwV+4CaCPecXVI2x
+ cD/M3uKTLhUMWo1Ge0qQWhl/qwtJ6FNaxp86yiX8x8EHYB0bDZgH4xMQE0/6o0Vg
+ vKpy/IrEwnN8WM8yYLpm9kTe9H+jM/NEOxPMh4uid/FLmi7KN549UItAzUS3h7zP
+ gP4cpSW+3Dgj0l7C58RIWxwABIIJZMH/2wMT/PeNg2pqDjhkoPDg8rwsvaFn6T0u
+ 1A6pJFnVtWGUuyxJESVYBq4vNSLH68v/xkajxl62uWPDkpgAqWuj5TOUP0e/1Uj5
+ wqF/jNlRhLMw10r0U40AYkzQjgN2Q4jasqUKsZyhDa8F8861BHsSvFPrASLy4UrZ
+ 9Tb4DMYXTNZOY6v1iQerRk4ujx/lTjlwuaX9FsirbkuLv/xF346uEl0jBYR7eMo=
+ -----END CERTIFICATE-----
+
+- expected-hash: >-
+ nG1UHCwz7nXHp2zMCiSfxRbCY29OK3RockkeOiw-t8A
+ expected-spki: >-
+ MCowBQYDK2VwAyEA6gbCgxeb9kkSDo4WbB76aTvBWnpyzColUKDxyDhPu94=
+ certificate: |
+ -----BEGIN CERTIFICATE-----
+ MIIBnzCCAVGgAwIBAgIUBM5d9fmVxhjKQod7TLp6Bb2vEd4wBQYDK2VwMEUxCzAJ
+ BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+ dCBXaWRnaXRzIFB0eSBMdGQwHhcNMjMwODIyMTI1NjE0WhcNMjQwODIxMTI1NjE0
+ WjBFMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwY
+ SW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMCowBQYDK2VwAyEA6gbCgxeb9kkSDo4W
+ bB76aTvBWnpyzColUKDxyDhPu96jUzBRMB0GA1UdDgQWBBQC8cbPWjZilcD4FSU/
+ J1sSNYwpAjAfBgNVHSMEGDAWgBQC8cbPWjZilcD4FSU/J1sSNYwpAjAPBgNVHRMB
+ Af8EBTADAQH/MAUGAytlcANBAGfmvq0a+Ip6nDBlj1tOpyJzcl1J+wj+4N72V23z
+ H1c75cXDrl9DMOqLwNVK9YD2wmaxPyEWO4tdth560Nir4QM=
+ -----END CERTIFICATE-----