diff --git a/flake.lock b/flake.lock
index b268d888768c5de6920c637dcf97bfc0f341961f..ab825dacd4422b8bcff9b4f5c870877df3581893 100644
--- a/flake.lock
+++ b/flake.lock
@@ -255,11 +255,11 @@
"pre-commit-hooks": "pre-commit-hooks_3"
},
"locked": {
- "lastModified": 1677773826,
- "narHash": "sha256-xJmOtHugr4k2zNhP/AF6JdIUnIEyM+TEspLn2n5kloc=",
+ "lastModified": 1681762240,
+ "narHash": "sha256-+PLx9xHBvV70dA7Gy/+YTH1w3PcSOrGV0z0rGxts8jU=",
"ref": "main",
- "rev": "d3a83fdd9563546ca41771186427638e685a2e2b",
- "revCount": 9,
+ "rev": "a51e591b7fdf8881ac0237452691df7b1aceecd3",
+ "revCount": 10,
"type": "git",
"url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
},
@@ -496,19 +496,19 @@
"nixpkgs": [
"hs-flake-utils",
"nixpkgs"
+ ],
+ "tahoe-chk": [
+ "tahoe-chk"
]
},
"locked": {
- "lastModified": 1682446800,
- "narHash": "sha256-Vxl4dLpoRp2svWTx0w74m7PeVPMlkSu/XOZAHccOUDs=",
- "ref": "refs/tags/0.1.0.1",
- "rev": "b81cc3fcdb0107d369a636fdc5a17cf174dff2ea",
- "revCount": 143,
+ "lastModified": 1683050544,
+ "narHash": "sha256-P08OTDBLUtwxp1scC44/xiGVZFYaKEu0Ad/E6nsmGgg=",
"type": "git",
- "url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
+ "url": "file:///home/exarkun/Work/PrivateStorage/tahoe-great-black-swamp"
},
"original": {
- "ref": "refs/tags/0.1.0.1",
+ "ref": "client-test",
"type": "git",
"url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
}
diff --git a/flake.nix b/flake.nix
index 8c70ef15153e6a444c51dee6bd182192295cb18f..53097888b8cf333b55bc2f31c87fb37b16d8670f 100644
--- a/flake.nix
+++ b/flake.nix
@@ -13,8 +13,9 @@
};
tahoe-great-black-swamp = {
- url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp?ref=refs/tags/0.1.0.1";
+ url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp?ref=client-test";
inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs";
+ inputs.tahoe-chk.follows = "tahoe-chk";
};
};
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 5b126bd93b13b65cec45629a24f471954804dbf2..3bdf332b0ccba6e019c06152265b6292a5e00bb7 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -92,7 +92,7 @@ library
, containers
, exceptions
, http-client
- , modern-uri
+ , network-uri
, servant-client
, servant-client-core
, tahoe-chk
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
index bbc274e0584bda83de06e5256c75878fd0f2df17..a40ae9153db52a58f16d5303f6785bc9f6b169da 100644
--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
@@ -1,32 +1,28 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
{- | A high-level interface to downloading share data as bytes from storage
servers.
-}
-module Tahoe.Download (LookupServer, DownloadError (..), discoverShares, download) where
-k with)
-
module Tahoe.Download (
LookupServer,
DownloadError (..),
- discoverOnce,
+ discoverShares,
download,
gbsURLToStorageServer,
) where
import Control.Exception (throwIO)
-import Control.Monad.Catch (MonadCatch, catch)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Binary (decodeOrFail)
import qualified Data.ByteString.Lazy as LB
import Data.Either (isRight, rights)
import Data.List (foldl')
-import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Network.HTTP.Client (ManagerSettings, defaultManagerSettings, newManager)
+import Network.URI (URI (..), URIAuth (..), parseURI)
import Servant.Client (Scheme (Https), mkClientEnv, runClientM)
import Servant.Client.Core (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
import qualified Tahoe.CHK
@@ -36,11 +32,7 @@ import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), Sto
import Tahoe.CHK.Types (ShareNum, StorageIndex)
import TahoeLAFS.Storage.API (ShareNumber (ShareNumber))
import TahoeLAFS.Storage.Client (readImmutableShares)
-import Text.URI (Authority (Authority, authHost, authPort, authUserInfo), ParseException (ParseException), RText, URI (..), UserInfo (UserInfo, uiPassword, uiUsername), mkURI, unRText)
-
--- | A view pattern for matching on the text of an RTest value.
-restrictedText :: RText l -> String
-restrictedText (T.unpack . unRText -> t) = t
+import Text.Read (readMaybe)
{- | An unrecoverable problem arose while attempting to download and/or read
some application data.
@@ -182,52 +174,41 @@ downloadShare storageIndex shareNum (s : _) = do
shareBytes <- storageServerRead s storageIndex shareNum
pure (shareNum, Right $ LB.fromStrict shareBytes)
-gbsURLToStorageServer :: (MonadIO m, MonadCatch m) => T.Text -> m (Maybe StorageServer)
+gbsURLToStorageServer :: MonadIO m => T.Text -> m (Maybe StorageServer)
gbsURLToStorageServer url =
- catch (mkURI url >>= makeServer) (\ParseException{} -> pure Nothing)
+ case parseURI (T.unpack url) of
+ Nothing -> pure Nothing
+ Just uri -> makeServer uri
makeServer :: MonadIO m => URI -> m (Maybe StorageServer)
makeServer
URI
- { uriScheme = Just (restrictedText -> "pb")
- , uriAuthority =
- Right
- ( Authority
- { authUserInfo =
- Just
- ( UserInfo
- { uiUsername = tubid
- , uiPassword = Nothing
- }
- )
- , authHost = host
- , authPort = Just port
- }
- )
- , uriPath = Just (False, swissnum :| [])
- , uriQuery = []
- , uriFragment = Just (restrictedText -> "v=1")
+ { uriScheme = "pb"
+ , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = port}
+ , uriPath = swissnum
+ , uriFragment = "#v=1"
} =
- do
- manager <- liftIO $ newManager (managerSettingsForService (unRText tubid) (unRText swissnum))
-
- let baseUrl = https (T.unpack $ unRText host) (fromIntegral port)
- env = mkClientEnv manager baseUrl
+ case readMaybe port of
+ Nothing -> pure Nothing
+ Just realPort -> do
+ manager <- liftIO $ newManager (managerSettingsForService (T.pack tubid) (T.pack swissnum))
- storageServerID = undefined
+ let baseUrl = https host realPort
+ env = mkClientEnv manager baseUrl
- storageServerWrite = undefined
+ storageServerID = undefined
- storageServerRead storageIndex shareNum = do
- let clientm = readImmutableShares (T.unpack $ decodeUtf8 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
- res <- runClientM clientm env
- case res of
- Left err -> throwIO err
- Right bs -> pure bs
+ storageServerWrite = undefined
- storageServerGetBuckets = undefined
+ storageServerRead storageIndex shareNum = do
+ let clientm = readImmutableShares (T.unpack $ decodeUtf8 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+ res <- runClientM clientm env
+ case res of
+ Left err -> throwIO err
+ Right bs -> pure bs
- pure $ Just StorageServer{..}
+ storageServerGetBuckets = undefined
+ pure $ Just StorageServer{..}
makeServer _ = pure Nothing
https :: String -> Int -> BaseUrl