From 36b7be28ade9c89ba66b1d531c9b273765876d2c Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Tue, 10 Oct 2023 12:27:19 -0400
Subject: [PATCH] Use runGBS from tahoe-great-black-swamp instead of rolling
our own
As a bonus, runGBS authenticates the server for us.
---
CHANGELOG.md | 5 ++++
README.md | 2 +-
gbs-downloader.cabal | 2 +-
src/Tahoe/Download/Internal/Client.hs | 33 ++++++++-------------------
4 files changed, 17 insertions(+), 25 deletions(-)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 5600cc9..70ee44b 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,10 @@
# Revision history for gbs-downloader
+## 0.2.0.0 -- YYYY-MM-DD
+
+* The download APIs now only send requests to a storage server after that
+ storage server is authenticated using information from the NURL.
+
## 0.1.0.0 -- 2023-08-17
* First version. Released on an unsuspecting world.
diff --git a/README.md b/README.md
index 56fb223..2d54769 100644
--- a/README.md
+++ b/README.md
@@ -8,7 +8,7 @@ It aims for bit-for-bit compatibility with the original Python implementation.
### What is the current state?
* It can download immutable and mutable shares from Great Black Swamp storage servers.
- * It *does not* cryptographically verify the identity of servers it communicates with.
+ * It cryptographically verifies the identity of servers it communicates with.
* It can interpret, decode, and decrypt the data for CHK- and SDMF-encoded shares to recover the plaintext.
## Why does it exist?
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index dbd75c3..ee59009 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -123,7 +123,7 @@ library
, servant-client-core >=0.16 && <0.21
, tahoe-chk >=0.2 && <0.3
, tahoe-directory >=0.1 && <0.2
- , tahoe-great-black-swamp >=0.3 && <0.4
+ , tahoe-great-black-swamp >=0.3.1 && <0.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
diff --git a/src/Tahoe/Download/Internal/Client.hs b/src/Tahoe/Download/Internal/Client.hs
index 43cc02e..76865c2 100644
--- a/src/Tahoe/Download/Internal/Client.hs
+++ b/src/Tahoe/Download/Internal/Client.hs
@@ -15,13 +15,14 @@ import Network.Connection
import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
import Network.HTTP.Client.TLS
import Network.HTTP.Types (ByteRange)
+import Network.URI (uriToString)
import Servant.Client
import Tahoe.Announcement
import Tahoe.CHK.Server (
StorageServer (..),
)
import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
-import Text.Read (readMaybe)
+import TahoeLAFS.Storage.Client (NURL, parseNURL, runGBS)
-- | Make an HTTPS URL.
https :: String -> Int -> BaseUrl
@@ -138,12 +139,10 @@ type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteStr
{- | Create a StorageServer that will speak Great Black Swamp using the given
manager to the server at the given host/port.
-}
-mkWrapper :: GetShareNumbers -> ReadShare -> Manager -> [Char] -> Int -> StorageServer
-mkWrapper getShareNumbers readShare manager host realPort =
+mkWrapper :: GetShareNumbers -> ReadShare -> NURL -> StorageServer
+mkWrapper getShareNumbers readShare nurl =
StorageServer{..}
where
- baseUrl = https host realPort
- env = mkClientEnv manager baseUrl
toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
storageServerID = undefined
@@ -152,7 +151,7 @@ mkWrapper getShareNumbers readShare manager host realPort =
storageServerRead storageIndex shareNum = do
let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
- res <- runClientM clientm env
+ res <- runGBS nurl clientm
case res of
Left err -> do
throwIO err
@@ -160,7 +159,7 @@ mkWrapper getShareNumbers readShare manager host realPort =
storageServerGetBuckets storageIndex = do
let clientm = getShareNumbers (toBase32 storageIndex)
- r <- try $ runClientM clientm env
+ r <- try $ runGBS nurl clientm
case r of
Left (_ :: SomeException) -> do
pure mempty
@@ -174,22 +173,10 @@ mkWrapper getShareNumbers readShare manager host realPort =
on the server at the given URI.
-}
makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer)
-makeServer
- getShareNumbers
- readShare
- URI
- { uriScheme = "pb:"
- , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)}
- , uriPath = ('/' : swissnum)
- , uriFragment = "" -- It's a fURL, not a NURL, so there's no fragment.
- } =
- case readMaybe port of
- Nothing -> pure . Left . PortParseError $ port
- Just realPort -> do
- manager <- liftIO $ newGBSManager tubid swissnum
-
- pure . Right $ mkWrapper getShareNumbers readShare manager host realPort
-makeServer _ _ _ = pure . Left $ AnnouncementStructureUnmatched
+makeServer getShareNumbers readShare uri =
+ pure $ case parseNURL (T.pack $ uriToString id uri "") of
+ Nothing -> Left AnnouncementStructureUnmatched
+ Just nurl -> Right $ mkWrapper getShareNumbers readShare nurl
announcementToStorageServer :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer)
announcementToStorageServer getShareNumbers readShare ann =
--
GitLab