Skip to content
Snippets Groups Projects
Commit 36b7be28 authored by Jean-Paul Calderone's avatar Jean-Paul Calderone
Browse files

Use runGBS from tahoe-great-black-swamp instead of rolling our own

As a bonus, runGBS authenticates the server for us.
parent b921e9eb
No related branches found
No related tags found
1 merge request!14Update dependencies, take advantage of some improvements
# Revision history for gbs-downloader # Revision history for gbs-downloader
## 0.2.0.0 -- YYYY-MM-DD
* The download APIs now only send requests to a storage server after that
storage server is authenticated using information from the NURL.
## 0.1.0.0 -- 2023-08-17 ## 0.1.0.0 -- 2023-08-17
* First version. Released on an unsuspecting world. * First version. Released on an unsuspecting world.
......
...@@ -8,7 +8,7 @@ It aims for bit-for-bit compatibility with the original Python implementation. ...@@ -8,7 +8,7 @@ It aims for bit-for-bit compatibility with the original Python implementation.
### What is the current state? ### What is the current state?
* It can download immutable and mutable shares from Great Black Swamp storage servers. * It can download immutable and mutable shares from Great Black Swamp storage servers.
* It *does not* cryptographically verify the identity of servers it communicates with. * It cryptographically verifies the identity of servers it communicates with.
* It can interpret, decode, and decrypt the data for CHK- and SDMF-encoded shares to recover the plaintext. * It can interpret, decode, and decrypt the data for CHK- and SDMF-encoded shares to recover the plaintext.
## Why does it exist? ## Why does it exist?
......
...@@ -123,7 +123,7 @@ library ...@@ -123,7 +123,7 @@ library
, servant-client-core >=0.16 && <0.21 , servant-client-core >=0.16 && <0.21
, tahoe-chk >=0.2 && <0.3 , tahoe-chk >=0.2 && <0.3
, tahoe-directory >=0.1 && <0.2 , tahoe-directory >=0.1 && <0.2
, tahoe-great-black-swamp >=0.3 && <0.4 , tahoe-great-black-swamp >=0.3.1 && <0.4
, tahoe-ssk >=0.3 && <0.4 , tahoe-ssk >=0.3 && <0.4
, text >=1.2.3.1 && <1.3 , text >=1.2.3.1 && <1.3
, yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
......
...@@ -15,13 +15,14 @@ import Network.Connection ...@@ -15,13 +15,14 @@ import Network.Connection
import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders)) import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Network.HTTP.Types (ByteRange) import Network.HTTP.Types (ByteRange)
import Network.URI (uriToString)
import Servant.Client import Servant.Client
import Tahoe.Announcement import Tahoe.Announcement
import Tahoe.CHK.Server ( import Tahoe.CHK.Server (
StorageServer (..), StorageServer (..),
) )
import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber)) import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
import Text.Read (readMaybe) import TahoeLAFS.Storage.Client (NURL, parseNURL, runGBS)
-- | Make an HTTPS URL. -- | Make an HTTPS URL.
https :: String -> Int -> BaseUrl https :: String -> Int -> BaseUrl
...@@ -138,12 +139,10 @@ type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteStr ...@@ -138,12 +139,10 @@ type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteStr
{- | Create a StorageServer that will speak Great Black Swamp using the given {- | Create a StorageServer that will speak Great Black Swamp using the given
manager to the server at the given host/port. manager to the server at the given host/port.
-} -}
mkWrapper :: GetShareNumbers -> ReadShare -> Manager -> [Char] -> Int -> StorageServer mkWrapper :: GetShareNumbers -> ReadShare -> NURL -> StorageServer
mkWrapper getShareNumbers readShare manager host realPort = mkWrapper getShareNumbers readShare nurl =
StorageServer{..} StorageServer{..}
where where
baseUrl = https host realPort
env = mkClientEnv manager baseUrl
toBase32 = T.unpack . T.toLower . encodeBase32Unpadded toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
storageServerID = undefined storageServerID = undefined
...@@ -152,7 +151,7 @@ mkWrapper getShareNumbers readShare manager host realPort = ...@@ -152,7 +151,7 @@ mkWrapper getShareNumbers readShare manager host realPort =
storageServerRead storageIndex shareNum = do storageServerRead storageIndex shareNum = do
let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
res <- runClientM clientm env res <- runGBS nurl clientm
case res of case res of
Left err -> do Left err -> do
throwIO err throwIO err
...@@ -160,7 +159,7 @@ mkWrapper getShareNumbers readShare manager host realPort = ...@@ -160,7 +159,7 @@ mkWrapper getShareNumbers readShare manager host realPort =
storageServerGetBuckets storageIndex = do storageServerGetBuckets storageIndex = do
let clientm = getShareNumbers (toBase32 storageIndex) let clientm = getShareNumbers (toBase32 storageIndex)
r <- try $ runClientM clientm env r <- try $ runGBS nurl clientm
case r of case r of
Left (_ :: SomeException) -> do Left (_ :: SomeException) -> do
pure mempty pure mempty
...@@ -174,22 +173,10 @@ mkWrapper getShareNumbers readShare manager host realPort = ...@@ -174,22 +173,10 @@ mkWrapper getShareNumbers readShare manager host realPort =
on the server at the given URI. on the server at the given URI.
-} -}
makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer) makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer)
makeServer makeServer getShareNumbers readShare uri =
getShareNumbers pure $ case parseNURL (T.pack $ uriToString id uri "") of
readShare Nothing -> Left AnnouncementStructureUnmatched
URI Just nurl -> Right $ mkWrapper getShareNumbers readShare nurl
{ 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 :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer)
announcementToStorageServer getShareNumbers readShare ann = announcementToStorageServer getShareNumbers readShare ann =
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment