diff --git a/app/Main.hs b/app/Main.hs index 47f3151f79d9ff0e41db5bf49066d2dae177d0b1..157e0186750e0a957a19e66e419fb7cc993c332d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,7 +8,7 @@ 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 Tahoe.Download (announcementToImmutableStorageServer, download) import Text.Megaparsec (parse) main :: IO () @@ -22,7 +22,7 @@ main = do let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap) -- Download & decode the shares - result <- download announcements cap announcementToStorageServer + result <- download announcements cap announcementToImmutableStorageServer -- Show the result putStrLn "Your result:" diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs index 77f701aab1baf9ce0770a7feb77ad14a8db73380..9674409b0741aed145690fe24fadec5b1e3d9700 100644 --- a/src/Tahoe/Download.hs +++ b/src/Tahoe/Download.hs @@ -8,7 +8,7 @@ module Tahoe.Download ( DiscoverError (..), discoverShares, download, - announcementToStorageServer, + announcementToImmutableStorageServer, ) where import Control.Exception (Exception (displayException), SomeException, try) @@ -21,8 +21,7 @@ import Data.Either (partitionEithers, rights) import Data.List (foldl') import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Network.URI (URI (..), URIAuth (..)) -import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs) +import Tahoe.Announcement (StorageServerAnnouncement) import qualified Tahoe.CHK import Tahoe.CHK.Capability (Reader (..), Verifier (..)) import qualified Tahoe.CHK.Encrypt @@ -30,7 +29,6 @@ import Tahoe.CHK.Server (StorageServer (..), StorageServerID) import Tahoe.CHK.Types (ShareNum, StorageIndex) import Tahoe.Download.Internal.Client import Tahoe.Download.Internal.Immutable -import Text.Read (readMaybe) print' :: MonadIO m => String -> m () -- print' = liftIO . print @@ -42,55 +40,6 @@ type DownloadTask = (ShareNum, StorageServer) -- | A downloaded share type Share = (ShareNum, LB.ByteString) -{- | An unrecoverable problem arose while attempting to download and/or read - some application data. --} -data DownloadError - = -- | The configuration included no candidate servers from which to download. - NoConfiguredServers - | -- | Across all of the configured servers, none were actually connectable. - 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, - -- did not verify enough shares - NotEnoughShares - { notEnoughSharesNeeded :: Int - , notEnoughSharesFound :: Int - } - | -- | Across all of the shares that we could download, fewer than the - -- required number could actually be decoded. - NotEnoughDecodedShares - { notEnoughDecodedSharesNeeded :: Int - , notEnoughDecodedSharesFound :: Int - } - | -- | Enough syntactically valid shares were recovered but they could not - -- be interpreted. - ShareDecodingFailed - | -- | 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) - -{- | 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 - | -- | An announcement included a location we could not interpret. - StorageServerLocationUnsupported - | StorageServerUnreachable LookupError - | StorageServerCommunicationError String - deriving (Eq, Ord, Show) - -{- | 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. -} @@ -248,40 +197,3 @@ downloadShare storageIndex (shareNum, s) = do 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 diff --git a/src/Tahoe/Download/Internal/Client.hs b/src/Tahoe/Download/Internal/Client.hs index 4cccaa3eea81d5d229592e8c144e520948c1df5a..c7e9767c190cb18e572658f8e971bf9b638afa37 100644 --- a/src/Tahoe/Download/Internal/Client.hs +++ b/src/Tahoe/Download/Internal/Client.hs @@ -9,6 +9,10 @@ import Network.Connection import Network.HTTP.Client import Network.HTTP.Client.TLS import Servant.Client +import Tahoe.Announcement +import Tahoe.CHK.Server ( + StorageServer, + ) -- | Make an HTTPS URL. https :: String -> Int -> BaseUrl @@ -54,3 +58,62 @@ newGBSManager tubid swissnum = managerSettingsForService (T.pack . init $ tubid) (T.pack swissnum) + +{- | An unrecoverable problem arose while attempting to download and/or read + some application data. +-} +data DownloadError + = -- | The configuration included no candidate servers from which to download. + NoConfiguredServers + | -- | Across all of the configured servers, none were actually connectable. + 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, + -- did not verify enough shares + NotEnoughShares + { notEnoughSharesNeeded :: Int + , notEnoughSharesFound :: Int + } + | -- | Across all of the shares that we could download, fewer than the + -- required number could actually be decoded. + NotEnoughDecodedShares + { notEnoughDecodedSharesNeeded :: Int + , notEnoughDecodedSharesFound :: Int + } + | -- | Enough syntactically valid shares were recovered but they could not + -- be interpreted. + ShareDecodingFailed + | -- | 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) + +{- | 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 + | -- | An announcement included a location we could not interpret. + StorageServerLocationUnsupported + | StorageServerUnreachable LookupError + | StorageServerCommunicationError String + deriving (Eq, Ord, Show) + +{- | The type of a function that can produce a concrete StorageServer from + that server's announcement. +-} +type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer) + +-- | 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) diff --git a/src/Tahoe/Download/Internal/Immutable.hs b/src/Tahoe/Download/Internal/Immutable.hs index 02a1153c2f92f0f074497c30c46e1be267ec5d00..b6996525477655d8ceca855d15112baa2fee02b7 100644 --- a/src/Tahoe/Download/Internal/Immutable.hs +++ b/src/Tahoe/Download/Internal/Immutable.hs @@ -1,21 +1,24 @@ module Tahoe.Download.Internal.Immutable where import Control.Exception +import Control.Monad.IO.Class import Data.ByteString.Base32 import qualified Data.Set as Set import qualified Data.Text as T import Network.HTTP.Client (Manager) import Servant.Client +import Tahoe.Announcement import Tahoe.CHK.Server (StorageServer (..)) import Tahoe.Download.Internal.Client import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber)) import TahoeLAFS.Storage.Client +import Text.Read (readMaybe) {- | 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 = +mkImmutableWrapper :: Manager -> [Char] -> Int -> StorageServer +mkImmutableWrapper manager host realPort = StorageServer{..} where baseUrl = https host realPort @@ -45,3 +48,28 @@ wrapGreatBlackSwamp manager host realPort = Left err -> do throwIO err Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!! + +{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at + a Great Black Swamp server. +-} +announcementToImmutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer) +announcementToImmutableStorageServer ann = + case greatBlackSwampURIs ann of + Nothing -> pure . Left . URIParseError $ ann + Just uri -> makeImmutableServer uri + +makeImmutableServer :: MonadIO m => URI -> m (Either LookupError StorageServer) +makeImmutableServer + 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 + manager <- liftIO $ newGBSManager tubid swissnum + + pure . Right $ mkImmutableWrapper manager host realPort +makeImmutableServer _ = pure . Left $ AnnouncementStructureUnmatched