diff --git a/app/Main.hs b/app/Main.hs
index 47f3151f79d9ff0e41db5bf49066d2dae177d0b1..157e0186750e0a957a19e66e419fb7cc993c332d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -8,7 +8,7 @@ import Data.Yaml (decodeEither')
import System.Environment (getArgs)
import Tahoe.Announcement (Announcements (..))
import Tahoe.CHK.Capability (CHK (CHKReader), pCapability)
-import Tahoe.Download (announcementToStorageServer, download)
+import Tahoe.Download (announcementToImmutableStorageServer, download)
import Text.Megaparsec (parse)
main :: IO ()
@@ -22,7 +22,7 @@ main = do
let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap)
-- Download & decode the shares
- result <- download announcements cap announcementToStorageServer
+ result <- download announcements cap announcementToImmutableStorageServer
-- Show the result
putStrLn "Your result:"
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 0312e51907c814bf571180adc41e61977864d352..ba2597aa1d6bdb02aadeb79eb14fd2a3f267a66b 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -81,6 +81,8 @@ library
exposed-modules:
Tahoe.Announcement
Tahoe.Download
+ Tahoe.Download.Internal.Client
+ Tahoe.Download.Internal.Immutable
-- Modules included in this library but not exported.
-- other-modules:
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index e957769e353efa3528787c2106cd7b91f9b67d4d..31697c3a6cfc59098a9c6a701936f80ada29f1b0 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
{- | A high-level interface to downloading share data as bytes from storage
servers.
-}
@@ -8,38 +11,30 @@ module Tahoe.Download (
DiscoverError (..),
discoverShares,
download,
- announcementToStorageServer,
+ announcementToImmutableStorageServer,
+ getShareNumbers,
) where
-import Control.Exception (Exception (displayException), SomeException, throwIO, try)
+import Control.Exception (Exception (displayException), SomeException, try)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Bifunctor (Bifunctor (first, second))
import Data.Binary (Word16, decodeOrFail)
import qualified Data.ByteString as B
-import Data.ByteString.Base32 (encodeBase32Unpadded)
-import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as LB
import Data.Either (partitionEithers, rights)
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 (encodeUtf8)
-import Network.Connection (TLSSettings (TLSSettingsSimple))
-import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
-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))
-import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
+import Tahoe.Announcement (StorageServerAnnouncement)
import qualified Tahoe.CHK
import Tahoe.CHK.Capability (Reader (..), Verifier (..))
+import qualified Tahoe.CHK.Capability as CHK
import qualified Tahoe.CHK.Encrypt
import Tahoe.CHK.Server (StorageServer (..), StorageServerID)
+import qualified Tahoe.CHK.Share
import Tahoe.CHK.Types (ShareNum, StorageIndex)
-import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
-import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
-import Text.Read (readMaybe)
+import Tahoe.Download.Internal.Client
+import Tahoe.Download.Internal.Immutable
print' :: MonadIO m => String -> m ()
-- print' = liftIO . print
@@ -51,73 +46,31 @@ type DownloadTask = (ShareNum, StorageServer)
-- | A downloaded share
type Share = (ShareNum, LB.ByteString)
-{- | An unrecoverable problem arose while attempting to download and/or read
- some application data.
--}
-data DownloadError
- = -- | The configuration included no candidate servers from which to download.
- NoConfiguredServers
- | -- | Across all of the configured servers, none were actually connectable.
- NoReachableServers [DiscoverError]
- | -- | Across all of the configured servers, fewer than the required
- -- number of shares were found. XXX Could split this into the different
- -- cases - did not locate enough shares, did not download enough shares,
- -- did not verify enough shares
- NotEnoughShares
- { notEnoughSharesNeeded :: Int
- , notEnoughSharesFound :: Int
- }
- | -- | Across all of the shares that we could download, fewer than the
- -- required number could actually be decoded.
- NotEnoughDecodedShares
- { notEnoughDecodedSharesNeeded :: Int
- , notEnoughDecodedSharesFound :: Int
- }
- | -- | Enough syntactically valid shares were recovered but they could not
- -- be interpreted.
- ShareDecodingFailed
- | -- | An attempt was made to download a share but no servers were given for
- -- the download.
- NoServers
- | -- | An error occurred during share download.
- ShareDownloadError String
- deriving (Eq, Ord, Show)
-
-{- | A problem arose while attempting to discover the shares held on a
- particular server.
--}
-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 LookupError
- | StorageServerCommunicationError String
- deriving (Eq, Ord, Show)
-
-{- | The type of a function that can produce a concrete StorageServer from
- that server's announcement.
--}
-type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
-
{- | Recover the application data associated with a given capability from the
given servers, if possible.
-}
download ::
- MonadIO m =>
+ (MonadIO m, Verifiable v, Readable r v) =>
-- | 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
- print' ("Going to download: " <> show storageIndex)
- locationE <- locateShares servers lookupServer storageIndex required
+download servers cap lookupServer = do
+ print' ("Going to download: " <> show (getStorageIndex $ getVerifiable cap))
+ let verifier = getVerifiable cap
+ let storageIndex = getStorageIndex verifier
+ -- TODO: If getRequiredTotal fails on the first storage server, we may
+ -- need to try more. If it fails for all of them, we need to represent
+ -- the failure coherently.
+ ss <- firstStorageServer (Map.elems servers) lookupServer
+ (required, _) <- getRequiredTotal verifier ss
+ locationE <- locateShares servers lookupServer storageIndex (fromIntegral required)
print' "Finished locating shares"
case locationE of
Left err -> do
@@ -128,10 +81,79 @@ download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
-- XXX note shares can contain failures
shares <- executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered)
print' "Fetched the shares, decoding them"
- s <- decodeShares cap shares
+ s <- decodeShares cap shares required
print' "Decoded them"
pure s
+-- We also need "first successful share"!
+firstStorageServer :: Monad m => [StorageServerAnnouncement] -> LookupServer m -> m StorageServer
+firstStorageServer servers finder = do
+ responses <- mapM finder servers
+ pure $ head $ take 1 $ rights responses -- XXX don't do this at home kids, head isn't safe
+
+-- | A capability which confers the ability to locate and verify some stored data.
+class Verifiable v where
+ -- | Ask a storage server which share numbers related to this capability it
+ -- is holding. This is an unverified result and the storage server could
+ -- present incorrect information. Even if it correctly reports that it
+ -- holds a share, it could decline to give it out when asked.
+ getShareNumbers :: MonadIO m => v -> StorageServer -> m (Set.Set ShareNum)
+
+ -- | Get the encoding parameters used for the shares of this capability.
+ -- The information is presented as a tuple of (required, total).
+ getRequiredTotal :: MonadIO m => v -> StorageServer -> m (Int, Int)
+
+ -- | Get the location information for shares of this capability.
+ getStorageIndex :: v -> StorageIndex
+
+instance Verifiable CHK.Verifier where
+ getShareNumbers v s = liftIO $ storageServerGetBuckets s (storageIndex v)
+ getStorageIndex Verifier{storageIndex} = storageIndex
+
+ -- CHK is pure, we don't have to ask the StorageServer
+ getRequiredTotal Verifier{required, total} _ = pure (fromIntegral required, fromIntegral total)
+
+{- | A capability which confers the ability to interpret some stored data to
+ recover the original plaintext. Additionally, it can be attentuated to a
+ Verifiable.
+-}
+class (Verifiable v) => Readable r v | r -> v where
+ -- | Attentuate the capability.
+ getVerifiable :: r -> v
+
+ -- | Interpret the required number of shares to recover the plaintext.
+ --
+ -- Note: might want to split the two functions below out of decodeShare
+ --
+ -- shareToCipherText :: r -> [(Int, WhichShare)] -> LB.ByteString
+ --
+ -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString
+ decodeShare :: MonadIO m => r -> [(Int, WhichShare)] -> m (Either DownloadError LB.ByteString)
+
+instance Readable CHK.Reader CHK.Verifier where
+ getVerifiable = verifier
+ decodeShare r shareList = do
+ cipherText <- liftIO $ Tahoe.CHK.decode r (second unWhich <$> shareList)
+ case cipherText of
+ Nothing -> pure $ Left ShareDecodingFailed
+ Just ct ->
+ pure . Right $ Tahoe.CHK.Encrypt.decrypt (readKey r) ct
+
+{- | Represent the kind of share to operate on. This forms a closed world of
+ share types. It might eventually be interesting to make an open world
+ variation instead.
+-}
+newtype WhichShare = CHK {unWhich :: Tahoe.CHK.Share.Share} -- \| SDMF SDMF.Share
+
+{- | Deserialize some bytes representing some kind of share to that kind of
+ share, if possible.
+-}
+bytesToShare :: LB.ByteString -> Either DeserializeError WhichShare
+bytesToShare bytes = do
+ case decodeOrFail bytes of
+ Left _ -> Left UnknownDeserializeError
+ Right (_, _, r) -> Right $ CHK r
+
{- | Execute each download task sequentially and return only the successful
results.
-}
@@ -185,26 +207,21 @@ locateShares servers lookupServer storageIndex required =
decode them and decrypt the contents of possible.
-}
decodeShares ::
- MonadIO m =>
+ (MonadIO m, Readable r v) =>
-- | The read capability which allows the contents to be decrypted.
- Reader ->
+ r ->
-- | The results of downloading the shares.
[Share] ->
+ Int ->
m (Either DownloadError LB.ByteString)
-decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares =
+decodeShares r shares required = do
-- Filter down to shares we actually got.
- let fewerShares = second decodeOrFail <$> shares
- onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares
- in if length onlyDecoded < fromIntegral required
- then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
- else do
- print' "Interpreted shares, decoding them"
- ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
- print' "Decoded them, might decrypt them"
- case ciphertext of
- Nothing -> pure $ Left ShareDecodingFailed
- Just ct ->
- pure . Right $ Tahoe.CHK.Encrypt.decrypt readKey ct
+ let fewerShares :: [(ShareNum, Either DeserializeError WhichShare)] = second bytesToShare <$> shares
+ onlyDecoded = rights $ (\(a, b) -> (fromIntegral a,) <$> b) <$> fewerShares
+ if length onlyDecoded < required
+ then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
+ else do
+ decodeShare r onlyDecoded
{- | Figure the total number of distinct shares reported by all of the servers
we asked.
@@ -257,127 +274,3 @@ downloadShare storageIndex (shareNum, s) = do
let massaged = first (ShareDownloadError . (displayException :: SomeException -> String)) shareBytes
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
-
-{- | 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)
diff --git a/src/Tahoe/Download/Internal/Client.hs b/src/Tahoe/Download/Internal/Client.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4b811312ac25b443a0f2ff92863c2ea0b59c1a77
--- /dev/null
+++ b/src/Tahoe/Download/Internal/Client.hs
@@ -0,0 +1,127 @@
+{- | Functionality related to acting as a client for the Great Black Swamp
+ protocol.
+-}
+module Tahoe.Download.Internal.Client where
+
+import Control.Monad.IO.Class
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Network.Connection
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+import Servant.Client
+import Tahoe.Announcement
+import Tahoe.CHK.Server (
+ StorageServer,
+ )
+
+-- | 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)
+
+{- | An unrecoverable problem arose while attempting to download and/or read
+ some application data.
+-}
+data DownloadError
+ = -- | The configuration included no candidate servers from which to download.
+ NoConfiguredServers
+ | -- | Across all of the configured servers, none were actually connectable.
+ NoReachableServers [DiscoverError]
+ | -- | Across all of the configured servers, fewer than the required
+ -- number of shares were found. XXX Could split this into the different
+ -- cases - did not locate enough shares, did not download enough shares,
+ -- did not verify enough shares
+ NotEnoughShares
+ { notEnoughSharesNeeded :: Int
+ , notEnoughSharesFound :: Int
+ }
+ | -- | Across all of the shares that we could download, fewer than the
+ -- required number could actually be decoded.
+ NotEnoughDecodedShares
+ { notEnoughDecodedSharesNeeded :: Int
+ , notEnoughDecodedSharesFound :: Int
+ }
+ | -- | Enough syntactically valid shares were recovered but they could not
+ -- be interpreted.
+ ShareDecodingFailed
+ | -- | An attempt was made to download a share but no servers were given for
+ -- the download.
+ NoServers
+ | -- | An error occurred during share download.
+ ShareDownloadError String
+ deriving (Eq, Ord, Show)
+
+{- | A problem arose while attempting to discover the shares held on a
+ particular server.
+-}
+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 LookupError
+ | StorageServerCommunicationError String
+ deriving (Eq, Ord, Show)
+
+{- | The type of a function that can produce a concrete StorageServer from
+ that server's announcement.
+-}
+type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
+
+-- | 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)
+
+{- | A problem was encountered attempting to deserialize bytes to a structured
+ representation of some value.
+-}
+data DeserializeError = UnknownDeserializeError -- add more later?
diff --git a/src/Tahoe/Download/Internal/Immutable.hs b/src/Tahoe/Download/Internal/Immutable.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f7c9cb8f192c4c9351cddd7fd33989406a5e87bf
--- /dev/null
+++ b/src/Tahoe/Download/Internal/Immutable.hs
@@ -0,0 +1,79 @@
+-- | 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.
+-}
+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