Move download and downloadDirectory into ExceptT

CHANGELOG.md

@@ -5,6 +5,8 @@
 * The download APIs now only send requests to a storage server after that
   storage server is authenticated using information from the NURL.
 
+* ``Tahoe.Download.download`` and ``Tahoe.Download.downloadDirectory`` now return ``ExceptT``.
+
 ## 0.1.0.0 -- 2023-08-17
 
 * First version. Released on an unsuspecting world.

gbs-downloader.cabal

@@ -118,6 +118,7 @@ library
     , http-client-tls          >=0.3.5.3  && <0.4
     , http-types               >=0.12.3   && <0.13
     , lens                     >=4.0      && <5.3
+    , mtl
     , network-uri              >=2.6.3    && <2.7
     , servant-client           >=0.16.0.1 && <0.21
     , servant-client-core      >=0.16     && <0.21
@@ -249,6 +250,7 @@ test-suite gbs-downloader-test
     , http-types           >=0.12.3   && <0.13
     , lens                 >=4.0      && <5.3
     , memory               >=0.15     && <0.17
+    , mtl
     , servant-client       >=0.16.0.1 && <0.21
     , servant-client-core  >=0.16     && <0.21
     , tahoe-chk            >=0.2      && <0.3

src/Tahoe/Download.hs

@@ -19,6 +19,7 @@ module Tahoe.Download (
 
 import Control.Concurrent.Async (mapConcurrently)
 import Control.Exception (Exception (displayException), SomeException, try)
+import Control.Monad.Except (ExceptT (..), lift, throwError, withExceptT)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Data.Bifunctor (Bifunctor (first, second))
 import Data.Binary (Word16)
@@ -55,7 +56,7 @@ download ::
     -- the read capability has a Verifiable instance because Verifiable is
     -- what gives us the ability to locate the shares.  If we located
     -- separately from decrypting this might be simpler.
-    (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) =>
+    (Readable readCap, Verifiable v, Verifier readCap ~ v) =>
     -- | Information about the servers from which to consider downloading shares
     -- representing the application data.
     Map.Map StorageServerID StorageServerAnnouncement ->
@@ -65,49 +66,35 @@ download ::
     LookupServer IO ->
     -- | Either a description of how the recovery failed or the recovered
     -- application data.
-    m (Either DownloadError LB.ByteString)
+    ExceptT DownloadError IO LB.ByteString
 download servers cap lookupServer = do
     print' ("Downloading: " <> show (getStorageIndex $ getVerifiable cap))
     let verifier = getVerifiable cap
     let storageIndex = getStorageIndex verifier
-    -- TODO: If getRequiredTotal fails on the first storage server, we may
-    -- need to try more.  If it fails for all of them, we need to represent
-    -- the failure coherently.
-    someParam <- liftIO $ firstRightM lookupServer (getRequiredTotal verifier) (Map.elems servers)
-    case someParam of
-        Left errs -> pure . Left $ if servers == mempty then NoConfiguredServers else NoReachableServers (StorageServerUnreachable <$> errs)
-        Right (required, _) -> do
-            locationE <- liftIO $ locateShares servers lookupServer storageIndex (fromIntegral required)
-            print' "Finished locating shares"
-            case locationE of
-                Left err -> do
-                    print' "Got an error locating shares"
-                    pure $ Left err
-                Right discovered -> do
-                    print' "Found some shares, fetching them"
-                    -- XXX note shares can contain failures
-                    shares <- liftIO $ executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered)
-                    print' "Fetched the shares, decoding them"
-                    s <- liftIO $ decodeShares cap shares required
-                    print' "Decoded them"
-                    pure s
+    (required, _) <- withExceptT noReachableServers (firstRightM lookupServer (getRequiredTotal verifier) (Map.elems servers))
+    print' "Discovered required number of shares"
+    discovered <- ExceptT $ locateShares servers lookupServer storageIndex (fromIntegral required)
+    print' "Finished locating shares, fetching"
+    shares <- liftIO $ executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered)
+    print' "Fetched the shares, decoding them"
+    ExceptT $ liftIO $ decodeShares cap shares required
+  where
+    noReachableServers = NoReachableServers . (StorageServerUnreachable <$>)
 
 {- | Apply a monadic operation to each element of a list and another monadic
  operation values in the resulting Rights.  If all of the results are Lefts or
  Nothings, return a list of the values in the Lefts.  Otherwise, return the
  *first* Right.
 -}
-firstRightM :: Monad m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> m (Either [b] d)
-firstRightM _ _ [] = pure $ Left []
+firstRightM :: Monad m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> ExceptT [b] m d
+firstRightM _ _ [] = throwError []
 firstRightM f op (x : xs) = do
-    s <- f x
+    s <- lift $ f x
     case s of
-        Left bs -> first (bs :) <$> recurse
+        Left bs -> (bs :) `withExceptT` recurse
         Right ss -> do
-            r <- op ss
-            case r of
-                Nothing -> recurse
-                Just d -> pure $ Right d
+            r <- lift $ op ss
+            maybe recurse pure r
   where
     recurse = firstRightM f op xs
 
