diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 6bb1f36ef7a0183555d418421585f1eb1a618e09..8d377001b6a0f7437ef008f13a615b2108909641 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -99,7 +99,7 @@ library
-- Base language which the package is written in.
default-language: Haskell2010
-executable gbs-downloader
+executable gbs-download
-- Import common warning flags.
import:
warnings
@@ -135,7 +135,7 @@ test-suite gbs-downloader-test
default-language: Haskell2010
-- Modules included in this executable, other than Main.
- -- other-modules:
+ other-modules: Generators
-- The interface type and version of the test suite.
type: exitcode-stdio-1.0
@@ -149,6 +149,8 @@ test-suite gbs-downloader-test
-- Test dependencies.
build-depends:
, base ^>=4.14.3.0
+ , base32
+ , binary
, bytestring
, containers
, crypto-api
@@ -156,4 +158,6 @@ test-suite gbs-downloader-test
, hedgehog
, tahoe-chk
, tasty
+ , tasty-hedgehog
, tasty-hunit
+ , text
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 24e6715a99debf1947aac0de7278edc70a39c787..91f851e9552e642e22f95ff7302117b99db3f8cb 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -29,6 +29,9 @@ data DownloadError
, notEnoughSharesFound :: Int
}
| ShareDecodingFailed
+ | -- | An attempt was made to download a share but no servers were given for
+ -- the download.
+ NoServers
deriving (Eq, Ord, Show)
{- | An problem arose while attempting to discover the shares held on a
@@ -105,7 +108,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} openServer =
-}
makeShareMap :: Ord k => [(v, Set.Set k)] -> Map.Map k [v]
makeShareMap locations =
- foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (\_ -> [k]) v) <$> locations)
+ foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (const [k]) v) <$> locations)
-- | Download the bytes of a share from one (or more!) of the given servers.
downloadShare ::
@@ -121,4 +124,5 @@ downloadShare ::
-- | The bytes of the share or some error that was encountered during
-- download.
IO (ShareNum, Either DownloadError LB.ByteString)
-downloadShare = undefined
+downloadShare _ shareNum [] = pure (shareNum, Left NoServers)
+downloadShare _ shareNum _ = pure (shareNum, Right "")
diff --git a/test/Generators.hs b/test/Generators.hs
new file mode 100644
index 0000000000000000000000000000000000000000..08ba46e3fcbefd45e977c8d35e240821439aab1b
--- /dev/null
+++ b/test/Generators.hs
@@ -0,0 +1,22 @@
+module Generators where
+
+import Data.Int (Int64)
+import Hedgehog (MonadGen)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+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}
diff --git a/test/Spec.hs b/test/Spec.hs
index 4251dece5429a402609148124e1adfd5402daef4..fac9ffe160b82ca222b37a3fe42a9a5bfa0840ab 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,17 +1,36 @@
module Main where
+import Control.Exception (Exception, throwIO)
+import Control.Monad (replicateM, zipWithM_)
import Control.Monad.IO.Class (liftIO)
import Crypto.Classes (buildKey)
+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 qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16)
+import Generators (genParameters)
+import Hedgehog (MonadGen, diff, forAll, property)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
import System.IO (hSetEncoding, stderr, stdout, utf8)
+import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
-import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..))
+import qualified Tahoe.CHK.Encrypt
+import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID)
+import Tahoe.CHK.Types (Parameters (..))
+import Tahoe.CHK.Upload (getConvergentKey)
import Tahoe.Download (DownloadError (..), download)
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
tests :: TestTree
tests =
@@ -128,20 +147,103 @@ tests =
"download should fail with not enough shares"
(Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
result
- , testCase "success" $ do
- -- If we can recover enough distinct, decodeable shares from the
- -- configured servers then we can recover the application data.
- --
- -- XXX Start writing here. Probably make this a property test
- -- that generates lots of 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)
- pure ()
+ , testProperty "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
+ -- Constructor <$> arbitrary <*> arbitrary
+
+ -- 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 cap (Binary.encode <$> shares) perServerShareCount servers 0
+
+ -- Recover the plaintext from the servers.
+ result <- liftIO $ download (Map.fromSet makeAnn serverIDs') cap (someServers $ Map.fromList $ zip (encodeUtf8 <$> Set.toList serverIDs') servers)
+ diff (Right plaintext) (==) result
]
where
+ -- A server lookup function that always fails.
noServers _ = pure Nothing
+ -- A server lookup function that finds servers already present in a Map.
+ someServers servers = pure . flip Map.lookup servers . parseURL
+ where
+ -- Exactly match the nonsense makeAnn spits out
+ parseURL = B.take 2 . B.drop 5 . encodeUtf8
+
+ --- 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 :: Reader -> [BL.ByteString] -> [Int] -> [StorageServer] -> Int -> 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 cap shares (n : ns) (s : ss) sharesSoFar = do
+ -- write the right number of shares to this server
+ zipWithM_
+ (\shnum share -> storageServerWrite s (storageIndex . verifier $ cap) shnum 0 share)
+ [fromIntegral n ..]
+ (BL.toStrict <$> take n shares)
+ -- recurse to write the rest
+ placeShares cap (drop n shares) ns ss (sharesSoFar + n)
+
+ -- Make up a distinct (but nonsense) announcement for a given storage
+ -- server identifier.
+ makeAnn :: StorageServerID -> StorageServerAnnouncement
+ makeAnn sid =
+ StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid
+ , storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+
+ -- 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