diff --git a/app/Main.hs b/app/Main.hs
index 2b87ca658b7f582f4d56e79fe8ba82b372be32ce..176fb0d6e28599856d8ad93642b508f6d8f4005c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,33 @@
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 = 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
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 3bdf332b0ccba6e019c06152265b6292a5e00bb7..2459c151c7fafe2b0749c0cec065a6da07f5c89d 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -122,8 +122,14 @@ executable gbs-download
-- Other library packages from which modules are imported.
build-depends:
+ , aeson
, base ^>=4.14.3.0
+ , bytestring
, gbs-downloader
+ , megaparsec
+ , tahoe-chk
+ , text
+ , yaml
-- Directories containing source files.
hs-source-dirs: app
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index a40ae9153db52a58f16d5303f6785bc9f6b169da..0ff1e5c45332d28214662c670e2cc2b1d2585a64 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{- | A high-level interface to downloading share data as bytes from storage
servers.
@@ -79,28 +80,29 @@ data DiscoverError
-- 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
+type LookupServer m = URL -> m (Maybe 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)
+ m (Either DownloadError LB.ByteString)
download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
case Map.toList servers of
[] -> pure . Left $ NoConfiguredServers
serverList -> do
-- 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
then pure $ Left NoReachableServers
else
@@ -119,7 +121,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
if length onlyDecoded < fromIntegral required
then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
else do
- ciphertext <- Tahoe.CHK.decode cap onlyDecoded
+ ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
case ciphertext of
Nothing -> pure $ Left ShareDecodingFailed
Just ct ->
@@ -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
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
+ server <- lookupServer url
case server of
Nothing -> pure $ Left StorageServerUnreachable
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
that claim to have a certain share can easily be retrieved.
@@ -154,6 +161,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.
@@ -165,13 +173,13 @@ 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
+ shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
pure (shareNum, Right $ LB.fromStrict shareBytes)
gbsURLToStorageServer :: MonadIO m => T.Text -> m (Maybe StorageServer)
diff --git a/test/Spec.hs b/test/Spec.hs
index 7751682e367171dbafcdaabc9988fd3807ad792e..bd8b7aacd430d140fe9eb67572345a1f96a2c96a 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -90,8 +90,8 @@ tests =
-- Make the server reachable.
let openServer furl =
if furl == "somewhere"
- then pure server
- else Nothing
+ then pure . pure $ server
+ else pure Nothing
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -138,9 +138,9 @@ tests =
-- Make the server reachable.
let openServer furl =
case furl of
- "somewhere" -> pure somewhere
- "elsewhere" -> pure elsewhere
- _ -> Nothing
+ "somewhere" -> pure . pure $ somewhere
+ "elsewhere" -> pure . pure $ elsewhere
+ _ -> pure Nothing
-- Try to download the cap which requires three shares to reconstruct.
result <- liftIO $ download anns cap openServer
@@ -221,11 +221,11 @@ tests =
]
where
-- A server lookup function that always fails.
- noServers _ = Nothing
+ noServers _ = pure Nothing
-- 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 = pure . flip Map.lookup servers . parseURL
where
-- Exactly match the nonsense makeAnn spits out
parseURL = T.take 2 . T.drop 5