diff --git a/app/Main.hs b/app/Main.hs
index 2b87ca658b7f582f4d56e79fe8ba82b372be32ce..47f3151f79d9ff0e41db5bf49066d2dae177d0b1 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,29 @@
module Main where
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+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 Text.Megaparsec (parse)
+
main :: IO ()
main = do
- putStrLn "Hello, Haskell!"
+ [announcementPath, readCap] <- getArgs
+ -- Load server announcements
+ announcementsBytes <- B.readFile announcementPath
+ let Right (Announcements announcements) = decodeEither' announcementsBytes
+
+ -- Accept & parse read capability
+ let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap)
+
+ -- Download & decode the shares
+ result <- download announcements cap announcementToStorageServer
+
+ -- Show the result
+ putStrLn "Your result:"
+ either print (C8.putStrLn . BL.toStrict) result
diff --git a/cabal.project b/cabal.project
index c216d6e9ce25190cc1b5794854ce6eae5b300174..55be17a13a683db9dd1f7743b243c5f56a0f587a 100644
--- a/cabal.project
+++ b/cabal.project
@@ -2,8 +2,8 @@ packages: .
-- These aren't released on hackage yet so we have to grab them
-- straight from the vcs host. Probably should do some releases
-- soon.
- https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.0/tahoe-chk-0.1.0.0.tar.gz
- https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/archive/0.1.0.1/tahoe-great-black-swamp-0.1.0.1.tar.gz
+ https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.1/tahoe-chk-0.1.0.1.tar.gz
+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/archive/0.2.0.2/tahoe-great-black-swamp-0.2.0.2.tar.gz
package zlib
-- Turn on discovery of the underlying zlib using pkg-config. This
diff --git a/flake.lock b/flake.lock
index b268d888768c5de6920c637dcf97bfc0f341961f..d5833947200194bc4a0e1131fef92513461b13cf 100644
--- a/flake.lock
+++ b/flake.lock
@@ -255,11 +255,11 @@
"pre-commit-hooks": "pre-commit-hooks_3"
},
"locked": {
- "lastModified": 1677773826,
- "narHash": "sha256-xJmOtHugr4k2zNhP/AF6JdIUnIEyM+TEspLn2n5kloc=",
+ "lastModified": 1681762240,
+ "narHash": "sha256-+PLx9xHBvV70dA7Gy/+YTH1w3PcSOrGV0z0rGxts8jU=",
"ref": "main",
- "rev": "d3a83fdd9563546ca41771186427638e685a2e2b",
- "revCount": 9,
+ "rev": "a51e591b7fdf8881ac0237452691df7b1aceecd3",
+ "revCount": 10,
"type": "git",
"url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
},
@@ -475,16 +475,16 @@
]
},
"locked": {
- "lastModified": 1681998540,
- "narHash": "sha256-gtlHidh8+qMUdnTzlxLIGlCMavq4/TFQDmope33Cd2w=",
- "ref": "refs/tags/0.1.0.0",
- "rev": "799bab0c2b8b5f9cbd98e7dd7d6a77285c87f16b",
- "revCount": 340,
+ "lastModified": 1683552888,
+ "narHash": "sha256-h9pgP/LYPtUr5CeCAhqt1XJyAqKTnkQxuIygiTulU/U=",
+ "ref": "refs/tags/0.1.0.1",
+ "rev": "05aeb5a433b85406ca3c0c313c46299a1026ade0",
+ "revCount": 344,
"type": "git",
"url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk"
},
"original": {
- "ref": "refs/tags/0.1.0.0",
+ "ref": "refs/tags/0.1.0.1",
"type": "git",
"url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk"
}
@@ -496,19 +496,22 @@
"nixpkgs": [
"hs-flake-utils",
"nixpkgs"
+ ],
+ "tahoe-chk": [
+ "tahoe-chk"
]
},
"locked": {
- "lastModified": 1682446800,
- "narHash": "sha256-Vxl4dLpoRp2svWTx0w74m7PeVPMlkSu/XOZAHccOUDs=",
- "ref": "refs/tags/0.1.0.1",
- "rev": "b81cc3fcdb0107d369a636fdc5a17cf174dff2ea",
- "revCount": 143,
+ "lastModified": 1683553313,
+ "narHash": "sha256-tXZc8ZDNkHtegoM1HlDUf1Jr5IE04aobZDpnBaBm53w=",
+ "ref": "refs/tags/0.2.0.2",
+ "rev": "ab799ee24d7150e13b300b86240433ecdb783577",
+ "revCount": 187,
"type": "git",
"url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
},
"original": {
- "ref": "refs/tags/0.1.0.1",
+ "ref": "refs/tags/0.2.0.2",
"type": "git",
"url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
}
diff --git a/flake.nix b/flake.nix
index 8c70ef15153e6a444c51dee6bd182192295cb18f..72e7dac3d07880153daef299b550ccd22605fde3 100644
--- a/flake.nix
+++ b/flake.nix
@@ -8,13 +8,14 @@
hs-flake-utils.url = "git+https://whetstone.private.storage/jcalderone/hs-flake-utils.git?ref=main";
tahoe-chk = {
- url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-chk?ref=refs/tags/0.1.0.0";
+ url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-chk?ref=refs/tags/0.1.0.1";
inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs";
};
tahoe-great-black-swamp = {
- url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp?ref=refs/tags/0.1.0.1";
+ url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp?ref=refs/tags/0.2.0.2";
inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs";
+ inputs.tahoe-chk.follows = "tahoe-chk";
};
};
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 8d377001b6a0f7437ef008f13a615b2108909641..0312e51907c814bf571180adc41e61977864d352 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -1,4 +1,4 @@
-cabal-version: 3.0
+cabal-version: 2.4
-- The cabal-version field refers to the version of the .cabal specification,
-- and can be different from the cabal-install (the tool) version and the
@@ -63,9 +63,12 @@ common warnings
common language
-- LANGUAGE extensions used by modules in all targets.
default-extensions:
+ DerivingStrategies
+ GeneralizedNewtypeDeriving
NamedFieldPuns
OverloadedStrings
RecordWildCards
+ ScopedTypeVariables
TupleSections
library
@@ -75,7 +78,9 @@ library
, language
-- Modules exported by the library.
- exposed-modules: Tahoe.Download
+ exposed-modules:
+ Tahoe.Announcement
+ Tahoe.Download
-- Modules included in this library but not exported.
-- other-modules:
@@ -85,13 +90,25 @@ library
-- Other library packages from which modules are imported.
build-depends:
- , base ^>=4.14.3.0
+ , aeson
+ , base
+ , base32
+ , base64-bytestring
, binary
, bytestring
+ , connection
, containers
+ , data-default-class
+ , exceptions
+ , http-client
+ , http-client-tls
+ , network-uri
+ , servant-client
+ , servant-client-core
, tahoe-chk
- , tahoe-great-black-swamp
+ , tahoe-great-black-swamp >=0.2 && <0.3
, text
+ , yaml
-- Directories containing source files.
hs-source-dirs: src
@@ -116,8 +133,15 @@ executable gbs-download
-- Other library packages from which modules are imported.
build-depends:
- , base ^>=4.14.3.0
+ , aeson
+ , base
+ , bytestring
+ , containers
, gbs-downloader
+ , megaparsec
+ , tahoe-chk
+ , text
+ , yaml
-- Directories containing source files.
hs-source-dirs: app
@@ -148,12 +172,13 @@ test-suite gbs-downloader-test
-- Test dependencies.
build-depends:
- , base ^>=4.14.3.0
+ , base
, base32
, binary
, bytestring
, containers
, crypto-api
+ , data-default-class
, gbs-downloader
, hedgehog
, tahoe-chk
@@ -161,3 +186,4 @@ test-suite gbs-downloader-test
, tasty-hedgehog
, tasty-hunit
, text
+ , yaml
diff --git a/src/Tahoe/Announcement.hs b/src/Tahoe/Announcement.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3ad916d4e9c2f7eacb11b4fe707717d996f801ef
--- /dev/null
+++ b/src/Tahoe/Announcement.hs
@@ -0,0 +1,117 @@
+{- | Represent and work with Tahoe-LAFS storage service announcements.
+
+ A storage service announcement includes information about how to find and
+ authenticate a storage service. They are often exchanged using a pubsub
+ system orchestrated by an "introducer". Here, we currently support only
+ reading them from a yaml or json file.
+-}
+module Tahoe.Announcement (
+ URI (..),
+ URIAuth (..),
+ StorageServerID,
+ StorageServerAnnouncement (..),
+ Announcements (..),
+ greatBlackSwampURIs,
+ parseURI',
+) where
+
+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.:?), (.=))
+import qualified Data.ByteString as B
+import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded)
+import Data.Default.Class (Default (def))
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import qualified Data.Text
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Network.URI (URI (..), URIAuth (..), parseURI)
+
+{- | The unique identifier for a particular storage server, conventionally the
+ lowercase base32 encoding of some public key controlled by the server.
+-}
+type StorageServerID = T.Text
+
+{- | A map of storage server announcements keyed on the unique server
+ identifier.
+-}
+newtype Announcements
+ = Announcements (Map.Map StorageServerID StorageServerAnnouncement)
+ deriving newtype (Eq, Show)
+
+-- Support serialization to the ``servers.yaml`` format supported by
+-- Tahoe-LAFS.
+instance FromJSON Announcements where
+ parseJSON = withObject "servers.yaml" $ \v -> do
+ storage <- v .: "storage"
+ pure $ Announcements storage
+
+instance ToJSON Announcements where
+ toJSON (Announcements announcements) =
+ object
+ [ "storage" .= announcements
+ ]
+
+-- | An announcement from a storage server about its storage service.
+data StorageServerAnnouncement = StorageServerAnnouncement
+ { storageServerAnnouncementFURL :: Maybe T.Text
+ , storageServerAnnouncementNick :: Maybe T.Text
+ , storageServerAnnouncementPermutationSeed :: Maybe B.ByteString
+ }
+ deriving (Eq, Ord, Show)
+
+instance Default StorageServerAnnouncement where
+ def =
+ StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Nothing
+ , storageServerAnnouncementNick = Nothing
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+
+-- Support deserialization of a StorageServerAnnouncement from the
+-- ``servers.yaml`` format supported by Tahoe-LAFS.
+instance FromJSON StorageServerAnnouncement where
+ parseJSON = withObject "StorageServerAnnouncement" $ \ann -> do
+ v <- ann .: "ann"
+ storageServerAnnouncementFURL <- v .:? "anonymous-storage-FURL"
+ storageServerAnnouncementNick <- v .:? "nickname"
+ permutationSeed <- v .:? "permutation-seed-base32"
+ let storageServerAnnouncementPermutationSeed =
+ case permutationSeed of
+ Nothing -> Nothing
+ Just txt -> case decodeBase32Unpadded . encodeUtf8 $ txt of
+ Left _ -> Nothing
+ Right ps -> Just ps
+
+ pure StorageServerAnnouncement{..}
+
+-- And serialization to that format.
+instance ToJSON StorageServerAnnouncement where
+ toJSON StorageServerAnnouncement{..} =
+ object
+ [ "ann"
+ .= object
+ [ "anonymous-storage-FURL" .= storageServerAnnouncementFURL
+ , "nickname" .= storageServerAnnouncementNick
+ , "permutation-seed-base32"
+ .= (encodeBase32Unpadded <$> storageServerAnnouncementPermutationSeed)
+ ]
+ ]
+
+{- | If possible, get the URI of a Great Black Swamp server from an
+ announcement.
+-}
+greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI
+greatBlackSwampURIs =
+ parseURI' . fromMaybe "" . storageServerAnnouncementFURL
+
+{- | Parse a Tahoe-LAFS fURL. For example:
+
+ pb://gnuer2axzoq3ggnn7gjoybmfqsjvaow3@tcp:localhost:46185/sxytycucj5eeunlx6modfazq5byp2hpb
+
+ This *does not* parse NURLs which are the expected way that GBS locations
+ will be communicated.
+
+ See https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/6
+-}
+parseURI' :: T.Text -> Maybe URI
+parseURI' = Network.URI.parseURI . T.unpack . Data.Text.replace "tcp:" ""
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 35d87188f5fb56222b3472f4d82df21e24d8d83f..48b8cd3e43b7a9e7ee7854c4910eb48c9a166a5e 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,19 +1,49 @@
{- | A high-level interface to downloading share data as bytes from storage
servers.
-}
-module Tahoe.Download (LookupServer, DownloadError (..), discoverShares, download) where
+module Tahoe.Download (
+ LookupServer,
+ DownloadError (..),
+ LookupError (..),
+ DiscoverError (..),
+ discoverShares,
+ download,
+ announcementToStorageServer,
+) where
-import Data.Binary (decodeOrFail)
+import Control.Exception (Exception (displayException), SomeException, throwIO, try)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Bifunctor (Bifunctor (first))
+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 (isRight, rights)
+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 (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 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.Server (StorageServer (..), StorageServerID)
import Tahoe.CHK.Types (ShareNum, StorageIndex)
+import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
+import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
+import Text.Read (readMaybe)
+
+print' :: MonadIO m => String -> m ()
+-- print' = liftIO . print
+print' = const $ pure ()
{- | An unrecoverable problem arose while attempting to download and/or read
some application data.
@@ -22,7 +52,7 @@ data DownloadError
= -- | The configuration included no candidate servers from which to download.
NoConfiguredServers
| -- | Across all of the configured servers, none were actually connectable.
- NoReachableServers
+ 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,
@@ -43,66 +73,134 @@ data DownloadError
| -- | 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)
-{- | An problem arose while attempting to discover the shares held on a
+{- | 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
- | StorageServerUnreachable
+ | -- | An announcement included a location we could not interpret.
+ StorageServerLocationUnsupported
+ | StorageServerUnreachable LookupError
+ | StorageServerCommunicationError String
deriving (Eq, Ord, Show)
--- TODO The result might need to be in IO in case the URL indicates a
--- Tor-based route to the server. In this case we might need to launch a Tor
--- daemon or connect to a running Tor daemon or at least set up a new Tor
--- circuit. All of which require I/O. But we can always refactor later!
-type LookupServer = URL -> Maybe StorageServer
+{- | 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 =>
-- | 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 ->
-- | Get functions for interacting with a server given its URL.
- LookupServer ->
+ LookupServer m ->
-- | Either a description of how the recovery failed or the recovered
-- application data.
- IO (Either DownloadError LB.ByteString)
-download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
+ 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
+ print' "Finished locating shares"
+ case locationE of
+ Left err -> do
+ print' "Got an error locating shares"
+ pure $ Left err
+ Right discovered -> do
+ print' "Found some shares, fetching them"
+ -- XXX note shares can contain failures
+ shares <- fetchShares storageIndex discovered
+ print' "Fetched the shares, decoding them"
+ s <- decodeShares cap shares
+ print' "Decoded them"
+ pure s
+
+-- | Find out which servers claim to have shares related to a given storage index.
+locateShares ::
+ MonadIO m =>
+ -- | Information about the servers from which to consider downloading shares
+ -- representing the application data.
+ Map.Map StorageServerID StorageServerAnnouncement ->
+ -- | Get functions for interacting with a server given its URL.
+ LookupServer m ->
+ -- | The storage index about which to retrieve information.
+ B.ByteString ->
+ -- | The number of shares we need to locate. If we cannot find at least
+ -- this many shares the result will be an error.
+ Word16 ->
+ -- | Either an error or a guide to where shares are placed.
+ m (Either DownloadError [(StorageServer, Set.Set ShareNum)])
+locateShares servers lookupServer storageIndex required =
case Map.toList servers of
[] -> pure . Left $ NoConfiguredServers
serverList -> do
+ print' "Discovering shares"
-- Ask each server for all shares it has.
- discovered <- rights <$> mapM (discoverShares lookupServer storageIndex) serverList :: IO [(StorageServer, Set.Set ShareNum)]
+ ( problems :: [DiscoverError]
+ , discovered :: [(StorageServer, Set.Set ShareNum)]
+ ) <-
+ partitionEithers <$> mapM (discoverShares lookupServer storageIndex) serverList
if null discovered
- then pure $ Left NoReachableServers
+ then pure . Left . NoReachableServers $ problems
else
if (fromIntegral required >) . countDistinctShares $ discovered
then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered}
- else do
- -- XXX up to here is probably "locateShares". now we move in to "fetchShares".
- let sharemap = makeShareMap discovered
- -- XXX note shares can contain failures
- shares <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
- -- XXX That was brief. Probably missing some complexity. now we move on to "decodeShares".
- -- Filter down to shares we actually got.
- let someShares = filter (isRight . snd) shares
- fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares
- onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares
- if length onlyDecoded < fromIntegral required
- then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
- else do
- ciphertext <- Tahoe.CHK.decode cap onlyDecoded
- case ciphertext of
- Nothing -> pure $ Left ShareDecodingFailed
- Just ct ->
- pure . Right $ Tahoe.CHK.Encrypt.decrypt readKey ct
+ else pure $ Right discovered
+
+{- | Given a guide to where shares for a given storage index are placed,
+ download them.
+-}
+fetchShares ::
+ MonadIO m =>
+ -- | The storage index of the shares to download.
+ B.ByteString ->
+ -- | The guide to where shares are placed.
+ [(StorageServer, Set.Set ShareNum)] ->
+ m [(ShareNum, Either DownloadError LB.ByteString)]
+fetchShares storageIndex discovered = do
+ print' "Fetching shares"
+ s <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+ print' "Fetched shares"
+ pure s
+ where
+ sharemap = makeShareMap discovered
+
+{- | Given the results of downloading shares related to a given capability,
+ decode them and decrypt the contents of possible.
+-}
+decodeShares ::
+ MonadIO m =>
+ -- | The read capability which allows the contents to be decrypted.
+ Reader ->
+ -- | The results of downloading the shares.
+ [(ShareNum, Either DownloadError LB.ByteString)] ->
+ m (Either DownloadError LB.ByteString)
+decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares =
+ -- Filter down to shares we actually got.
+ let someShares = filter (isRight . snd) shares
+ fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares
+ 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
{- | Figure the total number of distinct shares reported by all of the servers
we asked.
@@ -113,16 +211,24 @@ countDistinctShares = Set.size . foldl' Set.union mempty . map snd
{- | Ask one server which shares it has related to the storage index in
question.
-}
-discoverShares :: LookupServer -> StorageIndex -> (StorageServerID, StorageServerAnnouncement) -> IO (Either DiscoverError (StorageServer, Set.Set ShareNum))
+discoverShares ::
+ MonadIO m =>
+ LookupServer m ->
+ StorageIndex ->
+ (StorageServerID, StorageServerAnnouncement) ->
+ m (Either DiscoverError (StorageServer, Set.Set ShareNum))
discoverShares lookupServer storageIndex (_sid, sann) = do
- case storageServerAnnouncementFURL sann of
- Nothing -> pure $ Left StorageServerLocationUnknown
- Just url -> do
- let server = lookupServer url
- case server of
- Nothing -> pure $ Left StorageServerUnreachable
- Just ss@StorageServer{storageServerGetBuckets} ->
- Right . (ss,) <$> storageServerGetBuckets storageIndex
+ print' "Looking up server from announcement"
+ server <- lookupServer sann
+ print' "Looked it up"
+ case server of
+ Left e -> pure . Left . StorageServerUnreachable $ e
+ Right ss@StorageServer{storageServerGetBuckets} -> do
+ print' $ "Getting buckets for " <> show storageIndex
+ buckets <- liftIO $ try (storageServerGetBuckets storageIndex)
+ let massaged = first (StorageServerCommunicationError . (displayException :: SomeException -> String)) buckets
+ print' $ "Got them " <> show massaged
+ pure $ (ss,) <$> massaged
{- | Invert the mapping implied by the list of two tuples so that the servers
that claim to have a certain share can easily be retrieved.
@@ -133,6 +239,7 @@ makeShareMap locations =
-- | Download the bytes of a share from one (or more!) of the given servers.
downloadShare ::
+ MonadIO m =>
-- | The storage index of the share to download.
StorageIndex ->
-- | The number of the share to download.
@@ -144,11 +251,138 @@ downloadShare ::
[StorageServer] ->
-- | The bytes of the share or some error that was encountered during
-- download.
- IO (ShareNum, Either DownloadError LB.ByteString)
+ m (ShareNum, Either DownloadError LB.ByteString)
downloadShare _ shareNum [] = pure (shareNum, Left NoServers)
downloadShare storageIndex shareNum (s : _) = do
-- TODO: There might be more servers. We could try them if this fails.
-- On the other hand, we might get bytes but we don't verify them here so
-- we might also need retry logic up a level or two from here.
- shareBytes <- storageServerRead s storageIndex shareNum
- pure (shareNum, Right $ LB.fromStrict shareBytes)
+ print' $ "Going to download " <> show storageIndex <> " " <> show shareNum
+ shareBytes <- liftIO $ try (storageServerRead s storageIndex shareNum)
+ 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/test/Generators.hs b/test/Generators.hs
index 08ba46e3fcbefd45e977c8d35e240821439aab1b..3adc7c662bbccce84fecc99c0cb6251bac5eb1fa 100644
--- a/test/Generators.hs
+++ b/test/Generators.hs
@@ -1,9 +1,12 @@
module Generators where
+import Data.ByteString.Base32 (encodeBase32Unpadded)
import Data.Int (Int64)
+import qualified Data.Text as T
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
+import Tahoe.Announcement (Announcements (..), StorageServerAnnouncement (..))
import Tahoe.CHK.Types (Parameters (..))
-- | The maximum value an Int64 can represent.
@@ -20,3 +23,17 @@ genParameters = do
-- easier not to let this value vary and it doesn't hurt anything.
let paramHappyShares = 1
pure $ Parameters{paramSegmentSize, paramTotalShares, paramHappyShares, paramRequiredShares}
+
+genAnnouncements :: MonadGen m => Range.Range Int -> m Announcements
+genAnnouncements size =
+ Announcements <$> Gen.map size ((,) <$> genServerIDs <*> genStorageServerAnnouncements)
+
+genServerIDs :: MonadGen m => m T.Text
+genServerIDs = T.toLower . encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32)
+
+genStorageServerAnnouncements :: MonadGen m => m StorageServerAnnouncement
+genStorageServerAnnouncements =
+ StorageServerAnnouncement
+ <$> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)
+ <*> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)
+ <*> Gen.maybe (Gen.bytes $ Range.singleton 32)
diff --git a/test/Spec.hs b/test/Spec.hs
index f2547908dc60bdaab1ccc29623c844c2f6a05fe1..91a9191fd9cb0223b4fb905c9838bf9d612c93df 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -8,23 +8,39 @@ import qualified Data.Binary as Binary
import qualified Data.ByteString as B
import Data.ByteString.Base32 (encodeBase32Unpadded)
import qualified Data.ByteString.Lazy as BL
+import Data.Default.Class (Default (def))
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 Data.Word (Word16)
-import Generators (genParameters)
-import Hedgehog (MonadGen, diff, forAll, property)
+import qualified Data.Yaml as Yaml
+import Generators (genAnnouncements, genParameters)
+import Hedgehog (MonadGen, diff, forAll, property, tripping)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import System.IO (hSetEncoding, stderr, stdout, utf8)
+import Tahoe.Announcement (
+ Announcements,
+ 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 (..), StorageServerAnnouncement (..), StorageServerID)
+import Tahoe.CHK.Server (StorageServer (..))
import Tahoe.CHK.Types (Parameters (..))
import Tahoe.CHK.Upload (getConvergentKey)
-import Tahoe.Download (DownloadError (..), LookupServer, download)
+import Tahoe.Download (
+ DiscoverError (..),
+ DownloadError (..),
+ LookupError (..),
+ LookupServer,
+ download,
+ )
import Tahoe.Server (memoryStorageServer)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertEqual, testCase)
@@ -33,53 +49,109 @@ import Test.Tasty.Hedgehog (testProperty)
data PlacementError = RanOutOfPlacementInfo | RanOutOfServers deriving (Eq, Show)
instance Exception PlacementError
+{- | Return a new StorageServer like the given one but with a get-buckets
+ interface that always throws an IO exception.
+-}
+breakGetBuckets :: Exception e => e -> StorageServer -> StorageServer
+breakGetBuckets exc ss =
+ ss
+ { storageServerGetBuckets = const $ throwIO exc
+ }
+
+{- | Return a new StorageServer like the given one but with a read-share
+ interface that always throws an IO exception.
+-}
+breakRead :: Exception e => e -> StorageServer -> StorageServer
+breakRead exc ss =
+ ss
+ { storageServerRead = \_ _ -> throwIO exc
+ }
+
+{- | A completely arbitrary exception that the download implementation can't
+ know anything specific about.
+-}
+data BespokeFailure = BespokeFailure deriving (Show)
+
+instance Exception BespokeFailure
+
+-- | Make an announcement that's real enough to convince a test.
+simpleAnnouncement :: T.Text -> T.Text -> (T.Text, StorageServerAnnouncement)
+simpleAnnouncement nick furl =
+ ( T.concat ["v0-", nick]
+ , def
+ { storageServerAnnouncementFURL = Just furl
+ , storageServerAnnouncementNick = Just nick
+ }
+ )
+
+{- | Build a lookup function that can look up any server in the given list
+ from its announcement.
+-}
+simpleLookup :: Applicative f => [(T.Text, b)] -> StorageServerAnnouncement -> f (Either LookupError b)
+simpleLookup [] _ = pure . Left $ AnnouncementStructureUnmatched
+simpleLookup ((furl, server) : ss) ann@StorageServerAnnouncement{storageServerAnnouncementFURL} =
+ if Just furl == storageServerAnnouncementFURL
+ then pure . pure $ server
+ else simpleLookup ss ann
+
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)
+ , testProperty "Announcements round-trip through YAML encoding/decoding" $
+ property $ do
+ announcements <- forAll $ genAnnouncements (Range.linear 0 3)
+ tripping announcements Yaml.encode (Yaml.decodeThrow :: B.ByteString -> Maybe Announcements)
+ , 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.
- let anns =
+ let ann = def{storageServerAnnouncementNick = Just "unreachable"}
+ anns =
Map.fromList
- [
- ( "v0-abc123"
- , StorageServerAnnouncement
- { storageServerAnnouncementFURL = Nothing
- , storageServerAnnouncementNick = Just "unreachable"
- , storageServerAnnouncementPermutationSeed = Nothing
- }
- )
+ [ ("v0-abc123", ann)
]
result <- liftIO $ download anns (trivialCap 1 1) noServers
assertEqual
"download should fail with no reachable servers"
- (Left NoReachableServers)
+ (Left $ NoReachableServers [StorageServerUnreachable (URIParseError ann)])
result
, testCase "not enough shares" $ do
-- If we can't recover enough shares from the configured servers
-- then we can't possibly get enough shares to recover the
-- application data.
- let anns =
- Map.fromList
- [
- ( "v0-abc123"
- , StorageServerAnnouncement
- { storageServerAnnouncementFURL = Just "somewhere"
- , storageServerAnnouncementNick = Just "abc123"
- , storageServerAnnouncementPermutationSeed = Nothing
- }
- )
- ]
+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]
cap = trivialCap 3 3
-- Two shares exist.
@@ -88,10 +160,7 @@ tests =
storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world"
-- Make the server reachable.
- let openServer furl =
- if furl == "somewhere"
- then pure server
- else Nothing
+ let openServer = simpleLookup [("somewhere", server)]
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -105,22 +174,8 @@ tests =
-- recover the application data. Duplicate shares do us no good.
let anns =
Map.fromList
- [
- ( "v0-abc123"
- , StorageServerAnnouncement
- { storageServerAnnouncementFURL = Just "somewhere"
- , storageServerAnnouncementNick = Just "abc123"
- , storageServerAnnouncementPermutationSeed = Nothing
- }
- )
- ,
- ( "v0-abc456"
- , StorageServerAnnouncement
- { storageServerAnnouncementFURL = Just "elsewhere"
- , storageServerAnnouncementNick = Just "abc123"
- , storageServerAnnouncementPermutationSeed = Nothing
- }
- )
+ [ simpleAnnouncement "abc123" "somewhere"
+ , simpleAnnouncement "abc456" "elsewhere"
]
cap = trivialCap 3 3
@@ -136,11 +191,7 @@ tests =
storageServerWrite elsewhere idx 0 offset "Hello world"
-- Make the server reachable.
- let openServer furl =
- case furl of
- "somewhere" -> pure somewhere
- "elsewhere" -> pure elsewhere
- _ -> Nothing
+ let openServer = simpleLookup [("somewhere", somewhere), ("elsewhere", elsewhere)]
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -148,6 +199,51 @@ tests =
"download should fail with not enough shares"
(Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
result
+ , testCase "IO exceptions from storageServerGetBuckets are handled" $ do
+ -- An announcement for our server
+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]
+ -- A broken interface to the server
+ server <- breakGetBuckets BespokeFailure <$> memoryStorageServer
+
+ -- Make the server reachable.
+ let openServer = simpleLookup [("somewhere", server)]
+
+ -- Something to pretend to try to download
+ let cap = trivialCap 3 13
+
+ -- Try to download the cap which requires three shares to reconstruct.
+ result <- liftIO $ download anns cap openServer
+ assertEqual
+ "download should fail with details about unreachable server"
+ (Left (NoReachableServers [StorageServerCommunicationError "BespokeFailure"]))
+ result
+ , testCase "IO exceptions from storageServerRead are handled" $ do
+ -- An announcement for our server
+ let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"]
+
+ -- A broken interface to the server
+ server <- breakRead BespokeFailure <$> memoryStorageServer
+
+ -- Something to pretend to try to download
+ let cap = trivialCap 3 13
+
+ -- Three shares exist
+ let idx = storageIndex . verifier $ cap
+ offset = 0
+ storageServerWrite server idx 0 offset "Hello world"
+ storageServerWrite server idx 1 offset "Hello world"
+ storageServerWrite server idx 2 offset "Hello world"
+
+ -- Make the server reachable.
+ let openServer = simpleLookup [("somewhere", server)]
+
+ -- Try to download the cap which requires three shares to reconstruct.
+
+ result <- liftIO $ download anns cap openServer
+ assertEqual
+ "download should fail with details about unreachable server"
+ (Left (NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = 3, notEnoughDecodedSharesFound = 0}))
+ result
, testProperty "success" $
property $ do
-- If we can recover enough distinct, decodeable shares from the
@@ -169,7 +265,6 @@ tests =
let numServers = Range.linear 1 (fromIntegral paramTotalShares + 1)
serverIDs = Gen.text (Range.singleton 2) Gen.ascii
serverIDs' <- forAll $ Gen.set numServers serverIDs
- -- Constructor <$> arbitrary <*> arbitrary
-- Choose a share distribution. Each element of the resulting
-- list tells us how many shares to place on the next server, for
@@ -196,15 +291,35 @@ 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.
+ --
+ -- ERROR CASES
+ -- Server presents incorrect TLS certificate
+ -- * See https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
+ -- Server returns error response to our request
+ -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/4
+ -- Server returns tampered share data
+ -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/5
]
where
-- A server lookup function that always fails.
- noServers _ = Nothing
+ noServers = pure . Left . URIParseError
-- A server lookup function that finds servers already present in a Map.
- someServers :: Map.Map StorageServerID StorageServer -> LookupServer
- someServers servers = flip Map.lookup servers . parseURL
+ someServers :: Applicative m => Map.Map StorageServerID StorageServer -> LookupServer m
+ someServers servers ann =
+ pure $ case result of
+ Nothing -> Left AnnouncementStructureUnmatched
+ Just ss -> Right ss
where
+ result = do
+ furl <- storageServerAnnouncementFURL ann
+ let serverId = parseURL furl
+ Map.lookup serverId servers
+
-- Exactly match the nonsense makeAnn spits out
parseURL = T.take 2 . T.drop 5
@@ -233,10 +348,9 @@ tests =
-- server identifier.
makeAnn :: StorageServerID -> StorageServerAnnouncement
makeAnn sid =
- StorageServerAnnouncement
+ def
{ storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid
, storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid
- , storageServerAnnouncementPermutationSeed = Nothing
}
-- Generate lists of ints that sum to a given total.