Download.hs

{- | 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 (Exception (displayException), SomeException, throwIO, try)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Bifunctor (Bifunctor (first, second))
import Data.Binary (Word16, decodeOrFail)
import qualified Data.ByteString as B
import Data.ByteString.Base32 (encodeBase32Unpadded)
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as LB
import Data.Either (partitionEithers, rights)
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, readImmutableShare)
import Text.Read (readMaybe)

print' :: MonadIO m => String -> m ()
-- print' = liftIO . print
print' = const $ pure ()

-- | Partially describe one share download.
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.
-}
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
    print' ("Going to download: " <> show storageIndex)
    locationE <- locateShares servers lookupServer storageIndex required
    print' "Finished locating shares"
    case locationE of
        Left err -> do
            print' "Got an error locating shares"
            pure $ Left err
        Right discovered -> do
            print' "Found some shares, fetching them"
            -- XXX note shares can contain failures
            shares <- executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered)
            print' "Fetched the shares, decoding them"
            s <- decodeShares cap shares
            print' "Decoded them"
            pure s

{- | Execute each download task sequentially and return only the successful
 results.
-}
executeDownloadTasks ::
    MonadIO m =>
    -- | The storage index of the shares to download.
    StorageIndex ->
    -- | The downloads to attempt.
    [DownloadTask] ->
    -- | The results of all successful downloads.
    m [Share]
executeDownloadTasks storageIndex tasks = do
    downloadResults <- mapM (downloadShare storageIndex) tasks
    pure . rights $ inject <$> downloadResults
  where
    inject (a, b) = (a,) <$> b

-- | 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
            print' "Discovering shares"
            -- 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 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.
    [Share] ->
    m (Either DownloadError LB.ByteString)
decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares =
    -- Filter down to shares we actually got.
    let fewerShares = second decodeOrFail <$> shares
        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
                print' "Interpreted shares, decoding them"
                ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
                print' "Decoded them, might decrypt them"
                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
    print' "Looking up server from announcement"
    server <- lookupServer sann
    print' "Looked it up"
    case server of
        Left e -> pure . Left . StorageServerUnreachable $ e
        Right ss@StorageServer{storageServerGetBuckets} -> do
            print' $ "Getting buckets for " <> show storageIndex
            buckets <- liftIO $ try (storageServerGetBuckets storageIndex)
            let massaged = first (StorageServerCommunicationError . (displayException :: SomeException -> String)) buckets
            print' $ "Got them " <> show massaged
            pure $ (ss,) <$> massaged

{- | Expand a one-to-many mapping into a list of pairs with each of the "many"
   values as the first element and the corresponding "one" value as the second
   element.
-}
makeDownloadTasks :: Ord k => (v, Set.Set k) -> [(k, v)]
makeDownloadTasks (v, ks) = zip (Set.toList ks) (repeat v)

-- | 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 ->
    -- | Addressing information about the share to download.
    DownloadTask ->
    -- | The bytes of the share or some error that was encountered during
    -- download.
    m (ShareNum, Either DownloadError LB.ByteString)
downloadShare storageIndex (shareNum, s) = do
    print' $ "Going to download " <> show storageIndex <> " " <> show shareNum
    shareBytes <- liftIO $ try (storageServerRead s storageIndex shareNum)
    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

{- | 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 =
    StorageServer{..}
  where
    baseUrl = https host realPort
    env = mkClientEnv manager baseUrl
    toBase32 = T.unpack . T.toLower . encodeBase32Unpadded

    storageServerID = undefined

    storageServerWrite = undefined

    storageServerRead storageIndex shareNum = do
        let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
        print' "Going to read from a server"
        res <- runClientM clientm env
        print' "Did it"
        case res of
            Left err -> do
                print' "Going to throw a damn IO error"
                throwIO err
            Right bs -> pure bs

    storageServerGetBuckets storageIndex = do
        let clientm = getImmutableShareNumbers (toBase32 storageIndex)
        print' "Going to get share numbers"
        r <- try $ runClientM clientm env
        case r of
            Left (err :: SomeException) -> do
                print' $ "A PROBLEM ARISES " <> show err
                pure mempty
            Right res -> do
                print' "Got the share numbers"
                case res of
                    Left err -> do
                        print' "Going to throw another IO error!!"
                        throwIO err
                    Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!

-- | Make an HTTPS URL.
https :: String -> Int -> BaseUrl
https host port =
    BaseUrl
        { baseUrlScheme = Https
        , baseUrlHost = host
        , baseUrlPort = port
        , baseUrlPath = ""
        }

{- | Make an HTTPS manager for the given SPKI hash and swissnum.

 The SPKI hash is _not_ used to authenticate the server!  See
 https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
-}
managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
managerSettingsForService _ swissnum =
    (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}
  where
    tlsSettings = TLSSettingsSimple True True True
    sockSettings = Nothing
    swissnumBytes = encodeUtf8 swissnum
    swissnumBase64 = Base64.encode swissnumBytes
    headerCompleteBytes = B.concat ["Tahoe-LAFS ", swissnumBase64]
    authorize req =
        req
            { requestHeaders =
                ( "Authorization"
                , headerCompleteBytes
                ) :
                requestHeaders req
            }

-- | Make a manager suitable for use with a Great Black Swamp server.
newGBSManager ::
    MonadIO m =>
    [Char] ->
    String ->
    m Manager
newGBSManager tubid swissnum =
    newTlsManagerWith $
        managerSettingsForService
            (T.pack . init $ tubid)
            (T.pack swissnum)