diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index c462d6915dfec014a811cb7695d12d012b9507ff..ba99ccdc3dd3591b308ad13ea25c1c38a816af35 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -92,9 +92,11 @@ library
, base32
, binary
, bytestring
+ , connection
, containers
, exceptions
, http-client
+ , http-client-tls
, network-uri
, servant-client
, servant-client-core
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index f25bac673470c6b64a9dcd5aace7333348596ed2..f853b41272c400cf886a186f103f78cf9863b0c5 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -17,14 +17,16 @@ module Tahoe.Download (
import Control.Exception (throwIO)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Binary (decodeOrFail)
+import Data.ByteString.Base32 (encodeBase32Unpadded)
import qualified Data.ByteString.Lazy as LB
import Data.Either (isRight, partitionEithers)
import Data.List (foldl')
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 Network.Connection (TLSSettings (TLSSettingsSimple))
+import Network.HTTP.Client (Manager, ManagerSettings)
+import Network.HTTP.Client.TLS (mkManagerSettings, newTlsManagerWith)
import Network.URI (URI (..), URIAuth (..))
import Servant.Client (Scheme (Https), mkClientEnv, runClientM)
import Servant.Client.Core (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
@@ -34,8 +36,8 @@ import Tahoe.CHK.Capability (Reader (..), Verifier (..))
import qualified Tahoe.CHK.Encrypt
import Tahoe.CHK.Server (StorageServer (..), StorageServerID)
import Tahoe.CHK.Types (ShareNum, StorageIndex)
-import TahoeLAFS.Storage.API (ShareNumber (ShareNumber))
-import TahoeLAFS.Storage.Client (readImmutableShares)
+import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
+import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShares)
import Text.Read (readMaybe)
{- | An unrecoverable problem arose while attempting to download and/or read
@@ -200,31 +202,37 @@ announcementToStorageServer ann =
makeServer :: MonadIO m => URI -> m (Either LookupError StorageServer)
makeServer
URI
- { uriScheme = "pb"
- , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = port}
- , uriPath = swissnum
- , uriFragment = "#v=1"
+ { uriScheme = "pb:"
+ , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)}
+ , uriPath = ('/' : swissnum)
+ , uriFragment = "" -- Where's the #v=1 ???
} =
case readMaybe port of
Nothing -> pure . Left . PortParseError $ port
Just realPort -> do
- manager <- liftIO $ newManager (managerSettingsForService (T.pack tubid) (T.pack swissnum))
+ manager <- liftIO $ newGBSManager tubid swissnum
let baseUrl = https host realPort
env = mkClientEnv manager baseUrl
+ toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
storageServerID = undefined
storageServerWrite = undefined
storageServerRead storageIndex shareNum = do
- let clientm = readImmutableShares (T.unpack $ decodeUtf8 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+ let clientm = readImmutableShares (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
res <- runClientM clientm env
case res of
Left err -> throwIO err
Right bs -> pure bs
- storageServerGetBuckets = undefined
+ storageServerGetBuckets storageIndex = do
+ let clientm = getImmutableShareNumbers (toBase32 storageIndex)
+ res <- runClientM clientm env
+ case res of
+ Left err -> throwIO err
+ Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
pure . Right $ StorageServer{..}
makeServer _ = pure . Left $ AnnouncementStructureUnmatched
@@ -234,8 +242,23 @@ https host port =
{ baseUrlScheme = Https
, baseUrlHost = host
, baseUrlPort = port
- , baseUrlPath = "/"
+ , baseUrlPath = ""
}
managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
-managerSettingsForService _ _ = defaultManagerSettings
+managerSettingsForService _ _ =
+ mkManagerSettings tlsSettings sockSettings
+ where
+ tlsSettings = TLSSettingsSimple True True True
+ sockSettings = Nothing
+
+newGBSManager ::
+ MonadIO m =>
+ [Char] ->
+ String ->
+ m Manager
+newGBSManager tubid swissnum =
+ newTlsManagerWith $
+ managerSettingsForService
+ (T.pack . init $ tubid)
+ (T.pack swissnum)
diff --git a/test/Spec.hs b/test/Spec.hs
index e056b04cdfa06cc2dd4ce9d58962d24de29d2c57..f96cff83f0fa5bec130bdd284c1addaaf121d87b 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -18,14 +18,26 @@ import Hedgehog (MonadGen, diff, forAll, property)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import System.IO (hSetEncoding, stderr, stdout, utf8)
-import Tahoe.Announcement (StorageServerAnnouncement (..), StorageServerID)
+import Tahoe.Announcement (
+ StorageServerAnnouncement (..),
+ StorageServerID,
+ URI (..),
+ URIAuth (..),
+ parseURI',
+ )
import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
import qualified Tahoe.CHK.Encrypt
import Tahoe.CHK.Server (StorageServer (..))
import Tahoe.CHK.Types (Parameters (..))
import Tahoe.CHK.Upload (getConvergentKey)
-import Tahoe.Download (DiscoverError (StorageServerUnreachable), DownloadError (..), LookupError (..), LookupServer, download)
+import Tahoe.Download (
+ DiscoverError (StorageServerUnreachable),
+ DownloadError (..),
+ LookupError (..),
+ LookupServer,
+ download,
+ )
import Tahoe.Server (memoryStorageServer)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertEqual, testCase)
@@ -38,14 +50,37 @@ tests :: TestTree
tests =
testGroup
"All tests"
- [ testCase "no configured servers" $ do
- -- If there are no servers then we can't possibly get enough
- -- shares to recover the application data.
- result <- liftIO $ download mempty (trivialCap 1 1) noServers
- assertEqual
- "download should fail with no servers"
- (Left NoConfiguredServers)
- result
+ [ testCase "Tahoe-LAFS fURLs can be parsed to a structured representation" $
+ let tubid = "gnuer2axzoq3ggnn7gjoybmfqsjvaow3"
+ swissnum = "sxytycucj5eeunlx6modfazq5byp2hpb"
+ in assertEqual
+ "The result is as expected"
+ ( Just
+ URI
+ { uriScheme = "pb:"
+ , uriAuthority =
+ Just
+ URIAuth
+ { uriUserInfo = tubid <> "@"
+ , uriRegName = "localhost"
+ , uriPort = ":46185"
+ }
+ , uriPath = "/" <> swissnum
+ , uriQuery = ""
+ , uriFragment = ""
+ }
+ )
+ (parseURI' $ T.pack $ "pb://" <> tubid <> "@tcp:localhost:46185/" <> swissnum)
+ , testCase
+ "no configured servers"
+ $ do
+ -- If there are no servers then we can't possibly get enough
+ -- shares to recover the application data.
+ result <- liftIO $ download mempty (trivialCap 1 1) noServers
+ assertEqual
+ "download should fail with no servers"
+ (Left NoConfiguredServers)
+ result
, testCase "no reachable servers" $ do
-- If we can't contact any configured server then we can't
-- possibly get enough shares to recover the application data.