gbs-downloader (empty) → 0.1.0.0
raw patch · 15 files changed
+1792/−0 lines, 15 filesdep +aesondep +asn1-encodingdep +asn1-types
Dependencies added: aeson, asn1-encoding, asn1-types, async, base, base32, base64-bytestring, binary, bytestring, connection, containers, crypto-api, cryptonite, data-default-class, exceptions, gbs-downloader, hedgehog, http-client, http-client-tls, http-types, megaparsec, memory, network-uri, servant-client, servant-client-core, tahoe-chk, tahoe-directory, tahoe-great-black-swamp, tahoe-ssk, tasty, tasty-hedgehog, tasty-hunit, text, x509, yaml
Files
- CHANGELOG.md +8/−0
- LICENSE +32/−0
- README.md +22/−0
- app/Main.hs +29/−0
- download-sdmf/Main.hs +36/−0
- gbs-downloader.cabal +259/−0
- list-dircap/Main.hs +37/−0
- src/Tahoe/Announcement.hs +117/−0
- src/Tahoe/Download.hs +255/−0
- src/Tahoe/Download/Internal/Capability.hs +170/−0
- src/Tahoe/Download/Internal/Client.hs +198/−0
- src/Tahoe/Download/Internal/Immutable.hs +15/−0
- src/Tahoe/Download/Internal/Mutable.hs +15/−0
- test/Generators.hs +74/−0
- test/Spec.hs +525/−0
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Revision history for gbs-downloader++## 0.1.0.0 -- 2023-08-17++* First version. Released on an unsuspecting world.+* Basic support for loading storage service announcements for server discovery.+* Basic support for downloading the contents associated with a CHK or SDMF read capability.+ * CHK and SDMF directories are also supported.
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright 2023+Jean-Paul Calderone+Shae Erisson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Least Authority TFA GmbH nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,22 @@+# GBS-Downloader++## What is it?++GBS-Downloader integrates Tahoe-CHK with Tahoe-Great-Black-Swamp to support downloading and decoding data from Great Black Swamp servers.+It aims for bit-for-bit compatibility with the original Python implementation.++### What is the current state?++* It can download immutable and mutable shares from Great Black Swamp storage servers.+ * It *does not* cryptographically verify the identity of servers it communicates with.+* It can interpret, decode, and decrypt the data for CHK- and SDMF-encoded shares to recover the plaintext.++## Why does it exist?++A Haskell implementation can be used in places the original Python implementation cannot be+(for example, runtime environments where it is difficult to have a Python interpreter).+Additionally,+with the benefit of the experience gained from creating and maintaining the Python implementation,+a number of implementation decisions can be made differently to produce a more efficient, more flexible, simpler implementation and API.+Also,+the Python implementation claims no public library API for users outside of the Tahoe-LAFS project itself.
+ app/Main.hs view
@@ -0,0 +1,29 @@+module Main where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import Data.Yaml (decodeEither')+import System.Environment (getArgs)+import Tahoe.Announcement (Announcements (..))+import Tahoe.CHK.Capability (CHK (CHKReader), pCapability)+import Tahoe.Download (announcementToImmutableStorageServer, download)+import Text.Megaparsec (parse)++main :: IO ()+main = do+ [announcementPath, readCap] <- getArgs+ -- Load server announcements+ announcementsBytes <- B.readFile announcementPath+ let Right (Announcements announcements) = decodeEither' announcementsBytes++ -- Accept & parse read capability+ let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap)++ -- Download & decode the shares+ result <- download announcements cap announcementToImmutableStorageServer++ -- Show the result+ putStrLn "Your result:"+ either print (C8.putStrLn . BL.toStrict) result
+ download-sdmf/Main.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}++module Main where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import Data.Yaml (decodeEither')+import System.Environment (getArgs)+import Tahoe.Announcement (Announcements (..))+import Tahoe.Download (announcementToMutableStorageServer, download)+import Tahoe.SDMF (SDMF (..), pCapability, writerReader)+import Text.Megaparsec (parse)++main :: IO ()+main = do+ [announcementPath, readCap] <- getArgs+ -- Load server announcements+ announcementsBytes <- B.readFile announcementPath+ let Right (Announcements announcements) = decodeEither' announcementsBytes++ -- Accept & parse read capability+ case parse pCapability "<argv>" (T.pack readCap) of+ Left e -> print $ "Failed to parse cap: " <> show e+ Right (SDMFVerifier _) -> C8.putStrLn "Nothing currently implemented for verifier caps."+ Right (SDMFWriter rwcap) -> go announcements (writerReader rwcap)+ Right (SDMFReader rocap) -> go announcements rocap+ where+ go announcements cap = do+ -- Download & decode the shares+ result <- download announcements cap announcementToMutableStorageServer++ -- Show the result+ putStrLn "Your result:"+ either print (C8.putStrLn . BL.toStrict) result
+ gbs-downloader.cabal view
@@ -0,0 +1,259 @@+cabal-version: 2.4++-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'gbs-downloader' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: gbs-downloader++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis:+ A library for downloading data from a Great Black Swamp server++-- A longer description of the package.+description:+ Integrate tahoe-ssk, tahoe-chk, and tahoe-directory to provide a high-level+ API for downloading immutable and mutable files and directories.++-- URL for the project homepage or repository.+homepage:+ https://whetstone.private.storage/PrivateStorage/gbs-downloader++-- The license under which the package is released.+license: BSD-3-Clause++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Jean-Paul Calderone and others++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: exarkun@twistedmatrix.com++-- A copyright notice.+copyright: 2023 The Authors+category: Network+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files:+ CHANGELOG.md+ README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++source-repository head+ type: git+ location:+ https://whetstone.private.storage/PrivateStorage/gbs-downloader.git++common warnings+ ghc-options: -Wall++common language+ -- LANGUAGE extensions used by modules in all targets.+ default-extensions:+ DerivingStrategies+ GeneralizedNewtypeDeriving+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ TupleSections++library+ -- Import common warning flags.+ import:+ warnings+ , language++ -- Modules exported by the library.+ exposed-modules:+ Tahoe.Announcement+ Tahoe.Download+ Tahoe.Download.Internal.Capability+ Tahoe.Download.Internal.Client+ Tahoe.Download.Internal.Immutable+ Tahoe.Download.Internal.Mutable++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends:+ , aeson >=1.4.7 && <2.2+ , async >=2.2.2 && <2.3+ , base >=4.7 && <5+ , base32 >=0.2.1 && <0.3+ , base64-bytestring >=1.0.0.3 && <1.3+ , binary >=0.8.6 && <0.9+ , bytestring >=0.10.8.2 && <0.11+ , connection >=0.3.1 && <0.4+ , containers >=0.6.0.1 && <0.7+ , data-default-class >=0.1.2 && <0.2+ , exceptions >=0.10.4 && <0.11+ , http-client >=0.6.4.1 && <0.8+ , http-client-tls >=0.3.5.3 && <0.4+ , http-types >=0.12.3 && <0.13+ , network-uri >=2.6.3 && <2.7+ , servant-client >=0.16.0.1 && <0.21+ , servant-client-core >=0.16 && <0.21+ , tahoe-chk >=0.1 && <0.2+ , tahoe-directory >=0.1 && <0.2+ , tahoe-great-black-swamp >=0.3 && <0.4+ , tahoe-ssk >=0.2 && <0.3+ , text >=1.2.3.1 && <1.3+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: Haskell2010++executable download-chk+ -- Import common warning flags.+ import:+ warnings+ , language++ -- .hs or .lhs file containing the Main module.+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends:+ , aeson >=1.4.7 && <2.2+ , base >=4.7 && <5+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.6.0.1 && <0.7+ , gbs-downloader+ , megaparsec >=8.0 && <9.3+ , tahoe-chk >=0.1 && <0.2+ , text >=1.2.3.1 && <1.3+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12++ -- Directories containing source files.+ hs-source-dirs: app++ -- Base language which the package is written in.+ default-language: Haskell2010++executable download-sdmf+ import:+ warnings+ , language++ main-is: Main.hs+ build-depends:+ , aeson >=1.4.7 && <2.2+ , base >=4.7 && <5+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.6.0.1 && <0.7+ , gbs-downloader+ , megaparsec >=8.0 && <9.3+ , tahoe-ssk >=0.2 && <0.3+ , text >=1.2.3.1 && <1.3+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12++ hs-source-dirs: download-sdmf+ default-language: Haskell2010++executable list-dircap+ import:+ warnings+ , language++ main-is: Main.hs+ build-depends:+ , aeson >=1.4.7 && <2.2+ , base >=4.7 && <5+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.6.0.1 && <0.7+ , gbs-downloader+ , megaparsec >=8.0 && <9.3+ , tahoe-chk >=0.1 && <0.2+ , tahoe-directory >=0.1 && <0.2+ , tahoe-ssk >=0.2 && <0.3+ , text >=1.2.3.1 && <1.3+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12++ hs-source-dirs: list-dircap+ default-language: Haskell2010++test-suite gbs-downloader-test+ -- Import common warning flags.+ import:+ warnings+ , language++ -- Base language which the package is written in.+ default-language: Haskell2010+ ghc-options: -threaded++ -- Modules included in this executable, other than Main.+ other-modules: Generators++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: Spec.hs++ -- Test dependencies.+ build-depends:+ , asn1-encoding >=0.9.6 && <0.10+ , asn1-types >=0.3.4 && <0.4+ , base >=4.7 && <5+ , base32 >=0.2.1 && <0.3+ , binary >=0.8.6 && <0.9+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.6.0.1 && <0.7+ , crypto-api >=0.13.3 && <0.14+ , cryptonite >=0.27 && <0.31+ , data-default-class >=0.1.2 && <0.2+ , gbs-downloader+ , hedgehog >=1.0.3 && <1.1+ , http-client >=0.6.4.1 && <0.8+ , http-types >=0.12.3 && <0.13+ , memory >=0.15 && <0.17+ , servant-client >=0.16.0.1 && <0.21+ , servant-client-core >=0.16 && <0.21+ , tahoe-chk >=0.1 && <0.2+ , tahoe-ssk >=0.2 && <0.3+ , tasty >=1.2.3 && <1.5+ , tasty-hedgehog >=1.0.0.2 && <1.2+ , tasty-hunit >=0.10.0.2 && <0.11+ , text >=1.2.3.1 && <1.3+ , x509 >=1.7.5 && <1.8+ , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
+ list-dircap/Main.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}++module Main where++import qualified Data.ByteString as B+import qualified Data.Text as T+import Data.Yaml (decodeEither')+import System.Environment (getArgs)+import Tahoe.Announcement (Announcements (..))+import qualified Tahoe.Directory as TD+import Text.Megaparsec (parse)++import Tahoe.Download (announcementToImmutableStorageServer, announcementToMutableStorageServer, downloadDirectory)++main :: IO ()+main = do+ [announcementPath, dirReadCap] <- getArgs+ -- Load server announcements+ announcementsBytes <- B.readFile announcementPath+ let Right (Announcements announcements) = decodeEither' announcementsBytes++ -- Accept & parse read capability+ case parse TD.pReadSDMF "<argv>" (T.pack dirReadCap) of+ Right r -> go announcements r announcementToMutableStorageServer+ Left eSDMF -> case parse TD.pReadCHK "<argv>" (T.pack dirReadCap) of+ Right r -> go announcements r announcementToImmutableStorageServer+ Left eCHK -> do+ print $ "Failed to parse cap: " <> show eSDMF+ print $ "Failed to parse cap: " <> show eCHK+ where+ go announcements cap lookupServer = do+ -- Download & decode the shares+ result <- downloadDirectory announcements cap lookupServer++ -- Show the result+ putStrLn "Your result:"+ either print print result
+ src/Tahoe/Announcement.hs view
@@ -0,0 +1,117 @@+{- | Represent and work with Tahoe-LAFS storage service announcements.++ A storage service announcement includes information about how to find and+ authenticate a storage service. They are often exchanged using a pubsub+ system orchestrated by an "introducer". Here, we currently support only+ reading them from a yaml or json file.+-}+module Tahoe.Announcement (+ URI (..),+ URIAuth (..),+ StorageServerID,+ StorageServerAnnouncement (..),+ Announcements (..),+ greatBlackSwampURIs,+ parseURI',+) where++import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.:?), (.=))+import qualified Data.ByteString as B+import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded)+import Data.Default.Class (Default (def))+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.URI (URI (..), URIAuth (..), parseURI)++{- | The unique identifier for a particular storage server, conventionally the+ lowercase base32 encoding of some public key controlled by the server.+-}+type StorageServerID = T.Text++{- | A map of storage server announcements keyed on the unique server+ identifier.+-}+newtype Announcements+ = Announcements (Map.Map StorageServerID StorageServerAnnouncement)+ deriving newtype (Eq, Show)++-- Support serialization to the ``servers.yaml`` format supported by+-- Tahoe-LAFS.+instance FromJSON Announcements where+ parseJSON = withObject "servers.yaml" $ \v -> do+ storage <- v .: "storage"+ pure $ Announcements storage++instance ToJSON Announcements where+ toJSON (Announcements announcements) =+ object+ [ "storage" .= announcements+ ]++-- | An announcement from a storage server about its storage service.+data StorageServerAnnouncement = StorageServerAnnouncement+ { storageServerAnnouncementFURL :: Maybe T.Text+ , storageServerAnnouncementNick :: Maybe T.Text+ , storageServerAnnouncementPermutationSeed :: Maybe B.ByteString+ }+ deriving (Eq, Ord, Show)++instance Default StorageServerAnnouncement where+ def =+ StorageServerAnnouncement+ { storageServerAnnouncementFURL = Nothing+ , storageServerAnnouncementNick = Nothing+ , storageServerAnnouncementPermutationSeed = Nothing+ }++-- Support deserialization of a StorageServerAnnouncement from the+-- ``servers.yaml`` format supported by Tahoe-LAFS.+instance FromJSON StorageServerAnnouncement where+ parseJSON = withObject "StorageServerAnnouncement" $ \ann -> do+ v <- ann .: "ann"+ storageServerAnnouncementFURL <- v .:? "anonymous-storage-FURL"+ storageServerAnnouncementNick <- v .:? "nickname"+ permutationSeed <- v .:? "permutation-seed-base32"+ let storageServerAnnouncementPermutationSeed =+ case permutationSeed of+ Nothing -> Nothing+ Just txt -> case decodeBase32Unpadded . encodeUtf8 $ txt of+ Left _ -> Nothing+ Right ps -> Just ps++ pure StorageServerAnnouncement{..}++-- And serialization to that format.+instance ToJSON StorageServerAnnouncement where+ toJSON StorageServerAnnouncement{..} =+ object+ [ "ann"+ .= object+ [ "anonymous-storage-FURL" .= storageServerAnnouncementFURL+ , "nickname" .= storageServerAnnouncementNick+ , "permutation-seed-base32"+ .= (encodeBase32Unpadded <$> storageServerAnnouncementPermutationSeed)+ ]+ ]++{- | If possible, get the URI of a Great Black Swamp server from an+ announcement.+-}+greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI+greatBlackSwampURIs =+ parseURI' . fromMaybe "" . storageServerAnnouncementFURL++{- | Parse a Tahoe-LAFS fURL. For example:++ pb://gnuer2axzoq3ggnn7gjoybmfqsjvaow3@tcp:localhost:46185/sxytycucj5eeunlx6modfazq5byp2hpb++ This *does not* parse NURLs which are the expected way that GBS locations+ will be communicated.++ See https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/6+-}+parseURI' :: T.Text -> Maybe URI+parseURI' = Network.URI.parseURI . T.unpack . Data.Text.replace "tcp:" ""
+ src/Tahoe/Download.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE TypeFamilies #-}++{- | A high-level interface to downloading share data as bytes from storage+ servers.+-}+module Tahoe.Download (+ LookupServer,+ DownloadError (..),+ DirectoryDownloadError (..),+ LookupError (..),+ DiscoverError (..),+ discoverShares,+ download,+ downloadDirectory,+ announcementToImmutableStorageServer,+ announcementToMutableStorageServer,+ getShareNumbers,+) where++import Control.Concurrent.Async (mapConcurrently)+import Control.Exception (Exception (displayException), SomeException, try)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Bifunctor (Bifunctor (first, second))+import Data.Binary (Word16)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Either (partitionEithers, rights)+import Data.List (foldl')+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Tahoe.Announcement (StorageServerAnnouncement)+import Tahoe.CHK.Server (StorageServer (..), StorageServerID)+import Tahoe.CHK.Types (ShareNum, StorageIndex)+import Tahoe.Directory (Directory, DirectoryCapability (DirectoryCapability))+import qualified Tahoe.Directory as Directory+import Tahoe.Download.Internal.Capability+import Tahoe.Download.Internal.Client+import Tahoe.Download.Internal.Immutable+import Tahoe.Download.Internal.Mutable++-- | Partially describe one share download.+type DownloadTask = (ShareNum, StorageServer)++-- | A downloaded share+type DownloadedShare = (ShareNum, LB.ByteString)++{- | Recover the application data associated with a given capability from the+ given servers, if possible.+-}+download ::+ -- To download, we require a capability for which there is a Readable+ -- instance because are also going to decrypt the ciphertext. A different+ -- download interface that skips decryption could settle for a capability+ -- with a Verifiable instance. We also require that the Verifier type for+ -- the read capability has a Verifiable instance because Verifiable is+ -- what gives us the ability to locate the shares. If we located+ -- separately from decrypting this might be simpler.+ (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) =>+ -- | Information about the servers from which to consider downloading shares+ -- representing the application data.+ Map.Map StorageServerID StorageServerAnnouncement ->+ -- | The read capability for the application data.+ readCap ->+ -- | Get functions for interacting with a server given its URL.+ LookupServer IO ->+ -- | Either a description of how the recovery failed or the recovered+ -- application data.+ m (Either DownloadError LB.ByteString)+download servers cap lookupServer = do+ print' ("Downloading: " <> show (getStorageIndex $ getVerifiable cap))+ let verifier = getVerifiable cap+ let storageIndex = getStorageIndex verifier+ -- TODO: If getRequiredTotal fails on the first storage server, we may+ -- need to try more. If it fails for all of them, we need to represent+ -- the failure coherently.+ someParam <- liftIO $ firstRightM lookupServer (getRequiredTotal verifier) (Map.elems servers)+ case someParam of+ Left errs -> pure . Left $ if servers == mempty then NoConfiguredServers else NoReachableServers (StorageServerUnreachable <$> errs)+ Right (required, _) -> do+ locationE <- liftIO $ locateShares servers lookupServer storageIndex (fromIntegral required)+ print' "Finished locating shares"+ case locationE of+ Left err -> do+ print' "Got an error locating shares"+ pure $ Left err+ Right discovered -> do+ print' "Found some shares, fetching them"+ -- XXX note shares can contain failures+ shares <- liftIO $ executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered)+ print' "Fetched the shares, decoding them"+ s <- liftIO $ decodeShares cap shares required+ print' "Decoded them"+ pure s++{- | Apply a monadic operation to each element of a list and another monadic+ operation values in the resulting Rights. If all of the results are Lefts or+ Nothings, return a list of the values in the Lefts. Otherwise, return the+ *first* Right.+-}+firstRightM :: Monad m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> m (Either [b] d)+firstRightM _ _ [] = pure $ Left []+firstRightM f op (x : xs) = do+ s <- f x+ case s of+ Left bs -> first (bs :) <$> recurse+ Right ss -> do+ r <- op ss+ case r of+ Nothing -> recurse+ Just d -> pure $ Right d+ where+ recurse = firstRightM f op xs++{- | Execute each download task sequentially and return only the successful+ results.+-}+executeDownloadTasks ::+ -- | The storage index of the shares to download.+ StorageIndex ->+ -- | The downloads to attempt.+ [DownloadTask] ->+ -- | The results of all successful downloads.+ IO [DownloadedShare]+executeDownloadTasks storageIndex tasks = do+ downloadResults <- mapConcurrently (downloadShare storageIndex) tasks+ pure . rights $ inject <$> downloadResults+ where+ inject (a, b) = (a,) <$> b++-- | Find out which servers claim to have shares related to a given storage index.+locateShares ::+ -- | Information about the servers from which to consider downloading shares+ -- representing the application data.+ Map.Map StorageServerID StorageServerAnnouncement ->+ -- | Get functions for interacting with a server given its URL.+ LookupServer IO ->+ -- | The storage index about which to retrieve information.+ B.ByteString ->+ -- | The number of shares we need to locate. If we cannot find at least+ -- this many shares the result will be an error.+ Word16 ->+ -- | Either an error or a guide to where shares are placed.+ IO (Either DownloadError [(StorageServer, Set.Set ShareNum)])+locateShares servers lookupServer storageIndex required =+ case Map.toList servers of+ [] -> pure . Left $ NoConfiguredServers+ serverList -> do+ print' "Discovering shares"+ -- Ask each server for all shares it has.+ ( problems :: [DiscoverError]+ , discovered :: [(StorageServer, Set.Set ShareNum)]+ ) <-+ partitionEithers <$> mapConcurrently (discoverShares lookupServer storageIndex) serverList+ if null discovered+ then pure . Left . NoReachableServers $ problems+ else+ if (fromIntegral required >) . countDistinctShares $ discovered+ then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered}+ else pure $ Right discovered++{- | Given the results of downloading shares related to a given capability,+ decode them and decrypt the contents of possible.+-}+decodeShares ::+ (Readable readCap, Verifiable v, v ~ Verifier readCap) =>+ -- | The read capability which allows the contents to be decrypted.+ readCap ->+ -- | The results of downloading the shares.+ [DownloadedShare] ->+ Int ->+ IO (Either DownloadError LB.ByteString)+decodeShares r shares required = do+ -- Filter down to shares we actually got.+ let fewerShares = second (deserializeShare (getVerifiable r)) <$> shares+ onlyDecoded = rights $ (\(a, b) -> (fromIntegral a,) <$> b) <$> fewerShares+ if length onlyDecoded < required+ then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}+ else do+ decodeShare r onlyDecoded++{- | Figure the total number of distinct shares reported by all of the servers+ we asked.+-}+countDistinctShares :: Ord b => [(a, Set.Set b)] -> Int+countDistinctShares = Set.size . foldl' Set.union mempty . map snd++{- | Ask one server which shares it has related to the storage index in+ question.+-}+discoverShares ::+ LookupServer IO ->+ StorageIndex ->+ (StorageServerID, StorageServerAnnouncement) ->+ IO (Either DiscoverError (StorageServer, Set.Set ShareNum))+discoverShares lookupServer storageIndex (_sid, sann) = do+ print' "Looking up server from announcement"+ server <- lookupServer sann+ print' "Looked it up"+ case server of+ Left e -> pure . Left . StorageServerUnreachable $ e+ Right ss@StorageServer{storageServerGetBuckets} -> do+ print' $ "Getting buckets for " <> show storageIndex+ buckets <- try (storageServerGetBuckets storageIndex)+ let massaged = first (StorageServerCommunicationError . (displayException :: SomeException -> String)) buckets+ print' $ "Got them " <> show massaged+ pure $ (ss,) <$> massaged++{- | Expand a one-to-many mapping into a list of pairs with each of the "many"+ values as the first element and the corresponding "one" value as the second+ element.+-}+makeDownloadTasks :: Ord k => (v, Set.Set k) -> [(k, v)]+makeDownloadTasks (v, ks) = zip (Set.toList ks) (repeat v)++-- | Download the bytes of a share from one (or more!) of the given servers.+downloadShare ::+ -- | The storage index of the share to download.+ StorageIndex ->+ -- | Addressing information about the share to download.+ DownloadTask ->+ -- | The bytes of the share or some error that was encountered during+ -- download.+ IO (ShareNum, Either DownloadError LB.ByteString)+downloadShare storageIndex (shareNum, s) = do+ print' $ "Going to download " <> show storageIndex <> " " <> show shareNum+ shareBytes <- try (storageServerRead s storageIndex shareNum)+ let massaged = first (ShareDownloadError . (displayException :: SomeException -> String)) shareBytes+ print' "Downloaded it"+ pure (shareNum, LB.fromStrict <$> massaged)++{- | Download the data associated with a directory capability and interpret it+ as a collection of entries.+-}+downloadDirectory ::+ (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) =>+ -- | Information about the servers from which to consider downloading shares+ -- representing the application data.+ Map.Map StorageServerID StorageServerAnnouncement ->+ -- | The read capability for the application data.+ DirectoryCapability readCap ->+ -- | Get functions for interacting with a server given its URL.+ LookupServer IO ->+ -- | Either a description of how the recovery failed or the recovered+ -- application data.+ m (Either DirectoryDownloadError Directory)+downloadDirectory anns (DirectoryCapability cap) lookupServer = do+ bs <- download anns cap lookupServer+ pure $ do+ bs' <- first UnderlyingDownloadError bs+ first (const DecodingError) $ Directory.parse (LB.toStrict bs')++data DirectoryDownloadError+ = UnderlyingDownloadError DownloadError+ | DecodingError+ deriving (Ord, Eq, Show)
+ src/Tahoe/Download/Internal/Capability.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TypeFamilies #-}++module Tahoe.Download.Internal.Capability where++import Control.Exception (SomeException, throwIO, try)+import Control.Monad.IO.Class+import Data.Bifunctor (Bifunctor (..))+import Data.Binary (Word8, decodeOrFail)+import Data.Binary.Get (ByteOffset)+import qualified Data.ByteString.Lazy as LB+import Data.Foldable (foldlM)+import qualified Data.Set as Set+import Network.HTTP.Types (Status (statusCode))+import Servant.Client (ClientError (FailureResponse), ResponseF (..))+import qualified Tahoe.CHK+import qualified Tahoe.CHK.Capability as CHK+import qualified Tahoe.CHK.Encrypt+import Tahoe.CHK.Server+import qualified Tahoe.CHK.Share+import Tahoe.CHK.Types+import Tahoe.Download.Internal.Client+import qualified Tahoe.SDMF as SDMF+import qualified Tahoe.SDMF.Internal.Keys as SDMF.Keys++-- | A capability which confers the ability to locate and verify some stored data.+class Verifiable v where+ -- | Represent the type of share to operate on.+ type ShareT v++ -- | Ask a storage server which share numbers related to this capability it+ -- is holding. This is an unverified result and the storage server could+ -- present incorrect information. Even if it correctly reports that it+ -- holds a share, it could decline to give it out when asked.+ getShareNumbers :: MonadIO m => v -> StorageServer -> m (Set.Set ShareNum)++ -- | Get the encoding parameters used for the shares of this capability.+ -- The information is presented as a tuple of (required, total).++ -- SDMF can fail to figure this out in lots of ways so consider switching+ -- to Either or something?+ getRequiredTotal :: MonadIO m => v -> StorageServer -> m (Maybe (Int, Int))++ -- | Get the location information for shares of this capability.+ getStorageIndex :: v -> StorageIndex++ -- | Deserialize some bytes representing some kind of share to the kind of+ -- share associated with this capability type, if possible.+ deserializeShare ::+ -- | A type witness revealing what type of share to decode to.+ v ->+ -- | The bytes of the serialized share.+ LB.ByteString ->+ Either (LB.ByteString, ByteOffset, String) (ShareT v)++{- | A capability which confers the ability to recover plaintext from+ ciphertext.+-}+class Readable r where+ -- | Represent the type of a Verifiable associated with the Readable.+ type Verifier r++ -- | Attentuate the capability.+ getVerifiable :: r -> Verifier r++ -- | Interpret the required number of shares to recover the plaintext.+ --+ -- Note: might want to split the two functions below out of decodeShare+ --+ -- shareToCipherText :: r -> [(Int, ShareT r)] -> LB.ByteString+ --+ -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString+ decodeShare :: MonadIO m => r -> [(Int, ShareT (Verifier r))] -> m (Either DownloadError LB.ByteString)++instance Verifiable CHK.Verifier where+ type ShareT CHK.Verifier = Tahoe.CHK.Share.Share++ getShareNumbers v s = liftIO $ storageServerGetBuckets s (CHK.storageIndex v)+ getStorageIndex CHK.Verifier{storageIndex} = storageIndex++ -- CHK is pure, we don't have to ask the StorageServer+ getRequiredTotal CHK.Verifier{required, total} _ = pure $ pure (fromIntegral required, fromIntegral total)++ deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail++{- | A capability which confers the ability to interpret some stored data to+ recover the original plaintext. Additionally, it can be attentuated to a+ Verifiable.+-}+instance Readable CHK.Reader where+ type Verifier CHK.Reader = CHK.Verifier++ getVerifiable = CHK.verifier+ decodeShare r shareList = do+ cipherText <- liftIO $ Tahoe.CHK.decode r shareList+ case cipherText of+ Nothing -> pure $ Left ShareDecodingFailed+ Just ct ->+ pure . Right $ Tahoe.CHK.Encrypt.decrypt (CHK.readKey r) ct++firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)+firstJustsM = foldlM go Nothing+ where+ go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)+ go Nothing action = action+ go result@(Just _) _action = return result++instance Verifiable SDMF.Verifier where+ type ShareT SDMF.Verifier = SDMF.Share++ getShareNumbers v s = liftIO $ storageServerGetBuckets s (SDMF.Keys.unStorageIndex $ SDMF.verifierStorageIndex v)+ getStorageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex+ getRequiredTotal SDMF.Verifier{..} ss = liftIO $ do+ -- Find out what shares it has. Any share will do but we need to tell+ -- it which we want.+ errorOrShareNums <- try $ storageServerGetBuckets ss storageIndex+ case Set.toList <$> errorOrShareNums of+ -- Literally anything could go wrong with that...+ Left (e :: SomeException) -> throwIO e+ -- Or the server may have no shares for this storage index.+ Right [] -> pure Nothing+ -- Or it might have at least one. Check each in turn, stopping as+ -- soon as we get a result.+ Right shareNums -> firstJustsM (getParams <$> shareNums)+ where+ -- Get the Required, Total parameters for one share number, if+ -- possible.+ getParams :: MonadIO m => Word8 -> m (Maybe (Int, Int))+ getParams shareNum = liftIO $ do+ errorOrShareBytes <- try $ storageServerRead ss storageIndex shareNum+ case errorOrShareBytes of+ Left e@(FailureResponse _ response) ->+ -- It should not be very surprising for the requested share to+ -- be missing from the server (you can never be sure what a+ -- server will have). Other issues should probably be kept+ -- visible.+ if isStatusCode 404 response+ then pure Nothing+ else throwIO e+ Left e -> throwIO e+ Right shareBytes ->+ case decodeOrFail (LB.fromStrict shareBytes) of+ Left _ -> pure Nothing+ Right (_, _, sh) -> pure $ pure (fromIntegral $ SDMF.shareRequiredShares sh, fromIntegral $ SDMF.shareTotalShares sh)++ storageIndex = SDMF.Keys.unStorageIndex verifierStorageIndex++ deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail++-- | Test the status code of a response for equality against a given value.+isStatusCode :: Int -> ResponseF a -> Bool+isStatusCode expected = (expected ==) . statusCode . responseStatusCode++instance Readable SDMF.Reader where+ type Verifier SDMF.Reader = SDMF.Verifier+ getVerifiable = SDMF.readerVerifier+ decodeShare r shareList = do+ cipherText <- Right <$> liftIO (SDMF.decode r (first fromIntegral <$> shareList))+ case cipherText of+ Left _ -> pure $ Left ShareDecodingFailed+ Right ct -> do+ print' ("Got some ciphertext: " <> show ct)+ print' ("Decrypting with iv: " <> show iv)+ pure . Right $ SDMF.decrypt readKey iv ct+ where+ readKey = SDMF.readerReadKey r+ iv = SDMF.shareIV (snd . head $ shareList)++print' :: MonadIO m => String -> m ()+-- print' = liftIO . putStrLn+print' = const $ pure ()
+ src/Tahoe/Download/Internal/Client.hs view
@@ -0,0 +1,198 @@+{- | Functionality related to acting as a client for the Great Black Swamp+ protocol.+-}+module Tahoe.Download.Internal.Client where++import Control.Exception+import Control.Monad.IO.Class+import qualified Data.ByteString as B+import Data.ByteString.Base32+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding+import Network.Connection+import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))+import Network.HTTP.Client.TLS+import Network.HTTP.Types (ByteRange)+import Servant.Client+import Tahoe.Announcement+import Tahoe.CHK.Server (+ StorageServer (..),+ )+import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))+import Text.Read (readMaybe)++-- | Make an HTTPS URL.+https :: String -> Int -> BaseUrl+https host port =+ BaseUrl+ { baseUrlScheme = Https+ , baseUrlHost = host+ , baseUrlPort = port+ , baseUrlPath = ""+ }++{- | Make an HTTPS manager for the given SPKI hash and swissnum.++ The SPKI hash is _not_ used to authenticate the server! See+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27+-}+managerSettingsForService :: T.Text -> T.Text -> ManagerSettings+managerSettingsForService _ swissnum =+ (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}+ where+ tlsSettings = TLSSettingsSimple True True True+ sockSettings = Nothing+ swissnumBytes = encodeUtf8 swissnum+ swissnumBase64 = Base64.encode swissnumBytes+ headerCompleteBytes = B.concat ["Tahoe-LAFS ", swissnumBase64]+ authorize req =+ req+ { requestHeaders =+ ( "Authorization"+ , headerCompleteBytes+ ) :+ requestHeaders req+ }++-- | Make a manager suitable for use with a Great Black Swamp server.+newGBSManager ::+ MonadIO m =>+ [Char] ->+ String ->+ m Manager+newGBSManager tubid swissnum =+ newTlsManagerWith $+ managerSettingsForService+ (T.pack . init $ tubid)+ (T.pack swissnum)++{- | An unrecoverable problem arose while attempting to download and/or read+ some application data.+-}+data DownloadError+ = -- | The configuration included no candidate servers from which to download.+ NoConfiguredServers+ | -- | Across all of the configured servers, none were actually connectable.+ NoReachableServers [DiscoverError]+ | -- | Across all of the configured servers, fewer than the required+ -- number of shares were found. XXX Could split this into the different+ -- cases - did not locate enough shares, did not download enough shares,+ -- did not verify enough shares+ NotEnoughShares+ { notEnoughSharesNeeded :: Int+ , notEnoughSharesFound :: Int+ }+ | -- | Across all of the shares that we could download, fewer than the+ -- required number could actually be decoded.+ NotEnoughDecodedShares+ { notEnoughDecodedSharesNeeded :: Int+ , notEnoughDecodedSharesFound :: Int+ }+ | -- | Enough syntactically valid shares were recovered but they could not+ -- be interpreted.+ ShareDecodingFailed+ | -- | An attempt was made to download a share but no servers were given for+ -- the download.+ NoServers+ | -- | An error occurred during share download.+ ShareDownloadError String+ deriving (Eq, Ord, Show)++{- | A problem arose while attempting to discover the shares held on a+ particular server.+-}+data DiscoverError+ = -- | An announcement did not include a location for a connection attempt.+ StorageServerLocationUnknown+ | -- | An announcement included a location we could not interpret.+ StorageServerLocationUnsupported+ | StorageServerUnreachable LookupError+ | StorageServerCommunicationError String+ deriving (Eq, Ord, Show)++{- | The type of a function that can produce a concrete StorageServer from+ that server's announcement.+-}+type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)++-- | There was a problem while trying to look up a server from its announcement.+data LookupError+ = -- | The server's announced URI was unparseable.+ URIParseError StorageServerAnnouncement+ | -- | The port integer in the server's URI was unparseable.+ PortParseError String+ | -- | The structure of the server's URI was unparseable.+ AnnouncementStructureUnmatched+ deriving (Eq, Ord, Show)++{- | A problem was encountered attempting to deserialize bytes to a structured+ representation of some value.+-}+data DeserializeError = UnknownDeserializeError -- add more later?++type GetShareNumbers = String -> ClientM (CBORSet ShareNumber)+type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteString++{- | Create a StorageServer that will speak Great Black Swamp using the given+ manager to the server at the given host/port.+-}+mkWrapper :: GetShareNumbers -> ReadShare -> Manager -> [Char] -> Int -> StorageServer+mkWrapper getShareNumbers readShare manager host realPort =+ StorageServer{..}+ where+ baseUrl = https host realPort+ env = mkClientEnv manager baseUrl+ toBase32 = T.unpack . T.toLower . encodeBase32Unpadded++ storageServerID = undefined++ storageServerWrite = undefined++ storageServerRead storageIndex shareNum = do+ let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing+ res <- runClientM clientm env+ case res of+ Left err -> do+ throwIO err+ Right bs -> pure bs++ storageServerGetBuckets storageIndex = do+ let clientm = getShareNumbers (toBase32 storageIndex)+ r <- try $ runClientM clientm env+ case r of+ Left (_ :: SomeException) -> do+ pure mempty+ Right res -> do+ case res of+ Left err -> do+ throwIO err+ Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!++{- | If possible, populate a StorageServer with functions for operating on data+ on the server at the given URI.+-}+makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer)+makeServer+ getShareNumbers+ readShare+ URI+ { uriScheme = "pb:"+ , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)}+ , uriPath = ('/' : swissnum)+ , uriFragment = "" -- It's a fURL, not a NURL, so there's no fragment.+ } =+ case readMaybe port of+ Nothing -> pure . Left . PortParseError $ port+ Just realPort -> do+ manager <- liftIO $ newGBSManager tubid swissnum++ pure . Right $ mkWrapper getShareNumbers readShare manager host realPort+makeServer _ _ _ = pure . Left $ AnnouncementStructureUnmatched++announcementToStorageServer :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer)+announcementToStorageServer getShareNumbers readShare ann =+ case greatBlackSwampURIs ann of+ Nothing -> pure . Left . URIParseError $ ann+ Just uri -> makeServer getShareNumbers readShare uri
+ src/Tahoe/Download/Internal/Immutable.hs view
@@ -0,0 +1,15 @@+-- | Functionality related to retrieving "immutable" shares (mainly CHK).+module Tahoe.Download.Internal.Immutable where++import Control.Monad.IO.Class (MonadIO)+import Tahoe.Announcement (StorageServerAnnouncement)+import Tahoe.CHK.Server (StorageServer)+import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer)+import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)++{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a+ Great Black Swamp server and construct a StorageServer for interacting with+ immutable shares stored on it.+-}+announcementToImmutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)+announcementToImmutableStorageServer = announcementToStorageServer getImmutableShareNumbers readImmutableShare
+ src/Tahoe/Download/Internal/Mutable.hs view
@@ -0,0 +1,15 @@+-- | Functionality related to retrieving "mutable" shares (for example, SDMF).+module Tahoe.Download.Internal.Mutable where++import Control.Monad.IO.Class (MonadIO)+import Tahoe.Announcement (StorageServerAnnouncement)+import Tahoe.CHK.Server (StorageServer)+import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer)+import TahoeLAFS.Storage.Client (getMutableShareNumbers, readMutableShares)++{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a+ Great Black Swamp server and construct a StorageServer for interacting with+ mutable shares stored on it.+-}+announcementToMutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)+announcementToMutableStorageServer = announcementToStorageServer getMutableShareNumbers readMutableShares
+ test/Generators.hs view
@@ -0,0 +1,74 @@+module Generators where++import qualified Crypto.PubKey.RSA as RSA+import Data.ASN1.BinaryEncoding (DER (DER))+import Data.ASN1.Encoding (ASN1Decoding (decodeASN1))+import Data.ASN1.Types (ASN1Object (fromASN1))+import Data.Bifunctor (Bifunctor (first))+import Data.ByteString.Base32 (encodeBase32Unpadded)+import qualified Data.ByteString.Lazy as LB+import Data.Int (Int64)+import qualified Data.Text as T+import Data.X509 (PrivKey (PrivKeyRSA))+import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import System.IO.Unsafe (unsafePerformIO)+import Tahoe.Announcement (Announcements (..), StorageServerAnnouncement (..))+import Tahoe.CHK.Types (Parameters (..))++-- | The maximum value an Int64 can represent.+maxInt64 :: Integer+maxInt64 = fromIntegral (maxBound :: Int64)++-- | Generate Parameters values for which all field invariants hold.+genParameters :: MonadGen m => m Parameters+genParameters = do+ paramSegmentSize <- Gen.integral (Range.exponential 1 maxInt64)+ paramTotalShares <- Gen.integral (Range.linear 2 256)+ paramRequiredShares <- Gen.integral (Range.linear 1 (paramTotalShares - 1))+ -- XXX We're going to get rid of "Happy" from this type. For now it's+ -- easier not to let this value vary and it doesn't hurt anything.+ let paramHappyShares = 1+ pure $ Parameters{paramSegmentSize, paramTotalShares, paramHappyShares, paramRequiredShares}++genAnnouncements :: MonadGen m => Range.Range Int -> m Announcements+genAnnouncements size =+ Announcements <$> Gen.map size ((,) <$> genServerIDs <*> genStorageServerAnnouncements)++genServerIDs :: MonadGen m => m T.Text+genServerIDs = T.toLower . encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32)++genStorageServerAnnouncements :: MonadGen m => m StorageServerAnnouncement+genStorageServerAnnouncements =+ StorageServerAnnouncement+ <$> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)+ <*> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)+ <*> Gen.maybe (Gen.bytes $ Range.singleton 32)++{- | Build RSA key pairs.++ Because the specific bits of the key pair shouldn't make any difference to+ any application logic, generating new RSA key pairs is expensive, and+ generating new RSA key pairs in a way that makes sense in Hedgehog is+ challenging, this implementation just knows a few RSA key pairs already and+ will give back one of them.+-}+genRSAKeys :: MonadGen m => m RSA.PrivateKey+genRSAKeys = Gen.element (map rsaKeyPair rsaKeyPairBytes)++-- I'm not sure how to do IO in MonadGen so do the IO up front unsafely (but+-- hopefully not really unsafely).+rsaKeyPairBytes :: [LB.ByteString]+{-# NOINLINE rsaKeyPairBytes #-}+rsaKeyPairBytes = unsafePerformIO $ mapM (\n -> LB.readFile ("test/data/rsa-privkey-" <> show n <> ".der")) [0 .. 4 :: Int]++rsaKeyPair :: LB.ByteString -> RSA.PrivateKey+rsaKeyPair bs = do+ let (Right kp) = do+ asn1s <- first show (decodeASN1 DER bs)+ (r, _) <- fromASN1 asn1s+ case r of+ PrivKeyRSA pk -> pure pk+ _ -> error "Expected RSA Private Key"+ kp
+ test/Spec.hs view
@@ -0,0 +1,525 @@+module Main where++import Control.Exception (Exception, throwIO)+import Control.Monad (replicateM, when)+import Control.Monad.IO.Class (liftIO)+import Crypto.Cipher.Types (nullIV)+import Crypto.Classes (buildKey)+import qualified Crypto.Hash+import Data.Bifunctor (bimap)+import qualified Data.Binary as Binary+import qualified Data.ByteString as B+import Data.ByteString.Base32 (encodeBase32Unpadded)+import qualified Data.ByteString.Lazy as BL+import Data.Default.Class (Default (def))+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq (Empty), fromList)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word16)+import qualified Data.Yaml as Yaml+import Generators (genAnnouncements, genParameters, genRSAKeys)+import Hedgehog (MonadGen, annotateShow, diff, discard, forAll, property, tripping)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Network.HTTP.Types.Status (Status (..))+import Network.HTTP.Types.Version (http11)+import Servant.Client.Core (BaseUrl (..), ClientError (..), RequestF (..), ResponseF (..), Scheme (..))+import System.IO (hSetEncoding, stderr, stdout, utf8)+import Tahoe.Announcement (+ Announcements,+ StorageServerAnnouncement (..),+ StorageServerID,+ URI (..),+ URIAuth (..),+ parseURI',+ )+import qualified Tahoe.CHK+import Tahoe.CHK.Capability (Reader (..), Verifier (..))+import qualified Tahoe.CHK.Encrypt+import Tahoe.CHK.Server (StorageServer (..))+import Tahoe.CHK.Types (Parameters (..))+import Tahoe.CHK.Upload (getConvergentKey)+import Tahoe.Download (+ DiscoverError (..),+ DownloadError (..),+ LookupError (..),+ LookupServer,+ download,+ )+import Tahoe.Download.Internal.Capability (getRequiredTotal)+import qualified Tahoe.SDMF as SDMF+import qualified Tahoe.SDMF.Keys as SDMF.Keys+import Tahoe.Server (memoryStorageServer)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)+import Test.Tasty.Hedgehog (testProperty)++data PlacementError = RanOutOfPlacementInfo | RanOutOfServers deriving (Eq, Show)+instance Exception PlacementError++{- | Return a new StorageServer like the given one but with a get-buckets+ interface that always throws an IO exception.+-}+breakGetBuckets :: Exception e => e -> StorageServer -> StorageServer+breakGetBuckets exc ss =+ ss+ { storageServerGetBuckets = const $ throwIO exc+ }++{- | Return a new StorageServer like the given one but with a read-share+ interface that always throws an IO exception.+-}+breakRead :: Exception e => e -> StorageServer -> StorageServer+breakRead exc ss =+ ss+ { storageServerRead = \_ _ -> throwIO exc+ }++{- | A completely arbitrary exception that the download implementation can't+ know anything specific about.+-}+data BespokeFailure = BespokeFailure deriving (Show)++instance Exception BespokeFailure++-- | Make an announcement that's real enough to convince a test.+simpleAnnouncement :: T.Text -> T.Text -> (T.Text, StorageServerAnnouncement)+simpleAnnouncement nick furl =+ ( T.concat ["v0-", nick]+ , def+ { storageServerAnnouncementFURL = Just furl+ , storageServerAnnouncementNick = Just nick+ }+ )++{- | Build a lookup function that can look up any server in the given list+ from its announcement.+-}+simpleLookup :: Applicative f => [(T.Text, b)] -> StorageServerAnnouncement -> f (Either LookupError b)+simpleLookup [] _ = pure . Left $ AnnouncementStructureUnmatched+simpleLookup ((furl, server) : ss) ann@StorageServerAnnouncement{storageServerAnnouncementFURL} =+ if Just furl == storageServerAnnouncementFURL+ then pure . pure $ server+ else simpleLookup ss ann++tests :: TestTree+tests =+ testGroup+ "All tests"+ [ testCase "Tahoe-LAFS fURLs can be parsed to a structured representation" $+ let tubid = "gnuer2axzoq3ggnn7gjoybmfqsjvaow3"+ swissnum = "sxytycucj5eeunlx6modfazq5byp2hpb"+ in assertEqual+ "The result is as expected"+ ( Just+ URI+ { uriScheme = "pb:"+ , uriAuthority =+ Just+ URIAuth+ { uriUserInfo = tubid <> "@"+ , uriRegName = "localhost"+ , uriPort = ":46185"+ }+ , uriPath = "/" <> swissnum+ , uriQuery = ""+ , uriFragment = ""+ }+ )+ (parseURI' $ T.pack $ "pb://" <> tubid <> "@tcp:localhost:46185/" <> swissnum)+ , testProperty "Announcements round-trip through YAML encoding/decoding" $+ property $ do+ announcements <- forAll $ genAnnouncements (Range.linear 0 3)+ tripping announcements Yaml.encode (Yaml.decodeThrow :: B.ByteString -> Maybe Announcements)+ , testCase+ "no configured servers"+ $ do+ -- If there are no servers then we can't possibly get enough+ -- shares to recover the application data.+ result <- liftIO $ download mempty (trivialCap 1 1) noServers+ assertEqual+ "download should fail with no servers"+ (Left NoConfiguredServers)+ result+ , testCase "no reachable servers" $ do+ -- If we can't contact any configured server then we can't+ -- possibly get enough shares to recover the application data.+ let ann = def{storageServerAnnouncementNick = Just "unreachable"}+ anns =+ Map.fromList+ [ ("v0-abc123", ann)+ ]++ result <- liftIO $ download anns (trivialCap 1 1) noServers+ assertEqual+ "download should fail with no reachable servers"+ (Left $ NoReachableServers [StorageServerUnreachable (URIParseError ann)])+ result+ , testCase "not enough shares" $ do+ -- If we can't recover enough shares from the configured servers+ -- then we can't possibly get enough shares to recover the+ -- application data.+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]+ cap = trivialCap 3 3++ -- Two shares exist.+ server <- memoryStorageServer+ storageServerWrite server (storageIndex . verifier $ cap) 0 0 "Hello world"+ storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world"++ -- Make the server reachable.+ let openServer = simpleLookup [("somewhere", server)]++ -- Try to download the cap which requires three shares to reconstruct.+ result <- liftIO $ download anns cap openServer+ assertEqual+ "download should fail with not enough shares"+ (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})+ result+ , testCase "not enough distinct shares" $ do+ -- If we can't recover enough *distinct* shares from the+ -- configured servers then we can't possibly get enough shares to+ -- recover the application data. Duplicate shares do us no good.+ let anns =+ Map.fromList+ [ simpleAnnouncement "abc123" "somewhere"+ , simpleAnnouncement "abc456" "elsewhere"+ ]+ cap = trivialCap 3 3++ -- Three shares exist+ somewhere <- memoryStorageServer+ let idx = storageIndex . verifier $ cap+ offset = 0+ storageServerWrite somewhere idx 0 offset "Hello world"+ storageServerWrite somewhere idx 1 offset "Hello world"+ -- But this one is just a duplicate of share 0 on the other+ -- server.+ elsewhere <- memoryStorageServer+ storageServerWrite elsewhere idx 0 offset "Hello world"++ -- Make the server reachable.+ let openServer = simpleLookup [("somewhere", somewhere), ("elsewhere", elsewhere)]++ -- Try to download the cap which requires three shares to reconstruct.+ result <- liftIO $ download anns cap openServer+ assertEqual+ "download should fail with not enough shares"+ (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})+ result+ , testCase "IO exceptions from storageServerGetBuckets are handled" $ do+ -- An announcement for our server+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]+ -- A broken interface to the server+ server <- breakGetBuckets BespokeFailure <$> memoryStorageServer++ -- Make the server reachable.+ let openServer = simpleLookup [("somewhere", server)]++ -- Something to pretend to try to download+ let cap = trivialCap 3 13++ -- Try to download the cap which requires three shares to reconstruct.+ result <- liftIO $ download anns cap openServer+ assertEqual+ "download should fail with details about unreachable server"+ (Left (NoReachableServers [StorageServerCommunicationError "BespokeFailure"]))+ result+ , testProperty "getRequiredTotal handles a share being missing from the server" $+ property $ do+ -- If we can recover any single share from the server then we can+ -- inspect it for encoding parameters.++ -- Generates configurations where the encoding parameters dicated+ -- multiple shares but they may not be all placed on the server.+ sequenceNumber <- forAll $ Gen.integral (Range.exponential 1 10000)+ plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)+ Parameters{paramTotalShares, paramRequiredShares} <- forAll genParameters++ -- Encrypt and encode the data into shares.+ keypair <- SDMF.Keys.KeyPair <$> forAll genRSAKeys+ let iv = SDMF.Keys.SDMF_IV nullIV+ ciphertext = SDMF.encrypt keypair iv plaintext+ (shares, cap) <- liftIO $ SDMF.encode keypair iv sequenceNumber paramRequiredShares paramTotalShares ciphertext++ -- Pick some shares for placement on a single server.+ placedShares <- forAll $ Gen.subsequence (zip [0 ..] (Binary.encode <$> shares))+ when (null placedShares) discard++ let verifier = SDMF.readerVerifier . SDMF.writerReader $ cap+ storageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex $ verifier++ -- Be sure to create the server last to avoid having Hedgehog+ -- re-use it for multiple cases.+ server <- liftIO memoryStorageServer+ liftIO $+ placeShares+ storageIndex+ placedShares+ [length placedShares]+ [server]++ r <- getRequiredTotal verifier server+ diff (Just (fromIntegral paramRequiredShares, fromIntegral paramTotalShares)) (==) r+ , testCase "IO exceptions from storageServerRead are handled" $ do+ -- An announcement for our server+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]++ -- A broken interface to the server+ server <- breakRead BespokeFailure <$> memoryStorageServer++ -- Something to pretend to try to download+ let cap = trivialCap 3 13++ -- Three shares exist+ let idx = storageIndex . verifier $ cap+ offset = 0+ storageServerWrite server idx 0 offset "Hello world"+ storageServerWrite server idx 1 offset "Hello world"+ storageServerWrite server idx 2 offset "Hello world"++ -- Make the server reachable.+ let openServer = simpleLookup [("somewhere", server)]++ -- Try to download the cap which requires three shares to reconstruct.++ result <- liftIO $ download anns cap openServer+ assertEqual+ "download should fail with details about unreachable server"+ (Left (NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = 3, notEnoughDecodedSharesFound = 0}))+ result+ , testProperty "chk success" $+ property $ do+ -- If we can recover enough distinct, decodeable shares from the+ -- configured servers then we can recover the application data.++ -- Generates configurations where it should be possible to recover+ -- the data (have all the shares, have enough of the shares,+ -- spread them across many servers, concentrate them on one or a+ -- few, etc)++ secret <- forAll $ Gen.bytes (Range.singleton 32)+ plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)+ params@Parameters{paramTotalShares} <- forAll genParameters++ -- Since multiple shares can be placed on a single server, as long+ -- as we have one server we have a valid case. Since some shares+ -- might be placed non-optimally it is also nice to allow for some+ -- empty servers so allow for that as well.+ let numServers = Range.linear 1 (fromIntegral paramTotalShares + 1)+ serverIDs = Gen.text (Range.singleton 2) Gen.ascii+ serverIDs' <- forAll $ Gen.set numServers serverIDs++ -- Choose a share distribution. Each element of the resulting+ -- list tells us how many shares to place on the next server, for+ -- some arbitrary (stable) server ordering.+ perServerShareCount <-+ forAll $+ genListWithSum (length serverIDs') (fromIntegral paramTotalShares)++ -- Make the servers.+ servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer++ -- Encrypt and encode the data into shares.+ let key = getConvergentKey secret params plaintext+ ciphertext = Tahoe.CHK.Encrypt.encrypt key plaintext+ (shares, cap) <- liftIO $ Tahoe.CHK.encode key params ciphertext++ -- Distribute the shares.+ liftIO $ placeShares (storageIndex . verifier $ cap) (zip [0 ..] (Binary.encode <$> shares)) perServerShareCount servers++ let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers+ lookupServer = someServers serverMap+ serverAnnouncements = Map.fromSet makeAnn serverIDs'++ -- Recover the plaintext from the servers.+ result <- liftIO $ download serverAnnouncements cap lookupServer+ diff (Right plaintext) (==) result+ , testProperty "ssk success" $+ property $ do+ -- Like "chk success" above, but for SDMF (a case of SSK).+ plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)+ sequenceNumber <- forAll $ Gen.integral (Range.exponential 1 10000)+ keypair <- SDMF.Keys.KeyPair <$> forAll genRSAKeys+ Parameters{paramRequiredShares = required, paramTotalShares = total} <- forAll genParameters++ -- Since multiple shares can be placed on a single server, as long+ -- as we have one server we have a valid case. Since some shares+ -- might be placed non-optimally it is also nice to allow for some+ -- empty servers so allow for that as well.+ let numServers = Range.linear 1 (fromIntegral total + 1)+ serverIDs = Gen.text (Range.singleton 2) Gen.ascii+ serverIDs' <- forAll $ Gen.set numServers serverIDs++ perServerShareCount <-+ forAll $+ genListWithSum (length serverIDs') (fromIntegral total)++ -- Make the servers.+ servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer++ -- Derive the keys, encode the data.+ let -- Not a very good IV choice in reality but it's okay for+ -- this test where confidentiality and key secrecy is not+ -- particularly a concern.+ iv = SDMF.Keys.SDMF_IV nullIV+ ciphertext = SDMF.encrypt keypair iv plaintext+ annotateShow ciphertext+ annotateShow iv+ (shares, writeCap) <- liftIO $ SDMF.encode keypair iv sequenceNumber required total ciphertext+ let storageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex . SDMF.readerVerifier . SDMF.writerReader $ writeCap+ readCap = SDMF.writerReader writeCap+ -- Distribute the shares.+ liftIO $ placeShares storageIndex (zip [0 ..] (Binary.encode <$> shares)) perServerShareCount servers++ let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers+ lookupServer = someServers serverMap+ serverAnnouncements = Map.fromSet makeAnn serverIDs'++ -- Recover the plaintext from the servers.+ result <- liftIO $ download serverAnnouncements readCap lookupServer+ diff (Right plaintext) (==) result+ , testCase "immutable upload/download to using Great Black Swamp" $ do+ pure ()+ -- Consider moving these tests to another module, they're pretty+ -- different and there's quite a handful of them.+ --+ -- ERROR CASES+ -- Server presents incorrect TLS certificate+ -- * See https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27+ -- Server returns error response to our request+ -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/4+ -- Server returns tampered share data+ -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/5+ ]+ where+ -- A server lookup function that always fails.+ noServers = pure . Left . URIParseError++ -- A server lookup function that finds servers already present in a Map.+ someServers :: Applicative m => Map.Map StorageServerID StorageServer -> LookupServer m+ someServers servers ann =+ pure $ case result of+ Nothing -> Left AnnouncementStructureUnmatched+ Just ss -> Right ss+ where+ result = do+ furl <- storageServerAnnouncementFURL ann+ let serverId = parseURL furl+ Map.lookup serverId servers++ -- Exactly match the nonsense makeAnn spits out+ parseURL = T.take 2 . T.drop 5++ --- PHILOSOFY+ -- We wish that share numbers were an opaque type instead of a+ -- numeric/integral type. This is not the place to argue the point+ -- though.+ placeShares ::+ -- The storage index to place shares at.+ B.ByteString ->+ -- The number and bytes of the shares themselves.+ [(Int, BL.ByteString)] ->+ -- The number of shares to place on each server.+ [Int] ->+ -- The servers to place shares on.+ [StorageServer] ->+ IO ()+ -- Out of shares, done.+ placeShares _ [] _ _ = pure ()+ -- Out of placement info but not out of shares is a programming error.+ placeShares _ _ [] _ = throwIO RanOutOfPlacementInfo+ -- Out of servers but not out of shares is a programming error.+ placeShares _ _ _ [] = throwIO RanOutOfServers+ -- Having some of all three means we can make progress.+ placeShares si shares (n : ns) (s : ss) = do+ -- write the right number of shares to this server+ mapM_+ (\(shnum, share) -> storageServerWrite s si shnum 0 share)+ (bimap fromIntegral BL.toStrict <$> take n shares)+ -- recurse to write the rest+ placeShares si (drop n shares) ns ss++ -- Make up a distinct (but nonsense) announcement for a given storage+ -- server identifier.+ makeAnn :: StorageServerID -> StorageServerAnnouncement+ makeAnn sid =+ def+ { storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid+ , storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid+ }++ -- Generate lists of ints that sum to a given total.+ genListWithSum :: MonadGen m => Int -> Int -> m [Int]+ -- We hit the target.+ genListWithSum _ 0 = pure []+ -- We only have room for one more element.+ genListWithSum 1 t = pure [t]+ -- Use up some of what's left on one element and recurse.+ genListWithSum maxLength t = do+ v <- Gen.int (Range.linear 0 t)+ (v :) <$> genListWithSum (maxLength - 1) (t - v)++trivialCap :: Word16 -> Word16 -> Reader+trivialCap required total = Reader{..}+ where+ Just readKey = buildKey $ B.replicate 32 0x00+ storageIndex = B.replicate 32 0x00+ fingerprint = B.replicate 32 0x00+ size = 1234+ verifier = Verifier{..}++trivialSDMFVerifier :: SDMF.Verifier+trivialSDMFVerifier = SDMF.Verifier{..}+ where+ verifierStorageIndex = SDMF.Keys.StorageIndex $ B.pack [0 .. 15]+ verifierVerificationKeyHash = Crypto.Hash.hash $ B.pack [0 .. 31]++-- | A real 404 response from tahoe-great-black-swamp 0.3.0.0.+failure404 :: ClientError+failure404 =+ FailureResponse+ ( Request+ { requestPath =+ ( BaseUrl+ { baseUrlScheme = Https+ , baseUrlHost = "storage002.private.storage"+ , baseUrlPort = 8899+ , baseUrlPath = ""+ }+ , "/storage/v1/mutable/6yo5yo6uxniiiwtyxv46bfvwm4/0"+ )+ , requestQueryString = Empty+ , requestBody = Nothing+ , requestAccept = fromList ["application/octet-stream"]+ , requestHeaders = Empty+ , requestHttpVersion = http11+ , requestMethod = "GET"+ }+ )+ ( Response+ { responseStatusCode = Status{statusCode = 404, statusMessage = "Not Found"}+ , responseHttpVersion = http11+ , responseHeaders =+ fromList+ [ ("Transfer-Encoding", "chunked")+ , ("Server", "TwistedWeb/22.10.0")+ , ("Date", "Fri, 23 Jun 2023 11:27:49 GMT")+ , ("Content-Type", "application/octet-stream")+ ]+ , responseBody = ""+ }+ )++main :: IO ()+main = do+ -- Hedgehog writes some non-ASCII and the whole test process will die if+ -- it can't be encoded. Increase the chances that all of the output can+ -- be encoded by forcing the use of UTF-8 (overriding the LANG-based+ -- choice normally made).+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8++ defaultMain tests