diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 3f4350fa8bfb7decda8d7c5139168c7aaa0f1fbf..6bb1f36ef7a0183555d418421585f1eb1a618e09 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -66,6 +66,7 @@ common language
NamedFieldPuns
OverloadedStrings
RecordWildCards
+ TupleSections
library
-- Import common warning flags.
@@ -85,6 +86,7 @@ library
-- Other library packages from which modules are imported.
build-depends:
, base ^>=4.14.3.0
+ , binary
, bytestring
, containers
, tahoe-chk
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index f5a05d6a3f33cf0aa1af124657913dccb1d3a678..24e6715a99debf1947aac0de7278edc70a39c787 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,13 +1,14 @@
module Tahoe.Download (DownloadError (..), download) where
+import Data.Binary (decodeOrFail)
import qualified Data.ByteString.Lazy as LB
-import Data.Either (rights)
+import Data.Either (isRight, rights)
import Data.List (foldl')
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
+import qualified Tahoe.CHK.Encrypt
import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID, URL)
import Tahoe.CHK.Types (ShareNum, StorageIndex)
@@ -20,11 +21,23 @@ data DownloadError
| -- | Across all of the configured servers, none were actually connectable.
NoReachableServers
| -- | Across all of the configured servers, fewer than the required
- -- number of shares were found.
+ -- 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 decode enough shares, did not verify enough shares
NotEnoughShares
{ notEnoughSharesNeeded :: Int
, notEnoughSharesFound :: Int
}
+ | ShareDecodingFailed
+ deriving (Eq, Ord, Show)
+
+{- | An 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
+ | StorageServerUnreachable
deriving (Eq, Ord, Show)
{- | Recover the application data associated with a given capability from the
@@ -41,18 +54,35 @@ download ::
-- | Either a description of how the recovery failed or the recovered
-- application data.
IO (Either DownloadError LB.ByteString)
-download servers Reader{verifier = Verifier{..}} openServer =
+download servers cap@Reader{readKey, verifier = Verifier{..}} openServer =
case Map.toList servers of
[] -> pure . Left $ NoConfiguredServers
serverList -> do
-- Ask each server for all shares it has.
- discovered <- rights <$> mapM discoverOnce serverList :: IO [(StorageServerID, Set.Set ShareNum)]
+ discovered <- rights <$> mapM discoverOnce serverList :: IO [(StorageServer, Set.Set ShareNum)]
if null discovered
then pure $ Left NoReachableServers
else
if (fromIntegral required >=) . countDistinctShares $ discovered
then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered}
- else pure . Right . LB.fromStrict . encodeUtf8 . T.pack . show $ discovered
+ else do
+ -- XXX up to here is probably "locateShares". now we move in to "fetchShares".
+ let sharemap = makeShareMap discovered
+ -- XXX note shares can contain failures
+ shares <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+ -- XXX That was brief. Probably missing some complexity. now we move on to "decodeShares".
+ -- Filter down to shares we actually got.
+ let someShares = filter (isRight . snd) shares
+ fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares
+ onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares
+ if length onlyDecoded < fromIntegral required
+ then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = length onlyDecoded}
+ else do
+ ciphertext <- Tahoe.CHK.decode cap onlyDecoded
+ case ciphertext of
+ Nothing -> pure $ Left ShareDecodingFailed
+ Just ct ->
+ pure . Right $ Tahoe.CHK.Encrypt.decrypt readKey ct
where
-- Figure the total number of distinct shares reported by all of the servers we
-- asked.
@@ -60,39 +90,35 @@ download servers Reader{verifier = Verifier{..}} openServer =
-- Ask one server which shares it has related to the storage index in
-- question.
- discoverOnce (sid, sann) = do
- sharenums <- discoverShares storageIndex sann openServer
- pure $ case sharenums of
- Left e -> Left e
- Right shnums -> Right (sid, shnums)
+ discoverOnce (_sid, sann) = do
+ case storageServerAnnouncementFURL sann of
+ Nothing -> pure $ Left StorageServerLocationUnknown
+ Just url -> do
+ server <- openServer url
+ case server of
+ Nothing -> pure $ Left StorageServerUnreachable
+ Just ss@StorageServer{storageServerGetBuckets} ->
+ Right . (ss,) <$> storageServerGetBuckets storageIndex
-{- | An problem arose while attempting to discover the shares held on a
- particular server.
+{- | Invert the mapping implied by the list of two tuples so that the servers
+ that claim to have a certain share can easily be retrieved.
-}
-data DiscoverError
- = -- | An announcement did not include a location for a connection attempt.
- StorageServerLocationUnknown
- | StorageServerUnreachable
- deriving (Eq, Ord, Show)
+makeShareMap :: Ord k => [(v, Set.Set k)] -> Map.Map k [v]
+makeShareMap locations =
+ foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (\_ -> [k]) v) <$> locations)
--- | Identify which servers claim to have some data at some index.
-discoverShares ::
- -- | The storage index at which to look for data.
+-- | Download the bytes of a share from one (or more!) of the given servers.
+downloadShare ::
+ -- | The storage index of the share to download.
StorageIndex ->
- -- | A server which could possibly have the data. It "could possibly"
- -- have the data because local configuration suggests the data might have
- -- been uploaded to them in the past.
- StorageServerAnnouncement ->
- -- | A function to connect to a server.
- (URL -> IO (Maybe StorageServer)) ->
- -- | The share numbers the server claims to have.
- IO (Either DiscoverError (Set.Set ShareNum))
-discoverShares storageIndex ann openServer =
- case storageServerAnnouncementFURL ann of
- Nothing -> pure $ Left StorageServerLocationUnknown
- Just url -> do
- server <- openServer url
- case server of
- Nothing -> pure $ Left StorageServerUnreachable
- Just StorageServer{storageServerGetBuckets} ->
- Right <$> storageServerGetBuckets storageIndex
+ -- | The number of the share to download.
+ ShareNum ->
+ -- | The servers which we have a reasonable belief could hold a copy of the
+ -- share. It is common for there to be only one server holding each share
+ -- but nothing *prevents* multiple servers from having one. In this case we
+ -- could download the share from both of them, perhaps.
+ [StorageServer] ->
+ -- | The bytes of the share or some error that was encountered during
+ -- download.
+ IO (ShareNum, Either DownloadError LB.ByteString)
+downloadShare = undefined
diff --git a/test/Spec.hs b/test/Spec.hs
index 74566683bf79262165d72f1c34f878985009d099..4251dece5429a402609148124e1adfd5402daef4 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -128,6 +128,16 @@ 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 ()
]
where
noServers _ = pure Nothing