Immutable.hs

-- | Functionality related to retrieving "immutable" shares (mainly CHK).
module Tahoe.Download.Internal.Immutable where

import Control.Exception
import Control.Monad.IO.Class
import Data.ByteString.Base32
import qualified Data.Set as Set
import qualified Data.Text as T
import Network.HTTP.Client (Manager)
import Servant.Client
import Tahoe.Announcement
import Tahoe.CHK.Server (StorageServer (..))
import Tahoe.Download.Internal.Client
import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
import TahoeLAFS.Storage.Client
import Text.Read (readMaybe)

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

    storageServerGetBuckets storageIndex = do
        let clientm = getImmutableShareNumbers (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!!

{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
 a Great Black Swamp server.
-}
announcementToImmutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
announcementToImmutableStorageServer ann =
    case greatBlackSwampURIs ann of
        Nothing -> pure . Left . URIParseError $ ann
        Just uri -> makeImmutableServer uri

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