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

stop using modern-uri 

we need to use an _even older_ version of ghc than we're using now and
modern-uri doesn't seem particularly amenable to that.

network-uri is perfectly fine, anyway.
parent fb1c1685
Branches
Tags
1 merge request!2Incorporate tahoe-great-black-swamp to do share downloads using GBS
Hide whitespace changes
Inline Side-by-side
flake.lock
+ 11
− 11
View file @ f654fcea
......@@ -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"
}
......
flake.nix
+ 2
− 1
View file @ f654fcea
......@@ -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";
};
};
......
gbs-downloader.cabal
+ 1
− 1
View file @ f654fcea
......@@ -92,7 +92,7 @@ library
, containers
, exceptions
, http-client
, modern-uri
, network-uri
, servant-client
, servant-client-core
, tahoe-chk
......
src/Tahoe/Download.hs
+ 28
− 47
View file @ f654fcea
{-# 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
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment