diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for tahoe-great-black-swamp +## 0.3.1.0 + +* ``TahoeLAFS.Storage.Client.runGBS`` is a new high-level API for performing an interaction with a GBS server. +* Transitive ``http2`` dependency is now constrained to ``<4`` for compatibility with warp 3.3.25. + ## 0.3.0.1 * Package metadata improvements. diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -21,6 +21,31 @@ 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 --- 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 --- a/client-test/Main.hs +++ b/client-test/Main.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {- | Demonstrate the use of some GBS client APIs. @@ -10,113 +8,48 @@ -} module Main where +import Control.Lens (view) 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 - ), pCapability, + storageIndex, + verifier, ) -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 "")) + [storageNURLStr, capStr, shareNumStr] <- getArgs + let Right (CHKReader reader) = parse pCapability "argv[2]" (T.pack capStr) + nurlM = parseNURL . T.pack $ storageNURLStr - 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} + 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) -showIt :: (Show a1, Show a2) => Either a1 a2 -> IO () -showIt what = case what of - Left err -> putStrLn $ "Error: " <> show err - Right it -> print it + 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 . view (verifier . storageIndex) $ reader + shareNum = ShareNumber $ read shareNumStr diff --git a/src/TahoeLAFS/Internal/Client.hs b/src/TahoeLAFS/Internal/Client.hs new file mode 100644 --- /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 --- 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 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 --- 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.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/Backend/Filesystem.hs b/src/TahoeLAFS/Storage/Backend/Filesystem.hs --- a/src/TahoeLAFS/Storage/Backend/Filesystem.hs +++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs @@ -86,7 +86,7 @@ ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten), ) -data FilesystemBackend = FilesystemBackend FilePath +newtype FilesystemBackend = FilesystemBackend FilePath deriving (Show) versionString :: Storage.ApplicationVersion @@ -94,7 +94,7 @@ -- Copied from the Python implementation. Kind of arbitrary. maxMutableShareSize :: Storage.Size -maxMutableShareSize = 69105 * 1000 * 1000 * 1000 * 1000 +maxMutableShareSize = 69_105 * 1_000 * 1_000 * 1_000 * 1_000 -- storage/ -- storage/shares/incoming diff --git a/src/TahoeLAFS/Storage/Client.hs b/src/TahoeLAFS/Storage/Client.hs --- 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 @@ 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 @@ :<|> 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 --- a/tahoe-great-black-swamp.cabal +++ b/tahoe-great-black-swamp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tahoe-great-black-swamp -version: 0.3.0.1 +version: 0.3.1.0 build-type: Simple synopsis: An implementation of the "Great Black Swamp" LAFS protocol. description: @@ -40,7 +40,7 @@ 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: @@ -77,10 +77,22 @@ default-language: Haskell2010 +common warp-workaround + -- Place an upper bound on http2 to get a solution that avoids a compile + -- error in warp 3.3.25 which for some reason includes < 5 as its + -- constraint. + + build-depends: http2 <4 + library - import: common-opts + import: + common-opts + , warp-workaround + hs-source-dirs: src exposed-modules: + TahoeLAFS.Internal.Client + TahoeLAFS.Internal.ServantUtil TahoeLAFS.Storage.API TahoeLAFS.Storage.APIDocs TahoeLAFS.Storage.Backend @@ -90,24 +102,38 @@ 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 >=0.2 && <0.5 + , 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 >=0.27 && <0.31 + , data-default-class >=0.1 && <0.2 + , 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 >=0.15 && <0.19 + , network >=3.1.2 && <3.2 + , 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 >=1.5 && <2 + , 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 >=1.7 && <1.8 + , x509-store >=1.6 && <1.7 + , x509-validation >=1.6 && <1.7 -- executable gbs-generate-apidocs -- hs-source-dirs: generate-apidocs @@ -130,7 +156,6 @@ , 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 @@ -138,12 +163,12 @@ , http-client >=0.6.4.1 && <0.8 , http-client-tls >=0.3.5.3 && <0.4 , http-types >=0.12.3 && <0.13 + , lens >=4.0 && <5.3 , 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 - , tahoe-chk >=0.1 && <0.2 + , tahoe-chk >=0.1 && <0.3 , tahoe-great-black-swamp , text >=1.2.3.1 && <1.3 @@ -175,26 +200,41 @@ 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 >=0.2 && <0.5 , cborg >=0.2.4 && <0.3 + , connection >=0.3 && <0.4 + , data-default-class >=0.1 && <0.2 , hspec <2.12 , hspec-expectations <0.9 , hspec-wai <0.12 + , http-client >=0.6.4.1 && <0.8 + , network >=3.1 && <3.2 + , network-simple-tls >=0.4 && <0.5 , 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 >=1.5 && <2 , vector >=0.12.1.2 && <0.13 , wai-extra >=3.0.29.2 && <3.2 + , warp >=3.3.13 && <3.4 + , warp-tls >=3.2.12 && <3.5 + , x509 >=1.7 && <1.8 + , x509-store >=1.6 && <1.7 + , 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 --- /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/HTTPSpec.hs b/test/HTTPSpec.hs --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -79,12 +79,11 @@ "" -- postJSON :: ByteString -> L.ByteString -> WaiSession st SResponse -postJSON path body = +postJSON path = request methodPost path [("Content-Type", "application/json"), ("Accept", "application/json")] - body -- putShare :: ByteString -> Int64 -> WaiSession st SResponse putShare path size = diff --git a/test/MiscSpec.hs b/test/MiscSpec.hs --- a/test/MiscSpec.hs +++ b/test/MiscSpec.hs @@ -51,12 +51,12 @@ spec = do describe "partitionM" $ it "handles empty lists" $ - partitionM (\e -> return True) ([] :: [(Integer, Integer)]) `shouldBe` (Just ([], [])) + partitionM (\e -> return True) ([] :: [(Integer, Integer)]) `shouldBe` Just ([], []) describe "partitionM" $ it "puts matching elements in the first list and non-matching in the second" $ - partitionM (\e -> return $ (e `mod` 2) == 0) [5, 5, 6, 7, 8, 8] - `shouldBe` (Just ([6, 8, 8], [5, 5, 7])) + partitionM (return . even) [5, 5, 6, 7, 8, 8] + `shouldBe` Just ([6, 8, 8], [5, 5, 7]) describe "storageStartSegment" $ it "returns a string of length 2" $ @@ -70,7 +70,7 @@ genStorageIndex ( \storageIndex shareNumber -> pathOfShare "/foo" storageIndex shareNumber - `shouldBe` (printf "/foo/shares/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber)) + `shouldBe` printf "/foo/shares/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber) ) describe "incomingPathOf" $ @@ -80,7 +80,7 @@ genStorageIndex ( \storageIndex shareNumber -> incomingPathOf "/foo" storageIndex shareNumber - `shouldBe` (printf "/foo/shares/incoming/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber)) + `shouldBe` printf "/foo/shares/incoming/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber) ) describe "incomingPathOf vs pathOfShare" $ @@ -102,7 +102,7 @@ describe "base32 alphabet" $ it "encodes using only the base32 alphabet" $ property $ - \bs -> b32encode bs `shouldSatisfy` (onlyContains "abcdefghijklmnopqrstuvwxyz234567") + \bs -> b32encode bs `shouldSatisfy` onlyContains "abcdefghijklmnopqrstuvwxyz234567" describe "size ratio" $ it "encodes to a string no more than twice the length" $ @@ -111,5 +111,4 @@ -- Does the second list contain only elements of the first list? onlyContains :: (Eq a) => [a] -> [a] -> Bool -onlyContains xs [] = True -onlyContains xs (y : ys) = y `elem` xs && onlyContains xs ys +onlyContains xs = foldr (\y -> (&&) (y `elem` xs)) True diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,13 +3,15 @@ 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 --- /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)