Client.hs

module Tahoe.Client where

import Control.Exception (SomeException (SomeException))
import Control.Monad.IO.Class (MonadIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Set as Set
import qualified Data.Text as T
import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
import Network.URI (URI (URI, uriAuthority, uriFragment, uriPath, uriScheme), URIAuth (URIAuth, uriPort, uriRegName, uriUserInfo))
import Servant.Client (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
import Text.Read (readMaybe)

-- | 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 StorageClient = StorageClient
    { storageClientManager :: Manager
    , storageClientBaseUrl :: BaseUrl
    }

makeGBSManager :: MonadIO m => URI -> m (Either LookupError Manager)
makeGBSManager
    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 <- newGBSManager tubid swissnum
                wrapGreatBlackSwamp

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

--                 pure . Right $ wrapGreatBlackSwamp manager host realPort
-- makeServer _ = pure . Left $ AnnouncementStructureUnmatched

-- Parameterize readImmutableShare and getImmutableShareNumbers to
-- wrapGreatBlackSwamp, then use it for both mutables and immutables.  Then
-- use the same download function for both!

{- | Create a StorageClient that will speak Great Black Swamp using the given
 manager to the server at the given host/port.
-}
wrapGreatBlackSwamp :: [Char] -> Int -> Manager -> StorageServer
wrapGreatBlackSwamp host realPort manager =
    StorageClient{..}
  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
        res <- runClientM clientm env
        case res of
            Left err -> 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
                pure mempty
            Right res -> do
                case res of
                    Left err -> 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
            }

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