Handle IO exceptions from tahoe-great-black-swamp

Try as hard as we can to make ``download`` return its failures in a Left
instead.

Also factor most of the tahoe-great-black-swamp parts out of `makeServer`in to
a separate helper function.  I thought this function might be where the
exception handling goes but it can't really yet because StorageServer requires
IO exceptions as part of its interface.  Should likely fix that sometime.

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
@@ -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,7 +293,14 @@ makeServer
                 manager <- liftIO $ newGBSManager tubid swissnum
                 print' "Made it"
 
-                let baseUrl = https host realPort
+                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
 
@@ -320,8 +334,6 @@ makeServer
                         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
 
 https :: String -> Int -> BaseUrl
 https host port =

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