Client.hs

module Tahoe.Download.Internal.Client where

import Control.Monad.IO.Class
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Text as T
import Data.Text.Encoding
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
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)

data DeserializeError = UnknownDeserializeError -- add more later?