diff --git a/app/Main.hs b/app/Main.hs
index 176fb0d6e28599856d8ad93642b508f6d8f4005c..e07bda381ed0b08c5ec090a0ade5f7d4d2cf3f49 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,12 +1,13 @@
module Main where
--- import Data.Aeson
import qualified Data.ByteString as B
+import qualified Data.Map.Strict as Map
import Data.Text
-import Data.Yaml (decodeEither')
+import Data.Yaml (FromJSON (parseJSON), Value (Object), decodeEither', (.:))
import System.Environment (getArgs)
+import Tahoe.Announcement (StorageServerAnnouncement, StorageServerID)
import Tahoe.CHK.Capability
-import Tahoe.Download (download, gbsURLToStorageServer)
+import Tahoe.Download (announcementToStorageServer, download)
import Text.Megaparsec (parse)
main :: IO ()
@@ -14,20 +15,24 @@ main = do
[announcementPath, readCap] <- getArgs
-- Load server announcements
announcementsBytes <- B.readFile announcementPath
-
- -- XXX announcementsBytes is not quite the right shape for `Map
- -- StorageServerID StorageServerAnnouncement` - need to massage it a
- -- little bit somehow?
- -- let Just yaml = decodeEither' announcementBytes :: Either ParseException (Maybe Value)
- let Right announcements = decodeEither' announcementsBytes
+ let Right (Announcements announcements) = decodeEither' announcementsBytes
+ print ("Your announcements:" :: Data.Text.Text)
+ print announcements
-- Accept & parse read capability
let Right (CHKReader cap) = parse pCapability "<argv>" (Data.Text.pack readCap)
- -- Download the shares
- -- Decode them
- Right plaintext <- download announcements cap gbsURLToStorageServer
+ -- Download & decode the shares
+ result <- download announcements cap announcementToStorageServer
-- Show the result
- print ("Your plaintext:" :: Data.Text.Text)
- print plaintext
+ print ("Your result:" :: Data.Text.Text)
+ print result
+
+newtype Announcements = Announcements (Map.Map StorageServerID StorageServerAnnouncement)
+
+instance FromJSON Announcements where
+ parseJSON (Object v) = do
+ storage <- v .: "storage"
+ pure $ Announcements storage
+ parseJSON _ = error "unsupported announcements format"
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 2459c151c7fafe2b0749c0cec065a6da07f5c89d..c462d6915dfec014a811cb7695d12d012b9507ff 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -75,7 +75,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,6 +87,7 @@ library
-- Other library packages from which modules are imported.
build-depends:
+ , aeson
, base ^>=4.14.3.0
, base32
, binary
@@ -98,6 +101,7 @@ library
, tahoe-chk
, tahoe-great-black-swamp
, text
+ , yaml
-- Directories containing source files.
hs-source-dirs: src
@@ -125,6 +129,7 @@ executable gbs-download
, aeson
, base ^>=4.14.3.0
, bytestring
+ , containers
, gbs-downloader
, megaparsec
, tahoe-chk
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index 0ff1e5c45332d28214662c670e2cc2b1d2585a64..f25bac673470c6b64a9dcd5aace7333348596ed2 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -7,29 +7,32 @@
module Tahoe.Download (
LookupServer,
DownloadError (..),
+ LookupError (..),
+ DiscoverError (..),
discoverShares,
download,
- gbsURLToStorageServer,
+ announcementToStorageServer,
) where
import Control.Exception (throwIO)
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.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.URI (URI (..), URIAuth (..), parseURI)
+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 (ShareNumber (ShareNumber))
import TahoeLAFS.Storage.Client (readImmutableShares)
@@ -42,7 +45,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,
@@ -73,14 +76,14 @@ data DiscoverError
StorageServerLocationUnknown
| -- | An announcement included a location we could not interpret.
StorageServerLocationUnsupported
- | StorageServerUnreachable
+ | StorageServerUnreachable LookupError
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 m = URL -> m (Maybe StorageServer)
+type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
{- | Recover the application data associated with a given capability from the
given servers, if possible.
@@ -102,9 +105,12 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
[] -> pure . Left $ NoConfiguredServers
serverList -> do
-- Ask each server for all shares it has.
- (discovered :: [(StorageServer, Set.Set ShareNum)]) <- rights <$> mapM (discoverShares lookupServer storageIndex) serverList
+ ( 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}
@@ -143,14 +149,11 @@ discoverShares ::
(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
- server <- lookupServer url
- case server of
- Nothing -> pure $ Left StorageServerUnreachable
- Just ss@StorageServer{storageServerGetBuckets} ->
- liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
+ server <- lookupServer sann
+ case server of
+ Left e -> pure . Left . StorageServerUnreachable $ e
+ Right ss@StorageServer{storageServerGetBuckets} ->
+ liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
{- | 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.
@@ -182,13 +185,19 @@ downloadShare storageIndex shareNum (s : _) = do
shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
pure (shareNum, Right $ LB.fromStrict shareBytes)
-gbsURLToStorageServer :: MonadIO m => T.Text -> m (Maybe StorageServer)
-gbsURLToStorageServer url =
- case parseURI (T.unpack url) of
- Nothing -> pure Nothing
+data LookupError
+ = URIParseError StorageServerAnnouncement
+ | PortParseError String
+ | AnnouncementStructureUnmatched
+ deriving (Eq, Ord, Show)
+
+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 (Maybe StorageServer)
+makeServer :: MonadIO m => URI -> m (Either LookupError StorageServer)
makeServer
URI
{ uriScheme = "pb"
@@ -197,7 +206,7 @@ makeServer
, uriFragment = "#v=1"
} =
case readMaybe port of
- Nothing -> pure Nothing
+ Nothing -> pure . Left . PortParseError $ port
Just realPort -> do
manager <- liftIO $ newManager (managerSettingsForService (T.pack tubid) (T.pack swissnum))
@@ -216,8 +225,8 @@ makeServer
Right bs -> pure bs
storageServerGetBuckets = undefined
- pure $ Just StorageServer{..}
-makeServer _ = pure Nothing
+ pure . Right $ StorageServer{..}
+makeServer _ = pure . Left $ AnnouncementStructureUnmatched
https :: String -> Int -> BaseUrl
https host port =
diff --git a/test/Spec.hs b/test/Spec.hs
index bd8b7aacd430d140fe9eb67572345a1f96a2c96a..e056b04cdfa06cc2dd4ce9d58962d24de29d2c57 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -18,13 +18,14 @@ 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 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 (StorageServerUnreachable), DownloadError (..), LookupError (..), LookupServer, download)
import Tahoe.Server (memoryStorageServer)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertEqual, testCase)
@@ -48,22 +49,24 @@ tests =
, 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 =
+ StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Nothing
+ , storageServerAnnouncementNick = Just "unreachable"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ anns =
Map.fromList
[
( "v0-abc123"
- , StorageServerAnnouncement
- { storageServerAnnouncementFURL = Nothing
- , storageServerAnnouncementNick = Just "unreachable"
- , storageServerAnnouncementPermutationSeed = Nothing
- }
+ , 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
@@ -88,10 +91,10 @@ tests =
storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world"
-- Make the server reachable.
- let openServer furl =
- if furl == "somewhere"
+ let openServer StorageServerAnnouncement{storageServerAnnouncementFURL} =
+ if storageServerAnnouncementFURL == Just "somewhere"
then pure . pure $ server
- else pure Nothing
+ else pure . Left $ AnnouncementStructureUnmatched
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -136,11 +139,11 @@ tests =
storageServerWrite elsewhere idx 0 offset "Hello world"
-- Make the server reachable.
- let openServer furl =
- case furl of
- "somewhere" -> pure . pure $ somewhere
- "elsewhere" -> pure . pure $ elsewhere
- _ -> pure Nothing
+ let openServer StorageServerAnnouncement{storageServerAnnouncementFURL} =
+ case storageServerAnnouncementFURL of
+ Just "somewhere" -> pure . pure $ somewhere
+ Just "elsewhere" -> pure . pure $ elsewhere
+ _ -> pure . Left $ AnnouncementStructureUnmatched
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -221,12 +224,20 @@ tests =
]
where
-- A server lookup function that always fails.
- noServers _ = pure Nothing
+ noServers = pure . Left . URIParseError
-- A server lookup function that finds servers already present in a Map.
someServers :: Applicative m => Map.Map StorageServerID StorageServer -> LookupServer m
- someServers servers = pure . flip Map.lookup servers . parseURL
+ 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