Skip to content
Snippets Groups Projects
Download.hs 11.5 KiB
Newer Older
  • Learn to ignore specific revisions
  • {-# 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,
    
        announcementToStorageServer,
    
    import Control.Exception (throwIO)
    import Control.Monad.IO.Class (MonadIO (liftIO))
    
    import Data.Binary (decodeOrFail)
    
    import Data.ByteString.Base32 (encodeBase32Unpadded)
    
    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 Network.Connection (TLSSettings (TLSSettingsSimple))
    import Network.HTTP.Client (Manager, ManagerSettings)
    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
            }
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
        | -- | 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)
    
    
    -- TODO The result might need to be in IO in case the URL indicates a
    -- 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 m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
    
    {- | Recover the application data associated with a given capability from the
     given servers, if possible.
    -}
    
    download ::
    
        -- | 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.
    
        -- | Get functions for interacting with a server given its URL.
    
        -- | Either a description of how the recovery failed or the recovered
        -- application data.
    
        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.
    
                ( problems :: [DiscoverError]
                    , discovered :: [(StorageServer, Set.Set ShareNum)]
                    ) <-
                    partitionEithers <$> mapM (discoverShares lookupServer storageIndex) serverList
    
                    then pure . Left . NoReachableServers $ problems
    
                        if (fromIntegral required >) . countDistinctShares $ discovered
    
                            then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered}
    
                            else do
                                -- XXX up to here is probably "locateShares".  now we move in to "fetchShares".
                                let sharemap = makeShareMap discovered
                                -- XXX note shares can contain failures
                                shares <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
                                -- XXX That was brief.  Probably missing some complexity.  now we move on to "decodeShares".
                                -- 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
                                if length onlyDecoded < fromIntegral required
    
                                    then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
    
                                        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 ::
    
        -- | The storage index of the share to download.
    
        -- | 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)
    
            { 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
    
            }
    
    managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
    
    managerSettingsForService _ _ =
        mkManagerSettings tlsSettings sockSettings
      where
        tlsSettings = TLSSettingsSimple True True True
        sockSettings = Nothing
    
    newGBSManager ::
        MonadIO m =>
        [Char] ->
        String ->
        m Manager
    newGBSManager tubid swissnum =
        newTlsManagerWith $
            managerSettingsForService
                (T.pack . init $ tubid)
                (T.pack swissnum)