tahoe-great-black-swamp 0.3.0.1 → 0.3.1.0
raw patch · 15 files changed
+695/−145 lines, 15 filesdep +asn1-encodingdep +asn1-typesdep +base64dep ~connectiondep ~tahoe-chksetup-changed
Dependencies added: asn1-encoding, asn1-types, base64, cryptonite, data-default-class, http2, lens, memory, network, network-simple-tls, tls, x509, x509-store, x509-validation, yaml
Dependency ranges changed: connection, tahoe-chk
Files
- ChangeLog.md +5/−0
- README.rst +25/−0
- Setup.hs +1/−0
- client-test/Main.hs +34/−101
- src/TahoeLAFS/Internal/Client.hs +171/−0
- src/TahoeLAFS/Internal/ServantUtil.hs +2/−2
- src/TahoeLAFS/Storage/API.hs +2/−1
- src/TahoeLAFS/Storage/Backend/Filesystem.hs +2/−2
- src/TahoeLAFS/Storage/Client.hs +71/−2
- tahoe-great-black-swamp.cabal +62/−22
- test/ClientSpec.hs +241/−0
- test/HTTPSpec.hs +1/−2
- test/MiscSpec.hs +7/−8
- test/Spec.hs +7/−5
- test/Vectors.hs +64/−0
ChangeLog.md view
@@ -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.
README.rst view
@@ -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 --------------------
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
client-test/Main.hs view
@@ -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
+ src/TahoeLAFS/Internal/Client.hs view
@@ -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
src/TahoeLAFS/Internal/ServantUtil.hs view
@@ -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,
src/TahoeLAFS/Storage/API.hs view
@@ -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,
src/TahoeLAFS/Storage/Backend/Filesystem.hs view
@@ -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
src/TahoeLAFS/Storage/Client.hs view
@@ -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
tahoe-great-black-swamp.cabal view
@@ -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
+ test/ClientSpec.hs view
@@ -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
test/HTTPSpec.hs view
@@ -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 =
test/MiscSpec.hs view
@@ -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
test/Spec.hs view
@@ -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
+ test/Vectors.hs view
@@ -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)