From fb1c168555efcdebbcff6f581b7c73b4ba873d7f Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Fri, 21 Apr 2023 14:57:08 -0400
Subject: [PATCH] start of attempts to adapt the gbs interface to what we know
how to work with
quite possibly both of these interfaces are wrong
may want to ponder them for a moment before proceeding
---
gbs-downloader.cabal | 6 +++
src/Tahoe/Download.hs | 89 +++++++++++++++++++++++++++++++++++++++++++
test/Spec.hs | 22 +++++++++++
3 files changed, 117 insertions(+)
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 8d37700..5b126bd 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -86,9 +86,15 @@ library
-- Other library packages from which modules are imported.
build-depends:
, base ^>=4.14.3.0
+ , base32
, binary
, bytestring
, containers
+ , exceptions
+ , http-client
+ , modern-uri
+ , servant-client
+ , servant-client-core
, tahoe-chk
, tahoe-great-black-swamp
, text
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 35d8718..bbc274e 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,19 +1,46 @@
+{-# LANGUAGE ViewPatterns #-}
+
{- | A high-level interface to downloading share data as bytes from storage
servers.
-}
module Tahoe.Download (LookupServer, DownloadError (..), discoverShares, download) where
+k with)
+
+module Tahoe.Download (
+ LookupServer,
+ DownloadError (..),
+ discoverOnce,
+ download,
+ gbsURLToStorageServer,
+) where
+import Control.Exception (throwIO)
+import Control.Monad.Catch (MonadCatch, catch)
+import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Binary (decodeOrFail)
import qualified Data.ByteString.Lazy as LB
import Data.Either (isRight, rights)
import Data.List (foldl')
+import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import Network.HTTP.Client (ManagerSettings, defaultManagerSettings, newManager)
+import Servant.Client (Scheme (Https), mkClientEnv, runClientM)
+import Servant.Client.Core (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
import qualified Tahoe.CHK.Encrypt
import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID, URL)
import Tahoe.CHK.Types (ShareNum, StorageIndex)
+import TahoeLAFS.Storage.API (ShareNumber (ShareNumber))
+import TahoeLAFS.Storage.Client (readImmutableShares)
+import Text.URI (Authority (Authority, authHost, authPort, authUserInfo), ParseException (ParseException), RText, URI (..), UserInfo (UserInfo, uiPassword, uiUsername), mkURI, unRText)
+
+-- | A view pattern for matching on the text of an RTest value.
+restrictedText :: RText l -> String
+restrictedText (T.unpack . unRText -> t) = t
{- | An unrecoverable problem arose while attempting to download and/or read
some application data.
@@ -51,6 +78,8 @@ data DownloadError
data DiscoverError
= -- | An announcement did not include a location for a connection attempt.
StorageServerLocationUnknown
+ | -- | An announcement included a location we could not interpret.
+ StorageServerLocationUnsupported
| StorageServerUnreachable
deriving (Eq, Ord, Show)
@@ -152,3 +181,63 @@ downloadShare storageIndex shareNum (s : _) = do
-- we might also need retry logic up a level or two from here.
shareBytes <- storageServerRead s storageIndex shareNum
pure (shareNum, Right $ LB.fromStrict shareBytes)
+
+gbsURLToStorageServer :: (MonadIO m, MonadCatch m) => T.Text -> m (Maybe StorageServer)
+gbsURLToStorageServer url =
+ catch (mkURI url >>= makeServer) (\ParseException{} -> pure Nothing)
+
+makeServer :: MonadIO m => URI -> m (Maybe StorageServer)
+makeServer
+ URI
+ { uriScheme = Just (restrictedText -> "pb")
+ , uriAuthority =
+ Right
+ ( Authority
+ { authUserInfo =
+ Just
+ ( UserInfo
+ { uiUsername = tubid
+ , uiPassword = Nothing
+ }
+ )
+ , authHost = host
+ , authPort = Just port
+ }
+ )
+ , uriPath = Just (False, swissnum :| [])
+ , uriQuery = []
+ , uriFragment = Just (restrictedText -> "v=1")
+ } =
+ do
+ manager <- liftIO $ newManager (managerSettingsForService (unRText tubid) (unRText swissnum))
+
+ let baseUrl = https (T.unpack $ unRText host) (fromIntegral port)
+ env = mkClientEnv manager baseUrl
+
+ storageServerID = undefined
+
+ storageServerWrite = undefined
+
+ storageServerRead storageIndex shareNum = do
+ let clientm = readImmutableShares (T.unpack $ decodeUtf8 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+ res <- runClientM clientm env
+ case res of
+ Left err -> throwIO err
+ Right bs -> pure bs
+
+ storageServerGetBuckets = undefined
+
+ pure $ Just StorageServer{..}
+makeServer _ = pure Nothing
+
+https :: String -> Int -> BaseUrl
+https host port =
+ BaseUrl
+ { baseUrlScheme = Https
+ , baseUrlHost = host
+ , baseUrlPort = port
+ , baseUrlPath = "/"
+ }
+
+managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
+managerSettingsForService _ _ = defaultManagerSettings
diff --git a/test/Spec.hs b/test/Spec.hs
index f254790..7751682 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -196,6 +196,28 @@ tests =
-- Recover the plaintext from the servers.
result <- liftIO $ download serverAnnouncements cap lookupServer
diff (Right plaintext) (==) result
+ , testCase "immutable upload/download to using Great Black Swamp" $ do
+ pure ()
+ -- Consider moving these tests to another module, they're pretty
+ -- different and there's quite a handful of them.
+ --
+ -- SUCCESS CASE
+ -- Make an in-memory GBS backend
+ -- Encode some data to shares
+ -- Store the shares on the backend
+ -- Wrap an HTTPS server around the backend
+ -- Get its FURL
+ -- Make an announcement for it
+ -- Give the announcement and the cap to the download function
+ -- Assert we recovered the plaintext
+ --
+ -- ERROR CASES
+ -- Server address unresolveable
+ -- Server address unconnectable
+ -- Server times out
+ -- Server presents incorrect TLS certificate
+ -- Server returns error response to our request
+ -- Server returns tampered share data
]
where
-- A server lookup function that always fails.
--
GitLab