diff --git a/flake.nix b/flake.nix index 72e7dac3d07880153daef299b550ccd22605fde3..01d65c63769c028fcc7dbeaf82221e4ed9712a87 100644 --- a/flake.nix +++ b/flake.nix @@ -84,8 +84,13 @@ # headers and stuff. export PKG_CONFIG_PATH=${pkgs.lib.makeSearchPath "lib/pkgconfig" [pkgs.zlib.dev]} + # Get (or update if we have one) a package database so cabal can + # solve our dependencies. cabal update hackage.haskell.org - cabal run tests + + # Configure with tests enable, build the tests (if necessary), + # and run the default test suite. + cabal run --enable-tests tests ''; } }/bin/cabal-build-and-test"; diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs index 48b8cd3e43b7a9e7ee7854c4910eb48c9a166a5e..e957769e353efa3528787c2106cd7b91f9b67d4d 100644 --- a/src/Tahoe/Download.hs +++ b/src/Tahoe/Download.hs @@ -13,13 +13,13 @@ module Tahoe.Download ( import Control.Exception (Exception (displayException), SomeException, throwIO, try) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Bifunctor (Bifunctor (first)) +import Data.Bifunctor (Bifunctor (first, second)) import Data.Binary (Word16, decodeOrFail) import qualified Data.ByteString as B import Data.ByteString.Base32 (encodeBase32Unpadded) import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as LB -import Data.Either (isRight, partitionEithers) +import Data.Either (partitionEithers, rights) import Data.List (foldl') import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -45,6 +45,12 @@ print' :: MonadIO m => String -> m () -- print' = liftIO . print print' = const $ pure () +-- | Partially describe one share download. +type DownloadTask = (ShareNum, StorageServer) + +-- | A downloaded share +type Share = (ShareNum, LB.ByteString) + {- | An unrecoverable problem arose while attempting to download and/or read some application data. -} @@ -120,12 +126,29 @@ download servers cap@Reader{verifier = Verifier{..}} lookupServer = do Right discovered -> do print' "Found some shares, fetching them" -- XXX note shares can contain failures - shares <- fetchShares storageIndex discovered + shares <- executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered) print' "Fetched the shares, decoding them" s <- decodeShares cap shares print' "Decoded them" pure s +{- | Execute each download task sequentially and return only the successful + results. +-} +executeDownloadTasks :: + MonadIO m => + -- | The storage index of the shares to download. + StorageIndex -> + -- | The downloads to attempt. + [DownloadTask] -> + -- | The results of all successful downloads. + m [Share] +executeDownloadTasks storageIndex tasks = do + downloadResults <- mapM (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 :: MonadIO m => @@ -158,24 +181,6 @@ locateShares servers lookupServer storageIndex required = then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered} else pure $ Right discovered -{- | Given a guide to where shares for a given storage index are placed, - download them. --} -fetchShares :: - MonadIO m => - -- | The storage index of the shares to download. - B.ByteString -> - -- | The guide to where shares are placed. - [(StorageServer, Set.Set ShareNum)] -> - m [(ShareNum, Either DownloadError LB.ByteString)] -fetchShares storageIndex discovered = do - print' "Fetching shares" - s <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap) - print' "Fetched shares" - pure s - where - sharemap = makeShareMap discovered - {- | Given the results of downloading shares related to a given capability, decode them and decrypt the contents of possible. -} @@ -184,12 +189,11 @@ decodeShares :: -- | The read capability which allows the contents to be decrypted. Reader -> -- | The results of downloading the shares. - [(ShareNum, Either DownloadError LB.ByteString)] -> + [Share] -> m (Either DownloadError LB.ByteString) decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares = -- Filter down to shares we actually got. - let someShares = filter (isRight . snd) shares - fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares + let fewerShares = second decodeOrFail <$> shares onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares in if length onlyDecoded < fromIntegral required then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded} @@ -230,33 +234,24 @@ discoverShares lookupServer storageIndex (_sid, sann) = do print' $ "Got them " <> show massaged pure $ (ss,) <$> massaged -{- | 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. +{- | 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. -} -makeShareMap :: Ord k => [(v, Set.Set k)] -> Map.Map k [v] -makeShareMap locations = - foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (const [k]) v) <$> locations) +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 :: MonadIO m => -- | The storage index of the share to download. 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] -> + -- | Addressing information about the share to download. + DownloadTask -> -- | The bytes of the share or some error that was encountered during -- download. m (ShareNum, Either DownloadError LB.ByteString) -downloadShare _ shareNum [] = pure (shareNum, Left NoServers) -downloadShare storageIndex shareNum (s : _) = do - -- TODO: There might be more servers. We could try them if this fails. - -- On the other hand, we might get bytes but we don't verify them here so - -- we might also need retry logic up a level or two from here. +downloadShare storageIndex (shareNum, s) = do print' $ "Going to download " <> show storageIndex <> " " <> show shareNum shareBytes <- liftIO $ try (storageServerRead s storageIndex shareNum) let massaged = first (ShareDownloadError . (displayException :: SomeException -> String)) shareBytes