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