Client.hs

{- | Functionality related to acting as a client for the Great Black Swamp
 protocol.
-}
module Tahoe.Download.Internal.Client where

import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import Data.ByteString.Base32
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding
import Network.Connection
import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
import Network.HTTP.Client.TLS
import Network.HTTP.Types (ByteRange)
import Servant.Client
import Tahoe.Announcement
import Tahoe.CHK.Server (
    StorageServer (..),
 )
import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
import Text.Read (readMaybe)

-- | 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)

{- | 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)

{- | A problem was encountered attempting to deserialize bytes to a structured
 representation of some value.
-}
data DeserializeError = UnknownDeserializeError -- add more later?

type GetShareNumbers = String -> ClientM (CBORSet ShareNumber)
type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteString

{- | Create a StorageServer that will speak Great Black Swamp using the given
 manager to the server at the given host/port.
-}
mkWrapper :: GetShareNumbers -> ReadShare -> Manager -> [Char] -> Int -> StorageServer
mkWrapper getShareNumbers readShare 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 = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
        res <- runClientM clientm env
        case res of
            Left err -> do
                throwIO err
            Right bs -> pure bs

    storageServerGetBuckets storageIndex = do
        let clientm = getShareNumbers (toBase32 storageIndex)
        r <- try $ runClientM clientm env
        case r of
            Left (_ :: SomeException) -> do
                pure mempty
            Right res -> do
                case res of
                    Left err -> do
                        throwIO err
                    Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!

{- | If possible, populate a StorageServer with functions for operating on data
  on the server at the given URI.
-}
makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer)
makeServer
    getShareNumbers
    readShare
    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 $ mkWrapper getShareNumbers readShare manager host realPort
makeServer _ _ _ = pure . Left $ AnnouncementStructureUnmatched

announcementToStorageServer :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer)
announcementToStorageServer getShareNumbers readShare ann =
    case greatBlackSwampURIs ann of
        Nothing -> pure . Left . URIParseError $ ann
        Just uri -> makeServer getShareNumbers readShare uri