{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {- | A high-level interface to downloading share data as bytes from storage servers. -} module Tahoe.Download ( LookupServer, DownloadError (..), LookupError (..), DiscoverError (..), discoverShares, download, announcementToStorageServer, ) where import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Binary (Word16, decodeOrFail) import qualified Data.ByteString as B import Data.ByteString.Base32 (encodeBase32Unpadded) import Data.ByteString.Base64 (encodeBase64) import qualified Data.ByteString.Lazy as LB 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 (encodeUtf8) import Network.Connection (TLSSettings (TLSSettingsSimple)) import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders)) import Network.HTTP.Client.TLS (mkManagerSettings, newTlsManagerWith) 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 (..), StorageServerID) import Tahoe.CHK.Types (ShareNum, StorageIndex) import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber)) import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShares) import Text.Read (readMaybe) {- | 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 deriving (Eq, Ord, Show) {- | An 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 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. -} 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 m -> -- | Either a description of how the recovery failed or the recovered -- application data. m (Either DownloadError LB.ByteString) download servers cap@Reader{verifier = Verifier{..}} lookupServer = do locationE <- locateShares servers lookupServer storageIndex required case locationE of Left err -> pure $ Left err Right discovered -> do -- XXX note shares can contain failures shares <- fetchShares storageIndex discovered decodeShares cap shares -- | Find out which servers claim to have shares related to a given storage index. locateShares :: MonadIO m => -- | Information about the servers from which to consider downloading shares -- representing the application data. Map.Map StorageServerID StorageServerAnnouncement -> -- | Get functions for interacting with a server given its URL. LookupServer m -> -- | The storage index about which to retrieve information. B.ByteString -> -- | The number of shares we need to locate. If we cannot find at least -- this many shares the result will be an error. Word16 -> -- | Either an error or a guide to where shares are placed. m (Either DownloadError [(StorageServer, Set.Set ShareNum)]) locateShares servers lookupServer storageIndex required = case Map.toList servers of [] -> pure . Left $ NoConfiguredServers serverList -> do -- Ask each server for all shares it has. ( problems :: [DiscoverError] , discovered :: [(StorageServer, Set.Set ShareNum)] ) <- partitionEithers <$> mapM (discoverShares lookupServer storageIndex) serverList if null discovered then pure . Left . NoReachableServers $ problems else if (fromIntegral required >) . countDistinctShares $ discovered then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered} else pure $ Right discovered {- | Given a guide to where shares for a given storage index are placed, download them. -} fetchShares :: MonadIO m => -- | The storage index of the shares to download. B.ByteString -> -- | The guide to where shares are placed. [(StorageServer, Set.Set ShareNum)] -> m [(ShareNum, Either DownloadError LB.ByteString)] fetchShares storageIndex discovered = mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap) where sharemap = makeShareMap discovered {- | Given the results of downloading shares related to a given capability, decode them and decrypt the contents of possible. -} decodeShares :: MonadIO m => -- | The read capability which allows the contents to be decrypted. Reader -> -- | The results of downloading the shares. [(ShareNum, Either DownloadError LB.ByteString)] -> m (Either DownloadError LB.ByteString) decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares = -- Filter down to shares we actually got. let someShares = filter (isRight . snd) shares fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares in if length onlyDecoded < fromIntegral required then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded} else do ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded case ciphertext of Nothing -> pure $ Left ShareDecodingFailed Just ct -> pure . Right $ Tahoe.CHK.Encrypt.decrypt readKey ct {- | Figure the total number of distinct shares reported by all of the servers we asked. -} countDistinctShares :: Ord b => [(a, Set.Set b)] -> Int countDistinctShares = Set.size . foldl' Set.union mempty . map snd {- | Ask one server which shares it has related to the storage index in question. -} discoverShares :: MonadIO m => LookupServer m -> StorageIndex -> (StorageServerID, StorageServerAnnouncement) -> m (Either DiscoverError (StorageServer, Set.Set ShareNum)) discoverShares lookupServer storageIndex (_sid, sann) = do 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. -} makeShareMap :: Ord k => [(v, Set.Set k)] -> Map.Map k [v] makeShareMap locations = foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (const [k]) v) <$> 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. ShareNum -> -- | The servers which we have a reasonable belief could hold a copy of the -- share. It is common for there to be only one server holding each share -- but nothing *prevents* multiple servers from having one. In this case we -- could download the share from both of them, perhaps. [StorageServer] -> -- | The bytes of the share or some error that was encountered during -- download. 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 <- liftIO $ storageServerRead s storageIndex shareNum pure (shareNum, Right $ LB.fromStrict shareBytes) 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 (Either LookupError StorageServer) makeServer URI { uriScheme = "pb:" , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)} , uriPath = ('/' : swissnum) , uriFragment = "" -- Where's the #v=1 ??? } = case readMaybe port of Nothing -> pure . Left . PortParseError $ port Just realPort -> do manager <- liftIO $ newGBSManager tubid swissnum let baseUrl = https host realPort env = mkClientEnv manager baseUrl toBase32 = T.unpack . T.toLower . encodeBase32Unpadded storageServerID = undefined storageServerWrite = undefined storageServerRead storageIndex shareNum = do let clientm = readImmutableShares (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing res <- runClientM clientm env case res of Left err -> throwIO err Right bs -> pure bs storageServerGetBuckets storageIndex = do let clientm = getImmutableShareNumbers (toBase32 storageIndex) res <- runClientM clientm env case res of Left err -> throwIO err Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!! pure . Right $ StorageServer{..} makeServer _ = pure . Left $ AnnouncementStructureUnmatched https :: String -> Int -> BaseUrl https host port = BaseUrl { baseUrlScheme = Https , baseUrlHost = host , baseUrlPort = port , baseUrlPath = "" } managerSettingsForService :: T.Text -> T.Text -> ManagerSettings managerSettingsForService _ swissnum = (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize} where tlsSettings = TLSSettingsSimple True True True sockSettings = Nothing authorize req = req { requestHeaders = ( "Authorization" , encodeUtf8 $ T.concat ["Tahoe-LAFS ", encodeBase64 . encodeUtf8 $ swissnum] ) : requestHeaders req } newGBSManager :: MonadIO m => [Char] -> String -> m Manager newGBSManager tubid swissnum = newTlsManagerWith $ managerSettingsForService (T.pack . init $ tubid) (T.pack swissnum)