diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 8d377001b6a0f7437ef008f13a615b2108909641..5b126bd93b13b65cec45629a24f471954804dbf2 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 35d87188f5fb56222b3472f4d82df21e24d8d83f..bbc274e0584bda83de06e5256c75878fd0f2df17 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 f2547908dc60bdaab1ccc29623c844c2f6a05fe1..7751682e367171dbafcdaabc9988fd3807ad792e 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.