diff --git a/CHANGELOG.md b/CHANGELOG.md
index 70ee44bba3095f597016b6ca4f7a6ddf8be2a5a0..89f37bd8727fde3c24415a250174fcc2d52af226 100644
--- a/CHANGELOG.md
+++ b/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.
diff --git a/app/Main.hs b/app/Main.hs
index 157e0186750e0a957a19e66e419fb7cc993c332d..95edf3fc786f0447f00f74ec3fa092977dfd7542 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,6 @@
module Main where
+import Control.Monad.Except (runExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
@@ -22,7 +23,7 @@ main = do
let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap)
-- Download & decode the shares
- result <- download announcements cap announcementToImmutableStorageServer
+ result <- runExceptT $ download announcements cap announcementToImmutableStorageServer
-- Show the result
putStrLn "Your result:"
diff --git a/download-sdmf/Main.hs b/download-sdmf/Main.hs
index 6078709a3bf36d0f5d149cc80228b2e152ecd48b..1f38473e57a6346cc3a4414703747545deb74550 100644
--- a/download-sdmf/Main.hs
+++ b/download-sdmf/Main.hs
@@ -1,36 +1,43 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
module Main where
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as BL
+import Control.Monad.Except (ExceptT (ExceptT), MonadTrans (lift), runExceptT, withExceptT)
+import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text as T
-import Data.Yaml (decodeEither')
+import Data.Yaml (decodeFileEither)
import System.Environment (getArgs)
import Tahoe.Announcement (Announcements (..))
import Tahoe.Download (announcementToMutableStorageServer, download)
-import Tahoe.SDMF (SDMF (..), pCapability, writerReader)
+import Tahoe.SDMF (Reader, SDMF (..), pCapability, writerReader)
import Text.Megaparsec (parse)
+newtype Failed = Failed String
+
+instance Show Failed where
+ show (Failed s) = s
+
main :: IO ()
-main = do
- [announcementPath, readCap] <- getArgs
- -- Load server announcements
- announcementsBytes <- B.readFile announcementPath
- let Right (Announcements announcements) = decodeEither' announcementsBytes
-
- -- Accept & parse read capability
- case parse pCapability "<argv>" (T.pack readCap) of
- Left e -> print $ "Failed to parse cap: " <> show e
- Right (SDMFVerifier _) -> C8.putStrLn "Nothing currently implemented for verifier caps."
- Right (SDMFWriter rwcap) -> go announcements (writerReader rwcap)
- Right (SDMFReader rocap) -> go announcements rocap
+main =
+ either (putStrLn . ("Failed: " <>) . show) (BL.putStrLn . BL.append "Your result: ")
+ =<< ( runExceptT $
+ do
+ [announcementPath, readCap] <- lift getArgs
+
+ -- Load server announcements
+ announcements <- mightFail "Failed to parse announcements: " $ decodeFileEither announcementPath
+
+ -- Parse read capability
+ (mightFail "Failed to parse capability: " . pure . parse pCapability "<argv>" . T.pack) readCap
+ >>= \case
+ SDMFVerifier _ -> ExceptT . pure . Left . Failed $ "Nothing implemented for verifier capabilities."
+ SDMFWriter rwcap -> go announcements (writerReader rwcap)
+ SDMFReader rocap -> go announcements rocap
+ )
where
- go announcements cap = do
- -- Download & decode the shares
- result <- download announcements cap announcementToMutableStorageServer
+ go :: Announcements -> Reader -> ExceptT Failed IO BL.ByteString
+ go (Announcements announcements) cap = withExceptT (Failed . ("Failed download: " <>) . show) $ download announcements cap announcementToMutableStorageServer
- -- Show the result
- putStrLn "Your result:"
- either print (C8.putStrLn . BL.toStrict) result
+mightFail :: (Functor m, Show a1) => String -> m (Either a1 a2) -> ExceptT Failed m a2
+mightFail s = withExceptT (Failed . (s <>) . show) . ExceptT
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index ee59009836230a852db53248c9e5bcaf2cc84042..eebb17bc3965347a402a3961b909d77894c4a55c 100644
--- a/gbs-downloader.cabal
+++ b/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 >=2.2.2 && <2.4
, network-uri >=2.6.3 && <2.7
, servant-client >=0.16.0.1 && <0.21
, servant-client-core >=0.16 && <0.21
@@ -157,6 +158,7 @@ executable download-chk
, containers >=0.6.0.1 && <0.7
, gbs-downloader
, megaparsec >=8.0 && <9.3
+ , mtl >=2.2.2 && <2.4
, tahoe-chk >=0.2 && <0.3
, text >=1.2.3.1 && <1.3
, yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
@@ -180,6 +182,7 @@ executable download-sdmf
, containers >=0.6.0.1 && <0.7
, gbs-downloader
, megaparsec >=8.0 && <9.3
+ , mtl >=2.2.2 && <2.4
, tahoe-ssk >=0.3 && <0.4
, text >=1.2.3.1 && <1.3
, yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
@@ -200,6 +203,7 @@ executable list-dircap
, containers >=0.6.0.1 && <0.7
, gbs-downloader
, megaparsec >=8.0 && <9.3
+ , mtl >=2.2.2 && <2.4
, tahoe-chk >=0.2 && <0.3
, tahoe-directory >=0.1 && <0.2
, tahoe-ssk >=0.3 && <0.4
@@ -249,6 +253,7 @@ test-suite gbs-downloader-test
, http-types >=0.12.3 && <0.13
, lens >=4.0 && <5.3
, memory >=0.15 && <0.17
+ , mtl >=2.2.2 && <2.4
, servant-client >=0.16.0.1 && <0.21
, servant-client-core >=0.16 && <0.21
, tahoe-chk >=0.2 && <0.3
diff --git a/list-dircap/Main.hs b/list-dircap/Main.hs
index c0adc747c73d34ba882233bf596f445a44d37074..a050462180c8b45e49f4c8a084fc3cb5563b1a88 100644
--- a/list-dircap/Main.hs
+++ b/list-dircap/Main.hs
@@ -10,6 +10,7 @@ import Tahoe.Announcement (Announcements (..))
import qualified Tahoe.Directory as TD
import Text.Megaparsec (parse)
+import Control.Monad.Except (runExceptT)
import Tahoe.Download (announcementToImmutableStorageServer, announcementToMutableStorageServer, downloadDirectory)
main :: IO ()
@@ -30,7 +31,7 @@ main = do
where
go announcements cap lookupServer = do
-- Download & decode the shares
- result <- downloadDirectory announcements cap lookupServer
+ result <- runExceptT $ downloadDirectory announcements cap lookupServer
-- Show the result
putStrLn "Your result:"
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 4f0f41f55ef0f5354c4dcd0efbb46872065073e1..b7febdf8d3d470d3b690c5712af4191f07345791 100644
--- a/src/Tahoe/Download.hs
+++ b/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
diff --git a/test/Spec.hs b/test/Spec.hs
index c5ba7736b431e7b185fc5cd529ba8799af27fc4a..269248fdae0a5c7eacbe24e03c75ec6186773124 100644
--- a/test/Spec.hs
+++ b/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 ()