From 5c2384ff4d4752a3fadf08b56fd370c778153dbf Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Thu, 1 Jun 2023 13:27:47 -0400
Subject: [PATCH] Add a `lookupServer` for mutables
This is clunky but it works ... for now.
---
gbs-downloader.cabal | 2 +
src/Tahoe/Download.hs | 2 +
src/Tahoe/Download/Internal/Client.hs | 75 ++++++++++++++++++++-
src/Tahoe/Download/Internal/Immutable.hs | 84 +++---------------------
src/Tahoe/Download/Internal/Mutable.hs | 15 +++++
5 files changed, 102 insertions(+), 76 deletions(-)
create mode 100644 src/Tahoe/Download/Internal/Mutable.hs
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 842eb28..908ee89 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -84,6 +84,7 @@ library
Tahoe.Download.Internal.Capability
Tahoe.Download.Internal.Client
Tahoe.Download.Internal.Immutable
+ Tahoe.Download.Internal.Mutable
-- Modules included in this library but not exported.
-- other-modules:
@@ -105,6 +106,7 @@ library
, exceptions
, http-client
, http-client-tls
+ , http-types
, network-uri
, servant-client
, servant-client-core
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 19a7a46..93488ce 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -11,6 +11,7 @@ module Tahoe.Download (
discoverShares,
download,
announcementToImmutableStorageServer,
+ announcementToMutableStorageServer,
getShareNumbers,
) where
@@ -30,6 +31,7 @@ import Tahoe.CHK.Types (ShareNum, StorageIndex)
import Tahoe.Download.Internal.Capability
import Tahoe.Download.Internal.Client
import Tahoe.Download.Internal.Immutable
+import Tahoe.Download.Internal.Mutable
-- | Partially describe one share download.
type DownloadTask = (ShareNum, StorageServer)
diff --git a/src/Tahoe/Download/Internal/Client.hs b/src/Tahoe/Download/Internal/Client.hs
index 4b81131..43cc02e 100644
--- a/src/Tahoe/Download/Internal/Client.hs
+++ b/src/Tahoe/Download/Internal/Client.hs
@@ -3,19 +3,25 @@
-}
module Tahoe.Download.Internal.Client where
+import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString as B
+import Data.ByteString.Base32
import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding
import Network.Connection
-import Network.HTTP.Client
+import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
import Network.HTTP.Client.TLS
+import Network.HTTP.Types (ByteRange)
import Servant.Client
import Tahoe.Announcement
import Tahoe.CHK.Server (
- StorageServer,
+ StorageServer (..),
)
+import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
+import Text.Read (readMaybe)
-- | Make an HTTPS URL.
https :: String -> Int -> BaseUrl
@@ -125,3 +131,68 @@ data LookupError
representation of some value.
-}
data DeserializeError = UnknownDeserializeError -- add more later?
+
+type GetShareNumbers = String -> ClientM (CBORSet ShareNumber)
+type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteString
+
+{- | 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 =
+ StorageServer{..}
+ where
+ baseUrl = https host realPort
+ env = mkClientEnv manager baseUrl
+ toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
+
+ storageServerID = undefined
+
+ storageServerWrite = undefined
+
+ storageServerRead storageIndex shareNum = do
+ let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+ res <- runClientM clientm env
+ case res of
+ Left err -> do
+ throwIO err
+ Right bs -> pure bs
+
+ storageServerGetBuckets storageIndex = do
+ let clientm = getShareNumbers (toBase32 storageIndex)
+ r <- try $ runClientM clientm env
+ case r of
+ Left (_ :: SomeException) -> do
+ pure mempty
+ Right res -> do
+ case res of
+ Left err -> do
+ throwIO err
+ Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
+
+{- | If possible, populate a StorageServer with functions for operating on data
+ 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
+
+announcementToStorageServer :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer)
+announcementToStorageServer getShareNumbers readShare ann =
+ case greatBlackSwampURIs ann of
+ Nothing -> pure . Left . URIParseError $ ann
+ Just uri -> makeServer getShareNumbers readShare uri
diff --git a/src/Tahoe/Download/Internal/Immutable.hs b/src/Tahoe/Download/Internal/Immutable.hs
index f7c9cb8..00b7efb 100644
--- a/src/Tahoe/Download/Internal/Immutable.hs
+++ b/src/Tahoe/Download/Internal/Immutable.hs
@@ -1,79 +1,15 @@
-- | Functionality related to retrieving "immutable" shares (mainly CHK).
module Tahoe.Download.Internal.Immutable where
-import Control.Exception
-import Control.Monad.IO.Class
-import Data.ByteString.Base32
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import Network.HTTP.Client (Manager)
-import Servant.Client
-import Tahoe.Announcement
-import Tahoe.CHK.Server (StorageServer (..))
-import Tahoe.Download.Internal.Client
-import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
-import TahoeLAFS.Storage.Client
-import Text.Read (readMaybe)
-
-{- | Create a StorageServer that will speak Great Black Swamp using the given
- manager to the server at the given host/port.
--}
-mkImmutableWrapper :: Manager -> [Char] -> Int -> StorageServer
-mkImmutableWrapper manager host realPort =
- StorageServer{..}
- where
- baseUrl = https host realPort
- env = mkClientEnv manager baseUrl
- toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
-
- storageServerID = undefined
-
- storageServerWrite = undefined
-
- storageServerRead storageIndex shareNum = do
- let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
- res <- runClientM clientm env
- case res of
- Left err -> do
- throwIO err
- Right bs -> pure bs
-
- storageServerGetBuckets storageIndex = do
- let clientm = getImmutableShareNumbers (toBase32 storageIndex)
- r <- try $ runClientM clientm env
- case r of
- Left (_ :: SomeException) -> do
- pure mempty
- Right res -> do
- case res of
- Left err -> do
- throwIO err
- Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
-
-{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
- a Great Black Swamp server.
+import Control.Monad.IO.Class (MonadIO)
+import Tahoe.Announcement (StorageServerAnnouncement)
+import Tahoe.CHK.Server (StorageServer)
+import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer)
+import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
+
+{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a
+ Great Black Swamp server and construct a StorageServer for interacting with
+ immutable shares stored on it.
-}
announcementToImmutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
-announcementToImmutableStorageServer ann =
- case greatBlackSwampURIs ann of
- Nothing -> pure . Left . URIParseError $ ann
- Just uri -> makeImmutableServer uri
-
-{- | If possible, populate a StorageServer with functions for operating on
- immutable data on the server at the given URI.
--}
-makeImmutableServer :: MonadIO m => URI -> m (Either LookupError StorageServer)
-makeImmutableServer
- 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 $ mkImmutableWrapper manager host realPort
-makeImmutableServer _ = pure . Left $ AnnouncementStructureUnmatched
+announcementToImmutableStorageServer = announcementToStorageServer getImmutableShareNumbers readImmutableShare
diff --git a/src/Tahoe/Download/Internal/Mutable.hs b/src/Tahoe/Download/Internal/Mutable.hs
new file mode 100644
index 0000000..011e601
--- /dev/null
+++ b/src/Tahoe/Download/Internal/Mutable.hs
@@ -0,0 +1,15 @@
+-- | Functionality related to retrieving "mutable" shares (for example, SDMF).
+module Tahoe.Download.Internal.Mutable where
+
+import Control.Monad.IO.Class (MonadIO)
+import Tahoe.Announcement (StorageServerAnnouncement)
+import Tahoe.CHK.Server (StorageServer)
+import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer)
+import TahoeLAFS.Storage.Client (getMutableShareNumbers, readMutableShares)
+
+{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a
+ Great Black Swamp server and construct a StorageServer for interacting with
+ mutable shares stored on it.
+-}
+announcementToMutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
+announcementToMutableStorageServer = announcementToStorageServer getMutableShareNumbers readMutableShares
--
GitLab