Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
G
gbs-downloader
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Keyboard shortcuts
?
Snippets
Groups
Projects
This is an archived project. Repository and other project resources are read-only.
Show more breadcrumbs
PrivateStorage
gbs-downloader
Commits
594cc057
Commit
594cc057
authored
May 2, 2023
by
Jean-Paul Calderone
Browse files
Options
Downloads
Patches
Plain Diff
Get some more of the pieces working well together
Also sketch out a demo program
parent
f654fcea
No related branches found
No related tags found
1 merge request
!2
Incorporate tahoe-great-black-swamp to do share downloads using GBS
Changes
4
Show whitespace changes
Inline
Side-by-side
Showing
4 changed files
app/Main.hs
+29
-1
29 additions, 1 deletion
app/Main.hs
gbs-downloader.cabal
+6
-0
6 additions, 0 deletions
gbs-downloader.cabal
src/Tahoe/Download.hs
+18
-10
18 additions, 10 deletions
src/Tahoe/Download.hs
test/Spec.hs
+8
-8
8 additions, 8 deletions
test/Spec.hs
with
61 additions
and
19 deletions
app/Main.hs
+
29
−
1
View file @
594cc057
module
Main
where
module
Main
where
-- import Data.Aeson
import
qualified
Data.ByteString
as
B
import
Data.Text
import
Data.Yaml
(
decodeEither'
)
import
System.Environment
(
getArgs
)
import
Tahoe.CHK.Capability
import
Tahoe.Download
(
download
,
gbsURLToStorageServer
)
import
Text.Megaparsec
(
parse
)
main
::
IO
()
main
::
IO
()
main
=
do
main
=
do
putStrLn
"Hello, Haskell!"
[
announcementPath
,
readCap
]
<-
getArgs
-- Load server announcements
announcementsBytes
<-
B
.
readFile
announcementPath
-- XXX announcementsBytes is not quite the right shape for `Map
-- StorageServerID StorageServerAnnouncement` - need to massage it a
-- little bit somehow?
-- let Just yaml = decodeEither' announcementBytes :: Either ParseException (Maybe Value)
let
Right
announcements
=
decodeEither'
announcementsBytes
-- Accept & parse read capability
let
Right
(
CHKReader
cap
)
=
parse
pCapability
"<argv>"
(
Data
.
Text
.
pack
readCap
)
-- Download the shares
-- Decode them
Right
plaintext
<-
download
announcements
cap
gbsURLToStorageServer
-- Show the result
print
(
"Your plaintext:"
::
Data
.
Text
.
Text
)
print
plaintext
This diff is collapsed.
Click to expand it.
gbs-downloader.cabal
+
6
−
0
View file @
594cc057
...
@@ -122,8 +122,14 @@ executable gbs-download
...
@@ -122,8 +122,14 @@ executable gbs-download
-- Other library packages from which modules are imported.
-- Other library packages from which modules are imported.
build-depends:
build-depends:
, aeson
, base ^>=4.14.3.0
, base ^>=4.14.3.0
, bytestring
, gbs-downloader
, gbs-downloader
, megaparsec
, tahoe-chk
, text
, yaml
-- Directories containing source files.
-- Directories containing source files.
hs-source-dirs: app
hs-source-dirs: app
...
...
This diff is collapsed.
Click to expand it.
src/Tahoe/Download.hs
+
18
−
10
View file @
594cc057
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- | A high-level interface to downloading share data as bytes from storage
{- | A high-level interface to downloading share data as bytes from storage
servers.
servers.
...
@@ -79,28 +80,29 @@ data DiscoverError
...
@@ -79,28 +80,29 @@ data DiscoverError
-- Tor-based route to the server. In this case we might need to launch a Tor
-- Tor-based route to the server. In this case we might need to launch a Tor
-- daemon or connect to a running Tor daemon or at least set up a new Tor
-- daemon or connect to a running Tor daemon or at least set up a new Tor
-- circuit. All of which require I/O. But we can always refactor later!
-- circuit. All of which require I/O. But we can always refactor later!
type
LookupServer
=
URL
->
Maybe
StorageServer
type
LookupServer
m
=
URL
->
m
(
Maybe
StorageServer
)
{- | Recover the application data associated with a given capability from the
{- | Recover the application data associated with a given capability from the
given servers, if possible.
given servers, if possible.
-}
-}
download
::
download
::
MonadIO
m
=>
-- | Information about the servers from which to consider downloading shares
-- | Information about the servers from which to consider downloading shares
-- representing the application data.
-- representing the application data.
Map
.
Map
StorageServerID
StorageServerAnnouncement
->
Map
.
Map
StorageServerID
StorageServerAnnouncement
->
-- | The read capability for the application data.
-- | The read capability for the application data.
Reader
->
Reader
->
-- | Get functions for interacting with a server given its URL.
-- | Get functions for interacting with a server given its URL.
LookupServer
->
LookupServer
m
->
-- | Either a description of how the recovery failed or the recovered
-- | Either a description of how the recovery failed or the recovered
-- application data.
-- application data.
IO
(
Either
DownloadError
LB
.
ByteString
)
m
(
Either
DownloadError
LB
.
ByteString
)
download
servers
cap
@
Reader
{
readKey
,
verifier
=
Verifier
{
..
}}
lookupServer
=
download
servers
cap
@
Reader
{
readKey
,
verifier
=
Verifier
{
..
}}
lookupServer
=
case
Map
.
toList
servers
of
case
Map
.
toList
servers
of
[]
->
pure
.
Left
$
NoConfiguredServers
[]
->
pure
.
Left
$
NoConfiguredServers
serverList
->
do
serverList
->
do
-- Ask each server for all shares it has.
-- Ask each server for all shares it has.
discovered
<-
rights
<$>
mapM
(
discoverShares
lookupServer
storageIndex
)
serverList
::
IO
[(
StorageServer
,
Set
.
Set
ShareNum
)]
(
discovered
::
[(
StorageServer
,
Set
.
Set
ShareNum
)])
<-
rights
<$>
mapM
(
discoverShares
lookupServer
storageIndex
)
serverList
if
null
discovered
if
null
discovered
then
pure
$
Left
NoReachableServers
then
pure
$
Left
NoReachableServers
else
else
...
@@ -119,7 +121,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
...
@@ -119,7 +121,7 @@ download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
if
length
onlyDecoded
<
fromIntegral
required
if
length
onlyDecoded
<
fromIntegral
required
then
pure
$
Left
NotEnoughDecodedShares
{
notEnoughDecodedSharesNeeded
=
fromIntegral
required
,
notEnoughDecodedSharesFound
=
length
onlyDecoded
}
then
pure
$
Left
NotEnoughDecodedShares
{
notEnoughDecodedSharesNeeded
=
fromIntegral
required
,
notEnoughDecodedSharesFound
=
length
onlyDecoded
}
else
do
else
do
ciphertext
<-
Tahoe
.
CHK
.
decode
cap
onlyDecoded
ciphertext
<-
liftIO
$
Tahoe
.
CHK
.
decode
cap
onlyDecoded
case
ciphertext
of
case
ciphertext
of
Nothing
->
pure
$
Left
ShareDecodingFailed
Nothing
->
pure
$
Left
ShareDecodingFailed
Just
ct
->
Just
ct
->
...
@@ -134,16 +136,21 @@ countDistinctShares = Set.size . foldl' Set.union mempty . map snd
...
@@ -134,16 +136,21 @@ countDistinctShares = Set.size . foldl' Set.union mempty . map snd
{- | Ask one server which shares it has related to the storage index in
{- | Ask one server which shares it has related to the storage index in
question.
question.
-}
-}
discoverShares
::
LookupServer
->
StorageIndex
->
(
StorageServerID
,
StorageServerAnnouncement
)
->
IO
(
Either
DiscoverError
(
StorageServer
,
Set
.
Set
ShareNum
))
discoverShares
::
MonadIO
m
=>
LookupServer
m
->
StorageIndex
->
(
StorageServerID
,
StorageServerAnnouncement
)
->
m
(
Either
DiscoverError
(
StorageServer
,
Set
.
Set
ShareNum
))
discoverShares
lookupServer
storageIndex
(
_sid
,
sann
)
=
do
discoverShares
lookupServer
storageIndex
(
_sid
,
sann
)
=
do
case
storageServerAnnouncementFURL
sann
of
case
storageServerAnnouncementFURL
sann
of
Nothing
->
pure
$
Left
StorageServerLocationUnknown
Nothing
->
pure
$
Left
StorageServerLocationUnknown
Just
url
->
do
Just
url
->
do
let
server
=
lookupServer
url
server
<-
lookupServer
url
case
server
of
case
server
of
Nothing
->
pure
$
Left
StorageServerUnreachable
Nothing
->
pure
$
Left
StorageServerUnreachable
Just
ss
@
StorageServer
{
storageServerGetBuckets
}
->
Just
ss
@
StorageServer
{
storageServerGetBuckets
}
->
Right
.
(
ss
,)
<$>
storageServerGetBuckets
storageIndex
liftIO
$
Right
.
(
ss
,)
<$>
storageServerGetBuckets
storageIndex
{- | Invert the mapping implied by the list of two tuples so that the servers
{- | Invert the mapping implied by the list of two tuples so that the servers
that claim to have a certain share can easily be retrieved.
that claim to have a certain share can easily be retrieved.
...
@@ -154,6 +161,7 @@ makeShareMap locations =
...
@@ -154,6 +161,7 @@ makeShareMap locations =
-- | Download the bytes of a share from one (or more!) of the given servers.
-- | Download the bytes of a share from one (or more!) of the given servers.
downloadShare
::
downloadShare
::
MonadIO
m
=>
-- | The storage index of the share to download.
-- | The storage index of the share to download.
StorageIndex
->
StorageIndex
->
-- | The number of the share to download.
-- | The number of the share to download.
...
@@ -165,13 +173,13 @@ downloadShare ::
...
@@ -165,13 +173,13 @@ downloadShare ::
[
StorageServer
]
->
[
StorageServer
]
->
-- | The bytes of the share or some error that was encountered during
-- | The bytes of the share or some error that was encountered during
-- download.
-- download.
IO
(
ShareNum
,
Either
DownloadError
LB
.
ByteString
)
m
(
ShareNum
,
Either
DownloadError
LB
.
ByteString
)
downloadShare
_
shareNum
[]
=
pure
(
shareNum
,
Left
NoServers
)
downloadShare
_
shareNum
[]
=
pure
(
shareNum
,
Left
NoServers
)
downloadShare
storageIndex
shareNum
(
s
:
_
)
=
do
downloadShare
storageIndex
shareNum
(
s
:
_
)
=
do
-- TODO: There might be more servers. We could try them if this fails.
-- TODO: There might be more servers. We could try them if this fails.
-- On the other hand, we might get bytes but we don't verify them here so
-- On the other hand, we might get bytes but we don't verify them here so
-- we might also need retry logic up a level or two from here.
-- we might also need retry logic up a level or two from here.
shareBytes
<-
storageServerRead
s
storageIndex
shareNum
shareBytes
<-
liftIO
$
storageServerRead
s
storageIndex
shareNum
pure
(
shareNum
,
Right
$
LB
.
fromStrict
shareBytes
)
pure
(
shareNum
,
Right
$
LB
.
fromStrict
shareBytes
)
gbsURLToStorageServer
::
MonadIO
m
=>
T
.
Text
->
m
(
Maybe
StorageServer
)
gbsURLToStorageServer
::
MonadIO
m
=>
T
.
Text
->
m
(
Maybe
StorageServer
)
...
...
This diff is collapsed.
Click to expand it.
test/Spec.hs
+
8
−
8
View file @
594cc057
...
@@ -90,8 +90,8 @@ tests =
...
@@ -90,8 +90,8 @@ tests =
-- Make the server reachable.
-- Make the server reachable.
let
openServer
furl
=
let
openServer
furl
=
if
furl
==
"somewhere"
if
furl
==
"somewhere"
then
pure
server
then
pure
.
pure
$
server
else
Nothing
else
pure
Nothing
-- Try to download the cap which requires three shares to reconstruct.
-- Try to download the cap which requires three shares to reconstruct.
result
<-
liftIO
$
download
anns
cap
openServer
result
<-
liftIO
$
download
anns
cap
openServer
...
@@ -138,9 +138,9 @@ tests =
...
@@ -138,9 +138,9 @@ tests =
-- Make the server reachable.
-- Make the server reachable.
let
openServer
furl
=
let
openServer
furl
=
case
furl
of
case
furl
of
"somewhere"
->
pure
somewhere
"somewhere"
->
pure
.
pure
$
somewhere
"elsewhere"
->
pure
elsewhere
"elsewhere"
->
pure
.
pure
$
elsewhere
_
->
Nothing
_
->
pure
Nothing
-- Try to download the cap which requires three shares to reconstruct.
-- Try to download the cap which requires three shares to reconstruct.
result
<-
liftIO
$
download
anns
cap
openServer
result
<-
liftIO
$
download
anns
cap
openServer
...
@@ -221,11 +221,11 @@ tests =
...
@@ -221,11 +221,11 @@ tests =
]
]
where
where
-- A server lookup function that always fails.
-- A server lookup function that always fails.
noServers
_
=
Nothing
noServers
_
=
pure
Nothing
-- A server lookup function that finds servers already present in a Map.
-- A server lookup function that finds servers already present in a Map.
someServers
::
Map
.
Map
StorageServerID
StorageServer
->
LookupServer
someServers
::
Applicative
m
=>
Map
.
Map
StorageServerID
StorageServer
->
LookupServer
m
someServers
servers
=
flip
Map
.
lookup
servers
.
parseURL
someServers
servers
=
pure
.
flip
Map
.
lookup
servers
.
parseURL
where
where
-- Exactly match the nonsense makeAnn spits out
-- Exactly match the nonsense makeAnn spits out
parseURL
=
T
.
take
2
.
T
.
drop
5
parseURL
=
T
.
take
2
.
T
.
drop
5
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment