Skip to content
Snippets Groups Projects
Commit 594cc057 authored by Jean-Paul Calderone's avatar Jean-Paul Calderone
Browse files

Get some more of the pieces working well together

Also sketch out a demo program
parent f654fcea
No related branches found
No related tags found
1 merge request!2Incorporate tahoe-great-black-swamp to do share downloads using GBS
module Main where module Main where
-- import Data.Aeson
import qualified Data.ByteString as B
import Data.Text
import Data.Yaml (decodeEither')
import System.Environment (getArgs)
import Tahoe.CHK.Capability
import Tahoe.Download (download, gbsURLToStorageServer)
import Text.Megaparsec (parse)
main :: IO () main :: IO ()
main = do main = do
putStrLn "Hello, Haskell!" [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
-- 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
-- Show the result
print ("Your plaintext:" :: Data.Text.Text)
print plaintext
...@@ -122,8 +122,14 @@ executable gbs-download ...@@ -122,8 +122,14 @@ executable gbs-download
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: build-depends:
, aeson
, base ^>=4.14.3.0 , base ^>=4.14.3.0
, bytestring
, gbs-downloader , gbs-downloader
, megaparsec
, tahoe-chk
, text
, yaml
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: app hs-source-dirs: app
......
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- | A high-level interface to downloading share data as bytes from storage {- | A high-level interface to downloading share data as bytes from storage
servers. servers.
...@@ -79,28 +80,29 @@ data DiscoverError ...@@ -79,28 +80,29 @@ data DiscoverError
-- Tor-based route to the server. In this case we might need to launch a Tor -- 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 -- 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! -- circuit. All of which require I/O. But we can always refactor later!
type LookupServer = URL -> Maybe StorageServer type LookupServer m = URL -> m (Maybe StorageServer)
{- | Recover the application data associated with a given capability from the {- | Recover the application data associated with a given capability from the
given servers, if possible. given servers, if possible.
-} -}
download :: download ::
MonadIO m =>
-- | Information about the servers from which to consider downloading shares -- | Information about the servers from which to consider downloading shares
-- representing the application data. -- representing the application data.
Map.Map StorageServerID StorageServerAnnouncement -> Map.Map StorageServerID StorageServerAnnouncement ->
-- | The read capability for the application data. -- | The read capability for the application data.
Reader -> Reader ->
-- | Get functions for interacting with a server given its URL. -- | Get functions for interacting with a server given its URL.
LookupServer -> LookupServer m ->
-- | Either a description of how the recovery failed or the recovered -- | Either a description of how the recovery failed or the recovered
-- application data. -- application data.
IO (Either DownloadError LB.ByteString) m (Either DownloadError LB.ByteString)
download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer = download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
case Map.toList servers of case Map.toList servers of
[] -> pure . Left $ NoConfiguredServers [] -> pure . Left $ NoConfiguredServers
serverList -> do serverList -> do
-- Ask each server for all shares it has. -- Ask each server for all shares it has.
discovered <- rights <$> mapM (discoverShares lookupServer storageIndex) serverList :: IO [(StorageServer, Set.Set ShareNum)] (discovered :: [(StorageServer, Set.Set ShareNum)]) <- rights <$> mapM (discoverShares lookupServer storageIndex) serverList
if null discovered if null discovered
then pure $ Left NoReachableServers then pure $ Left NoReachableServers
else else
...@@ -119,7 +121,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer = ...@@ -119,7 +121,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
if length onlyDecoded < fromIntegral required if length onlyDecoded < fromIntegral required
then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded} then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
else do else do
ciphertext <- Tahoe.CHK.decode cap onlyDecoded ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
case ciphertext of case ciphertext of
Nothing -> pure $ Left ShareDecodingFailed Nothing -> pure $ Left ShareDecodingFailed
Just ct -> Just ct ->
...@@ -134,16 +136,21 @@ countDistinctShares = Set.size . foldl' Set.union mempty . map snd ...@@ -134,16 +136,21 @@ countDistinctShares = Set.size . foldl' Set.union mempty . map snd
{- | Ask one server which shares it has related to the storage index in {- | Ask one server which shares it has related to the storage index in
question. 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 discoverShares lookupServer storageIndex (_sid, sann) = do
case storageServerAnnouncementFURL sann of case storageServerAnnouncementFURL sann of
Nothing -> pure $ Left StorageServerLocationUnknown Nothing -> pure $ Left StorageServerLocationUnknown
Just url -> do Just url -> do
let server = lookupServer url server <- lookupServer url
case server of case server of
Nothing -> pure $ Left StorageServerUnreachable Nothing -> pure $ Left StorageServerUnreachable
Just ss@StorageServer{storageServerGetBuckets} -> Just ss@StorageServer{storageServerGetBuckets} ->
Right . (ss,) <$> storageServerGetBuckets storageIndex liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
{- | Invert the mapping implied by the list of two tuples so that the servers {- | 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. that claim to have a certain share can easily be retrieved.
...@@ -154,6 +161,7 @@ makeShareMap locations = ...@@ -154,6 +161,7 @@ makeShareMap locations =
-- | Download the bytes of a share from one (or more!) of the given servers. -- | Download the bytes of a share from one (or more!) of the given servers.
downloadShare :: downloadShare ::
MonadIO m =>
-- | The storage index of the share to download. -- | The storage index of the share to download.
StorageIndex -> StorageIndex ->
-- | The number of the share to download. -- | The number of the share to download.
...@@ -165,13 +173,13 @@ downloadShare :: ...@@ -165,13 +173,13 @@ downloadShare ::
[StorageServer] -> [StorageServer] ->
-- | The bytes of the share or some error that was encountered during -- | The bytes of the share or some error that was encountered during
-- download. -- download.
IO (ShareNum, Either DownloadError LB.ByteString) m (ShareNum, Either DownloadError LB.ByteString)
downloadShare _ shareNum [] = pure (shareNum, Left NoServers) downloadShare _ shareNum [] = pure (shareNum, Left NoServers)
downloadShare storageIndex shareNum (s : _) = do downloadShare storageIndex shareNum (s : _) = do
-- TODO: There might be more servers. We could try them if this fails. -- 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 -- 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. -- we might also need retry logic up a level or two from here.
shareBytes <- storageServerRead s storageIndex shareNum shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
pure (shareNum, Right $ LB.fromStrict shareBytes) pure (shareNum, Right $ LB.fromStrict shareBytes)
gbsURLToStorageServer :: MonadIO m => T.Text -> m (Maybe StorageServer) gbsURLToStorageServer :: MonadIO m => T.Text -> m (Maybe StorageServer)
......
...@@ -90,8 +90,8 @@ tests = ...@@ -90,8 +90,8 @@ tests =
-- Make the server reachable. -- Make the server reachable.
let openServer furl = let openServer furl =
if furl == "somewhere" if furl == "somewhere"
then pure server then pure . pure $ server
else Nothing else pure Nothing
-- Try to download the cap which requires three shares to reconstruct. -- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer result <- liftIO $ download anns cap openServer
...@@ -138,9 +138,9 @@ tests = ...@@ -138,9 +138,9 @@ tests =
-- Make the server reachable. -- Make the server reachable.
let openServer furl = let openServer furl =
case furl of case furl of
"somewhere" -> pure somewhere "somewhere" -> pure . pure $ somewhere
"elsewhere" -> pure elsewhere "elsewhere" -> pure . pure $ elsewhere
_ -> Nothing _ -> pure Nothing
-- Try to download the cap which requires three shares to reconstruct. -- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer result <- liftIO $ download anns cap openServer
...@@ -221,11 +221,11 @@ tests = ...@@ -221,11 +221,11 @@ tests =
] ]
where where
-- A server lookup function that always fails. -- A server lookup function that always fails.
noServers _ = Nothing noServers _ = pure Nothing
-- A server lookup function that finds servers already present in a Map. -- A server lookup function that finds servers already present in a Map.
someServers :: Map.Map StorageServerID StorageServer -> LookupServer someServers :: Applicative m => Map.Map StorageServerID StorageServer -> LookupServer m
someServers servers = flip Map.lookup servers . parseURL someServers servers = pure . flip Map.lookup servers . parseURL
where where
-- Exactly match the nonsense makeAnn spits out -- Exactly match the nonsense makeAnn spits out
parseURL = T.take 2 . T.drop 5 parseURL = T.take 2 . T.drop 5
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment