diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 71d08e5765f5189c09c65c5dbe767441e86a9586..ab7a6bcd49b43a16929d22be87c92ebf69eea0d1 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -1,4 +1,4 @@
-cabal-version: 3.0
+cabal-version: 2.4
-- The cabal-version field refers to the version of the .cabal specification,
-- and can be different from the cabal-install (the tool) version and the
@@ -88,9 +88,9 @@ library
-- Other library packages from which modules are imported.
build-depends:
, aeson
- , base ^>=4.14.3.0
+ , base
, base32
- , base64
+ , base64-bytestring
, binary
, bytestring
, connection
@@ -130,7 +130,7 @@ executable gbs-download
-- Other library packages from which modules are imported.
build-depends:
, aeson
- , base ^>=4.14.3.0
+ , base
, bytestring
, containers
, gbs-downloader
@@ -168,7 +168,7 @@ test-suite gbs-downloader-test
-- Test dependencies.
build-depends:
- , base ^>=4.14.3.0
+ , base
, base32
, binary
, bytestring
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 58d933e15a92f0955082af31867b9de2a40283d9..bd44f3cedd0b64419cc69f09664af15273aa0b66 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -14,12 +14,12 @@ module Tahoe.Download (
announcementToStorageServer,
) where
-import Control.Exception (throwIO)
+import Control.Exception (SomeException, throwIO, try)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Binary (Word16, decodeOrFail)
import qualified Data.ByteString as B
import Data.ByteString.Base32 (encodeBase32Unpadded)
-import Data.ByteString.Base64 (encodeBase64)
+import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as LB
import Data.Either (isRight, partitionEithers)
import Data.List (foldl')
@@ -43,6 +43,9 @@ import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
import Text.Read (readMaybe)
+print' :: MonadIO m => String -> m ()
+print' = liftIO . print
+
{- | An unrecoverable problem arose while attempting to download and/or read
some application data.
-}
@@ -105,13 +108,21 @@ download ::
-- application data.
m (Either DownloadError LB.ByteString)
download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
+ print' ("Going to download: " <> show storageIndex)
locationE <- locateShares servers lookupServer storageIndex required
+ print' "Finished locating shares"
case locationE of
- Left err -> pure $ Left err
+ 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 <- fetchShares storageIndex discovered
- decodeShares cap shares
+ print' "Fetched the shares, decoding them"
+ s <- decodeShares cap shares
+ print' "Decoded them"
+ pure s
-- | Find out which servers claim to have shares related to a given storage index.
locateShares ::
@@ -132,6 +143,7 @@ locateShares servers lookupServer storageIndex required =
case Map.toList servers of
[] -> pure . Left $ NoConfiguredServers
serverList -> do
+ print' "Discovering shares"
-- Ask each server for all shares it has.
( problems :: [DiscoverError]
, discovered :: [(StorageServer, Set.Set ShareNum)]
@@ -154,8 +166,11 @@ fetchShares ::
-- | The guide to where shares are placed.
[(StorageServer, Set.Set ShareNum)] ->
m [(ShareNum, Either DownloadError LB.ByteString)]
-fetchShares storageIndex discovered =
- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+fetchShares storageIndex discovered = do
+ print' "Fetching shares"
+ s <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+ print' "Fetched shares"
+ pure s
where
sharemap = makeShareMap discovered
@@ -177,7 +192,9 @@ decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares =
in if length onlyDecoded < fromIntegral required
then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
else do
+ print' "Interpreted shares, decoding them"
ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
+ print' "Decoded them, might decrypt them"
case ciphertext of
Nothing -> pure $ Left ShareDecodingFailed
Just ct ->
@@ -199,11 +216,16 @@ discoverShares ::
(StorageServerID, StorageServerAnnouncement) ->
m (Either DiscoverError (StorageServer, Set.Set ShareNum))
discoverShares lookupServer storageIndex (_sid, sann) = do
+ print' "Looking up server from announcement"
server <- lookupServer sann
+ print' "Looked it up"
case server of
Left e -> pure . Left . StorageServerUnreachable $ e
- Right ss@StorageServer{storageServerGetBuckets} ->
- liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
+ 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
{- | 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.
@@ -232,7 +254,9 @@ 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.
+ print' $ "Going to download " <> show storageIndex <> " " <> show shareNum
shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
+ print' "Downloaded it"
pure (shareNum, Right $ LB.fromStrict shareBytes)
data LookupError
@@ -258,7 +282,9 @@ makeServer
case readMaybe port of
Nothing -> pure . Left . PortParseError $ port
Just realPort -> do
+ print' "Going to make a GBS manager"
manager <- liftIO $ newGBSManager tubid swissnum
+ print' "Made it"
let baseUrl = https host realPort
env = mkClientEnv manager baseUrl
@@ -270,17 +296,30 @@ makeServer
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 -> throwIO err
+ 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)
- res <- runClientM clientm env
- case res of
- Left err -> throwIO err
- Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
+ 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
@@ -299,11 +338,14 @@ managerSettingsForService _ swissnum =
where
tlsSettings = TLSSettingsSimple True True True
sockSettings = Nothing
+ swissnumBytes = encodeUtf8 swissnum
+ swissnumBase64 = Base64.encode swissnumBytes
+ headerCompleteBytes = B.concat ["Tahoe-LAFS ", swissnumBase64]
authorize req =
req
{ requestHeaders =
( "Authorization"
- , encodeUtf8 $ T.concat ["Tahoe-LAFS ", encodeBase64 . encodeUtf8 $ swissnum]
+ , headerCompleteBytes
) :
requestHeaders req
}