From 575fe571aa33bdaa1cc4e96b19482eb10d00f32a Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Tue, 30 May 2023 13:05:26 -0400
Subject: [PATCH] wip some steps towards StorageServer/StorageClient
refactoring
---
gbs-downloader.cabal | 1 +
src/Tahoe/Client.hs | 138 ++++++++++++++++++++++++++++++++++++++++
src/Tahoe/Download.hs | 143 +++---------------------------------------
3 files changed, 147 insertions(+), 135 deletions(-)
create mode 100644 src/Tahoe/Client.hs
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index c6a8896..ef28645 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -80,6 +80,7 @@ library
-- Modules exported by the library.
exposed-modules:
Tahoe.Announcement
+ Tahoe.Client
Tahoe.Download
-- Modules included in this library but not exported.
diff --git a/src/Tahoe/Client.hs b/src/Tahoe/Client.hs
new file mode 100644
index 0000000..e23de90
--- /dev/null
+++ b/src/Tahoe/Client.hs
@@ -0,0 +1,138 @@
+module Tahoe.Client where
+
+import Control.Exception (SomeException (SomeException))
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
+import Network.URI (URI (URI, uriAuthority, uriFragment, uriPath, uriScheme), URIAuth (URIAuth, uriPort, uriRegName, uriUserInfo))
+import Servant.Client (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
+import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
+import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
+import Text.Read (readMaybe)
+
+-- | There was a problem while trying to look up a server from its announcement.
+data LookupError
+ = -- | The server's announced URI was unparseable.
+ URIParseError StorageServerAnnouncement
+ | -- | The port integer in the server's URI was unparseable.
+ PortParseError String
+ | -- | The structure of the server's URI was unparseable.
+ AnnouncementStructureUnmatched
+ deriving (Eq, Ord, Show)
+
+data StorageClient = StorageClient
+ { storageClientManager :: Manager
+ , storageClientBaseUrl :: BaseUrl
+ }
+
+makeGBSManager :: MonadIO m => URI -> m (Either LookupError Manager)
+makeGBSManager
+ 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 <- newGBSManager tubid swissnum
+ wrapGreatBlackSwamp
+
+-- | Make a manager suitable for use with a Great Black Swamp server.
+newGBSManager ::
+ MonadIO m =>
+ [Char] ->
+ String ->
+ m Manager
+newGBSManager tubid swissnum =
+ newTlsManagerWith $
+ managerSettingsForService
+ (T.pack . init $ tubid)
+ (T.pack swissnum)
+
+-- pure . Right $ wrapGreatBlackSwamp manager host realPort
+-- makeServer _ = pure . Left $ AnnouncementStructureUnmatched
+
+-- Parameterize readImmutableShare and getImmutableShareNumbers to
+-- wrapGreatBlackSwamp, then use it for both mutables and immutables. Then
+-- use the same download function for both!
+
+{- | Create a StorageClient that will speak Great Black Swamp using the given
+ manager to the server at the given host/port.
+-}
+wrapGreatBlackSwamp :: [Char] -> Int -> Manager -> StorageServer
+wrapGreatBlackSwamp host realPort manager =
+ StorageClient{..}
+ 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 -> throwIO err
+ Right bs -> pure bs
+
+ storageServerGetBuckets storageIndex = do
+ let clientm = getImmutableShareNumbers (toBase32 storageIndex)
+ print' "Going to get share numbers"
+ r <- try $ runClientM clientm env
+ case r of
+ Left (err :: SomeException) -> do
+ pure mempty
+ Right res -> do
+ case res of
+ Left err -> throwIO err
+ Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
+
+-- | Make an HTTPS URL.
+https :: String -> Int -> BaseUrl
+https host port =
+ BaseUrl
+ { baseUrlScheme = Https
+ , baseUrlHost = host
+ , baseUrlPort = port
+ , baseUrlPath = ""
+ }
+
+{- | Make an HTTPS manager for the given SPKI hash and swissnum.
+
+ The SPKI hash is _not_ used to authenticate the server! See
+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
+-}
+managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
+managerSettingsForService _ swissnum =
+ (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}
+ 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"
+ , headerCompleteBytes
+ ) :
+ requestHeaders req
+ }
+
+{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
+ a Great Black Swamp server.
+-}
+announcementToStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
+announcementToStorageServer ann =
+ case greatBlackSwampURIs ann of
+ Nothing -> pure . Left . URIParseError $ ann
+ Just uri -> makeServer uri
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 5b25fd3..629e977 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -36,8 +36,8 @@ import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
import qualified Tahoe.CHK.Encrypt
-import Tahoe.CHK.Server (StorageServer (..), StorageServerID)
import Tahoe.CHK.Types (ShareNum, StorageIndex)
+import Tahoe.Client (StorageClient (..), StorageServerID)
import qualified Tahoe.SDMF as SDMF
import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
@@ -48,7 +48,7 @@ print' :: MonadIO m => String -> m ()
print' = const $ pure ()
-- | Partially describe one share download.
-type DownloadTask = (ShareNum, StorageServer)
+type DownloadTask = (ShareNum, StorageClient)
-- | A downloaded share
type Share = (ShareNum, LB.ByteString)
@@ -102,25 +102,22 @@ data DiscoverError
-}
type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
-downloadMutable :: MonadIO m => Map.Map StorageServerID StorageServerAnnouncement -> SDMF.Reader -> LookupServer m -> m (Either DownloadError LB.ByteString)
-downloadMutable = undefined
-
{- | Recover the application data associated with a given capability from the
given servers, if possible.
-}
download ::
- MonadIO m =>
+ (ReadCapability r, MonadIO m) =>
-- | Information about the servers from which to consider downloading shares
-- representing the application data.
Map.Map StorageServerID StorageServerAnnouncement ->
-- | The read capability for the application data.
- Reader ->
+ r ->
-- | Get functions for interacting with a server given its URL.
LookupServer m ->
-- | Either a description of how the recovery failed or the recovered
-- application data.
m (Either DownloadError LB.ByteString)
-download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
+download servers cap lookupServer = do
print' ("Going to download: " <> show storageIndex)
locationE <- locateShares servers lookupServer storageIndex required
print' "Finished locating shares"
@@ -263,130 +260,6 @@ downloadShare storageIndex (shareNum, s) = do
print' "Downloaded it"
pure (shareNum, LB.fromStrict <$> massaged)
--- | There was a problem while trying to look up a server from its announcement.
-data LookupError
- = -- | The server's announced URI was unparseable.
- URIParseError StorageServerAnnouncement
- | -- | The port integer in the server's URI was unparseable.
- PortParseError String
- | -- | The structure of the server's URI was unparseable.
- AnnouncementStructureUnmatched
- deriving (Eq, Ord, Show)
-
-{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
- a Great Black Swamp server.
--}
-announcementToStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
-announcementToStorageServer ann =
- case greatBlackSwampURIs ann of
- Nothing -> pure . Left . URIParseError $ ann
- Just uri -> makeServer uri
-
-makeServer :: MonadIO m => URI -> m (Either LookupError StorageServer)
-makeServer
- 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
- print' "Going to make a GBS manager"
- manager <- liftIO $ newGBSManager tubid swissnum
- print' "Made it"
-
- pure . Right $ wrapGreatBlackSwamp manager host realPort
-makeServer _ = pure . Left $ AnnouncementStructureUnmatched
-
--- Parameterize readImmutableShare and getImmutableShareNumbers to
--- wrapGreatBlackSwamp, then use it for both mutables and immutables. Then
--- use the same download function for both!
-
-{- | Create a StorageServer that will speak Great Black Swamp using the given
- manager to the server at the given host/port.
--}
-wrapGreatBlackSwamp :: Manager -> [Char] -> Int -> StorageServer
-wrapGreatBlackSwamp 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
- print' "Going to read from a server"
- res <- runClientM clientm env
- print' "Did it"
- case res of
- 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)
- 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!!
-
--- | Make an HTTPS URL.
-https :: String -> Int -> BaseUrl
-https host port =
- BaseUrl
- { baseUrlScheme = Https
- , baseUrlHost = host
- , baseUrlPort = port
- , baseUrlPath = ""
- }
-
-{- | Make an HTTPS manager for the given SPKI hash and swissnum.
-
- The SPKI hash is _not_ used to authenticate the server! See
- https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
--}
-managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
-managerSettingsForService _ swissnum =
- (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}
- 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"
- , headerCompleteBytes
- ) :
- requestHeaders req
- }
-
--- | Make a manager suitable for use with a Great Black Swamp server.
-newGBSManager ::
- MonadIO m =>
- [Char] ->
- String ->
- m Manager
-newGBSManager tubid swissnum =
- newTlsManagerWith $
- managerSettingsForService
- (T.pack . init $ tubid)
- (T.pack swissnum)
+class ReadCapability r s | r -> s where
+ storageIndex :: r -> StorageIndex
+ decode :: LB.ByteString -> Maybe s
--
GitLab