diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index bd44f3cedd0b64419cc69f09664af15273aa0b66..8afd0f4f15587906ca2bc894de4119a83c54f2cf 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -14,8 +14,9 @@ module Tahoe.Download (
announcementToStorageServer,
) where
-import Control.Exception (SomeException, throwIO, try)
+import Control.Exception (Exception (displayException), SomeException, throwIO, try)
import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Bifunctor (Bifunctor (first))
import Data.Binary (Word16, decodeOrFail)
import qualified Data.ByteString as B
import Data.ByteString.Base32 (encodeBase32Unpadded)
@@ -44,7 +45,8 @@ import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
import Text.Read (readMaybe)
print' :: MonadIO m => String -> m ()
-print' = liftIO . print
+-- print' = liftIO . print
+print' = const $ pure ()
{- | An unrecoverable problem arose while attempting to download and/or read
some application data.
@@ -74,6 +76,8 @@ data DownloadError
| -- | 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
@@ -85,6 +89,7 @@ data DiscoverError
| -- | 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
@@ -113,8 +118,8 @@ download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
print' "Finished locating shares"
case locationE of
Left err -> do
- print' "Got an error locating shares"
- pure $ Left err
+ print' "Got an error locating shares"
+ pure $ Left err
Right discovered -> do
print' "Found some shares, fetching them"
-- XXX note shares can contain failures
@@ -223,9 +228,10 @@ discoverShares lookupServer storageIndex (_sid, sann) = do
Left e -> pure . Left . StorageServerUnreachable $ e
Right ss@StorageServer{storageServerGetBuckets} -> do
print' $ "Getting buckets for " <> show storageIndex
- r <- liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
- print' $ "Got them " <> (show . fmap snd) r
- pure r
+ buckets <- liftIO $ try (storageServerGetBuckets storageIndex)
+ let massaged = first (StorageServerCommunicationError . (displayException :: SomeException -> String)) buckets
+ 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.
@@ -255,9 +261,10 @@ downloadShare storageIndex shareNum (s : _) = do
-- 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.
print' $ "Going to download " <> show storageIndex <> " " <> show shareNum
- shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
+ shareBytes <- liftIO $ try (storageServerRead s storageIndex shareNum)
+ let massaged = first (ShareDownloadError . (displayException :: SomeException -> String)) shareBytes
print' "Downloaded it"
- pure (shareNum, Right $ LB.fromStrict shareBytes)
+ pure $ (shareNum, LB.fromStrict <$> massaged)
data LookupError
= URIParseError StorageServerAnnouncement
@@ -286,42 +293,47 @@ makeServer
manager <- liftIO $ newGBSManager tubid swissnum
print' "Made it"
- let baseUrl = https host realPort
- env = mkClientEnv manager baseUrl
- toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
+ pure $ wrapGreatBlackSwamp manager host realPort
+makeServer _ = pure . Left $ AnnouncementStructureUnmatched
+
+wrapGreatBlackSwamp :: Manager -> [Char] -> Int -> Either a StorageServer
+wrapGreatBlackSwamp manager host realPort =
+ Right $ StorageServer{..}
+ where
+ baseUrl = https host realPort
+ env = mkClientEnv manager baseUrl
+ toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
- storageServerID = undefined
+ storageServerID = undefined
- storageServerWrite = undefined
+ storageServerWrite = undefined
- storageServerRead storageIndex shareNum = do
- let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
- print' "Going to read from a server"
- res <- runClientM clientm env
- print' "Did it"
- case res of
- Left err -> do
- print' "Going to throw a damn IO error"
- throwIO err
- Right bs -> pure bs
+ storageServerRead storageIndex shareNum = do
+ let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+ print' "Going to read from a server"
+ res <- runClientM clientm env
+ print' "Did it"
+ case res of
+ Left err -> do
+ print' "Going to throw a damn IO error"
+ throwIO err
+ Right bs -> pure bs
- storageServerGetBuckets storageIndex = do
- let clientm = getImmutableShareNumbers (toBase32 storageIndex)
- print' "Going to get share numbers"
- r <- try $ runClientM clientm env
- case r of
- Left (err :: SomeException) -> do
- print' $ "A PROBLEM ARISES " <> show err
- pure mempty
- Right res -> do
- print' "Got the share numbers"
- case res of
- Left err -> do
- print' "Going to throw another IO error!!"
- throwIO err
- Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
- pure . Right $ StorageServer{..}
-makeServer _ = pure . Left $ AnnouncementStructureUnmatched
+ storageServerGetBuckets storageIndex = do
+ let clientm = getImmutableShareNumbers (toBase32 storageIndex)
+ print' "Going to get share numbers"
+ r <- try $ runClientM clientm env
+ case r of
+ Left (err :: SomeException) -> do
+ print' $ "A PROBLEM ARISES " <> show err
+ pure mempty
+ Right res -> do
+ print' "Got the share numbers"
+ case res of
+ Left err -> do
+ print' "Going to throw another IO error!!"
+ throwIO err
+ Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
https :: String -> Int -> BaseUrl
https host port =
diff --git a/test/Spec.hs b/test/Spec.hs
index 29a94f7564c1bd97b7b090a2955e2a5d7998e2da..3fbcda4c744ea1d528ed7b57fc9d18724112bd89 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -32,7 +32,7 @@ import Tahoe.CHK.Server (StorageServer (..))
import Tahoe.CHK.Types (Parameters (..))
import Tahoe.CHK.Upload (getConvergentKey)
import Tahoe.Download (
- DiscoverError (StorageServerUnreachable),
+ DiscoverError (..),
DownloadError (..),
LookupError (..),
LookupServer,
@@ -46,6 +46,31 @@ 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
+
tests :: TestTree
tests =
testGroup
@@ -186,6 +211,76 @@ tests =
"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
+ [
+ ( "v0-abc123"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just "somewhere"
+ , storageServerAnnouncementNick = Just "abc123"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ]
+ -- A broken interface to the server
+ server <- breakGetBuckets BespokeFailure <$> memoryStorageServer
+
+ -- Make the server reachable.
+ let openServer StorageServerAnnouncement{storageServerAnnouncementFURL} =
+ if storageServerAnnouncementFURL == Just "somewhere"
+ then pure . pure $ server
+ else pure . Left $ AnnouncementStructureUnmatched
+
+ -- 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
+ , testCase "IO exceptions from storageServerRead are handled" $ do
+ -- An announcement for our server
+ let anns =
+ Map.fromList
+ [
+ ( "v0-abc123"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just "somewhere"
+ , storageServerAnnouncementNick = Just "abc123"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ]
+ -- 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 StorageServerAnnouncement{storageServerAnnouncementFURL} =
+ if storageServerAnnouncementFURL == Just "somewhere"
+ then pure . pure $ server
+ else pure . Left $ AnnouncementStructureUnmatched
+
+ -- 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 "success" $
property $ do
-- If we can recover enough distinct, decodeable shares from the