@@ -232,7 +219,7 @@ downloadShare storageIndex (shareNum, s) = do
  as a collection of entries.
 -}
 downloadDirectory ::
-    (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) =>
+    (Readable readCap, Verifiable v, Verifier readCap ~ v) =>
     -- | Information about the servers from which to consider downloading shares
     -- representing the application data.
     Map.Map StorageServerID StorageServerAnnouncement ->
@@ -242,12 +229,10 @@ downloadDirectory ::
     LookupServer IO ->
     -- | Either a description of how the recovery failed or the recovered
     -- application data.
-    m (Either DirectoryDownloadError Directory)
+    ExceptT DirectoryDownloadError IO Directory
 downloadDirectory anns (DirectoryCapability cap) lookupServer = do
-    bs <- download anns cap lookupServer
-    pure $ do
-        bs' <- first UnderlyingDownloadError bs
-        first (const DecodingError) $ Directory.parse (LB.toStrict bs')
+    bs <- UnderlyingDownloadError `withExceptT` download anns cap lookupServer
+    ExceptT . pure . first (const DecodingError) . Directory.parse . LB.toStrict $ bs
 
 data DirectoryDownloadError
     = UnderlyingDownloadError DownloadError

test/Spec.hs

@@ -5,6 +5,7 @@ module Main where
 import Control.Exception (Exception, throwIO)
 import Control.Lens (view)
 import Control.Monad (replicateM, when)
+import Control.Monad.Except (MonadTrans (lift), runExceptT)
 import Control.Monad.IO.Class (liftIO)
 import Crypto.Cipher.AES (AES128)
 import Crypto.Cipher.Types (Cipher (cipherInit, cipherKeySize), KeySizeSpecifier (KeySizeEnum, KeySizeFixed, KeySizeRange), nullIV)
@@ -144,10 +145,10 @@ tests =
             $ do
                 -- If there are no servers then we can't possibly get enough
                 -- shares to recover the application data.
-                result <- liftIO $ download mempty (trivialCap 1 1) noServers
+                result <- runExceptT $ download mempty (trivialCap 1 1) noServers
                 assertEqual
                     "download should fail with no servers"
-                    (Left NoConfiguredServers)
+                    (Left (NoReachableServers []))
                     result
         , testCase "no reachable servers" $ do
             -- If we can't contact any configured server then we can't
@@ -158,7 +159,7 @@ tests =
                         [ ("v0-abc123", ann)
                         ]
 
-            result <- liftIO $ download anns (trivialCap 1 1) noServers
+            result <- runExceptT $ download anns (trivialCap 1 1) noServers
             assertEqual
                 "download should fail with no reachable servers"
                 (Left $ NoReachableServers [StorageServerUnreachable (URIParseError ann)])
@@ -179,7 +180,7 @@ tests =
             let openServer = simpleLookup [("somewhere", server)]
 
             -- Try to download the cap which requires three shares to reconstruct.
-            result <- liftIO $ download anns cap openServer
+            result <- runExceptT $ download anns cap openServer
             assertEqual
                 "download should fail with not enough shares"
                 (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
@@ -210,7 +211,7 @@ tests =
             let openServer = simpleLookup [("somewhere", somewhere), ("elsewhere", elsewhere)]
 
             -- Try to download the cap which requires three shares to reconstruct.
-            result <- liftIO $ download anns cap openServer
+            result <- runExceptT $ download anns cap openServer
             assertEqual
                 "download should fail with not enough shares"
                 (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
@@ -228,7 +229,7 @@ tests =
             let cap = trivialCap 3 13
 
             -- Try to download the cap which requires three shares to reconstruct.
-            result <- liftIO $ download anns cap openServer
+            result <- runExceptT $ download anns cap openServer
             assertEqual
                 "download should fail with details about unreachable server"
                 (Left (NoReachableServers [StorageServerCommunicationError "BespokeFailure"]))
@@ -291,7 +292,7 @@ tests =
 
             -- Try to download the cap which requires three shares to reconstruct.
 
-            result <- liftIO $ download anns cap openServer
+            result <- runExceptT $ download anns cap openServer
             assertEqual
                 "download should fail with details about unreachable server"
                 (Left (NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = 3, notEnoughDecodedSharesFound = 0}))
@@ -341,7 +342,7 @@ tests =
                     serverAnnouncements = Map.fromSet makeAnn serverIDs'
 
                 -- Recover the plaintext from the servers.
-                result <- liftIO $ download serverAnnouncements cap lookupServer
+                result <- lift $ runExceptT $ download serverAnnouncements cap lookupServer
                 diff (Right plaintext) (==) result
         , testProperty "ssk success" $
             property $ do
@@ -385,7 +386,7 @@ tests =
                     serverAnnouncements = Map.fromSet makeAnn serverIDs'
 
                 -- Recover the plaintext from the servers.
-                result <- liftIO $ download serverAnnouncements readCap lookupServer
+                result <- lift $ runExceptT $ download serverAnnouncements readCap lookupServer
                 diff (Right plaintext) (==) result
         , testCase "immutable upload/download to using Great Black Swamp" $ do
             pure ()