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
1683964c
Commit
1683964c
authored
2 years ago
by
Shae Erisson
Browse files
Options
Downloads
Patches
Plain Diff
generalize download and decodeShares, begin capability typeclass
parent
c6064d90
No related branches found
No related tags found
1 merge request
!4
Cleanup immutable factoring
Changes
2
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
src/Tahoe/Download.hs
+42
-28
42 additions, 28 deletions
src/Tahoe/Download.hs
src/Tahoe/Download/Internal/Client.hs
+2
-0
2 additions, 0 deletions
src/Tahoe/Download/Internal/Client.hs
with
44 additions
and
28 deletions
src/Tahoe/Download.hs
+
42
−
28
View file @
1683964c
...
@@ -12,6 +12,7 @@ module Tahoe.Download (
...
@@ -12,6 +12,7 @@ module Tahoe.Download (
discoverShares
,
discoverShares
,
download
,
download
,
announcementToImmutableStorageServer
,
announcementToImmutableStorageServer
,
getShareNumbers
,
)
where
)
where
import
Control.Exception
(
Exception
(
displayException
),
SomeException
,
try
)
import
Control.Exception
(
Exception
(
displayException
),
SomeException
,
try
)
...
@@ -30,6 +31,7 @@ import Tahoe.CHK.Capability (Reader (..), Verifier (..))
...
@@ -30,6 +31,7 @@ import Tahoe.CHK.Capability (Reader (..), Verifier (..))
import
qualified
Tahoe.CHK.Capability
as
CHK
import
qualified
Tahoe.CHK.Capability
as
CHK
import
qualified
Tahoe.CHK.Encrypt
import
qualified
Tahoe.CHK.Encrypt
import
Tahoe.CHK.Server
(
StorageServer
(
..
),
StorageServerID
)
import
Tahoe.CHK.Server
(
StorageServer
(
..
),
StorageServerID
)
import
qualified
Tahoe.CHK.Share
import
Tahoe.CHK.Types
(
ShareNum
,
StorageIndex
)
import
Tahoe.CHK.Types
(
ShareNum
,
StorageIndex
)
import
Tahoe.Download.Internal.Client
import
Tahoe.Download.Internal.Client
import
Tahoe.Download.Internal.Immutable
import
Tahoe.Download.Internal.Immutable
...
@@ -60,10 +62,11 @@ download ::
...
@@ -60,10 +62,11 @@ download ::
-- application data.
-- application data.
m
(
Either
DownloadError
LB
.
ByteString
)
m
(
Either
DownloadError
LB
.
ByteString
)
download
servers
cap
lookupServer
=
do
download
servers
cap
lookupServer
=
do
print'
(
"Going to download: "
<>
show
s
torageIndex
)
print'
(
"Going to download: "
<>
show
(
getS
torageIndex
$
getVerifiable
cap
)
)
let
verifier
=
getVerifiable
cap
let
verifier
=
getVerifiable
cap
let
storageIndex
=
getStorageIndex
verifier
let
storageIndex
=
getStorageIndex
verifier
(
required
,
_
)
<-
getRequiredTotal
ss
verifier
ss
<-
firstStorageServer
(
Map
.
elems
servers
)
lookupServer
(
required
,
_
)
<-
getRequiredTotal
verifier
ss
locationE
<-
locateShares
servers
lookupServer
storageIndex
(
fromIntegral
required
)
locationE
<-
locateShares
servers
lookupServer
storageIndex
(
fromIntegral
required
)
print'
"Finished locating shares"
print'
"Finished locating shares"
case
locationE
of
case
locationE
of
...
@@ -75,43 +78,59 @@ download servers cap lookupServer = do
...
@@ -75,43 +78,59 @@ download servers cap lookupServer = do
-- XXX note shares can contain failures
-- XXX note shares can contain failures
shares
<-
executeDownloadTasks
storageIndex
(
makeDownloadTasks
=<<
discovered
)
shares
<-
executeDownloadTasks
storageIndex
(
makeDownloadTasks
=<<
discovered
)
print'
"Fetched the shares, decoding them"
print'
"Fetched the shares, decoding them"
s
<-
decodeShares
cap
shares
s
<-
decodeShares
cap
shares
required
print'
"Decoded them"
print'
"Decoded them"
pure
s
pure
s
-- fetchRequiredTotal :: [StorageServerAnnouncement] -> (StorageServerAnnouncement -> IO (Either LookupError StorageServer) -> (StorageServer -> IO (Int, Int)) -> IO (Int, Int)
-- We also need "first successful share"!
-- fetchRequiredTotal locations f = _
firstStorageServer
::
Monad
m
=>
[
StorageServerAnnouncement
]
->
LookupServer
m
->
m
StorageServer
firstStorageServer
::
[
StorageServerAnnouncement
]
->
(
StorageServerAnnouncement
->
IO
(
Either
LookupError
StorageServer
))
->
IO
[
StorageServer
]
firstStorageServer
servers
finder
=
do
firstStorageServer
servers
finder
=
do
responses
<-
mapM
finder
servers
responses
<-
mapM
finder
servers
pure
$
take
1
$
rights
responses
pure
$
head
$
take
1
$
rights
responses
-- XXX don't do this at home kids, head isn't safe
{-
{-
getShareNumbers :: server -> storageIndex -> IO [ShareNumber]
getShareNumbers :: server -> storageIndex -> IO [ShareNumber]
for mutables,
that's
getMutableShareNumbers
for mutables, getMutableShareNumbers
getEncodingParameters :: Capability -> StorageServer -> IO (n,k)
getEncodingParameters :: Capability -> StorageServer -> IO (n,k)
it's pure for CHK (immutables), but must be requested from the server for mutables
it's pure for CHK (immutables), but must be requested from the server for mutables
this returns the FEC encoding values so you know when to stop fetching shares
this returns the FEC encoding values so you know when to stop fetching shares
getStorageIndex :: Capability -> StorageIndex
getStorageIndex :: Capability -> StorageIndex
-}
-}
class
Verifiable
v
where
class
Verifiable
v
where
getShareNumbers
::
v
->
StorageServer
->
IO
(
Set
.
Set
ShareNum
)
getShareNumbers
::
MonadIO
m
=>
v
->
StorageServer
->
m
(
Set
.
Set
ShareNum
)
getRequiredTotal
::
v
->
StorageServer
->
IO
(
Int
,
Int
)
getRequiredTotal
::
MonadIO
m
=>
v
->
StorageServer
->
m
(
Int
,
Int
)
getStorageIndex
::
v
->
StorageIndex
getStorageIndex
::
v
->
StorageIndex
instance
Verifiable
CHK
.
Verifier
where
instance
Verifiable
CHK
.
Verifier
where
getShareNumbers
v
s
=
storageServerGetBuckets
s
(
storageIndex
v
)
getShareNumbers
v
s
=
liftIO
$
storageServerGetBuckets
s
(
storageIndex
v
)
getStorageIndex
Verifier
{
storageIndex
}
=
storageIndex
getStorageIndex
Verifier
{
storageIndex
}
=
storageIndex
-- CHK is pure, we don't have to ask the StorageServer
-- CHK is pure, we don't have to ask the StorageServer
getRequiredTotal
Verifier
{
required
,
total
}
_
=
pure
(
fromIntegral
required
,
fromIntegral
total
)
getRequiredTotal
Verifier
{
required
,
total
}
_
=
pure
(
fromIntegral
required
,
fromIntegral
total
)
class
Verifiable
v
=>
Readable
r
v
|
r
->
v
where
class
(
Verifiable
v
)
=>
Readable
r
v
|
r
->
v
where
getVerifiable
::
r
->
v
getVerifiable
::
r
->
v
decodeShare
::
MonadIO
m
=>
r
->
[(
Int
,
WhichShare
)]
->
m
(
Either
DownloadError
LB
.
ByteString
)
-- Might want to split the two functions below out of decodeShare
-- shareToCipherText :: Share ->
-- cipherTextToPlainText
instance
Readable
CHK
.
Reader
CHK
.
Verifier
where
instance
Readable
CHK
.
Reader
CHK
.
Verifier
where
getVerifiable
=
verifier
getVerifiable
=
verifier
decodeShare
r
shareList
=
do
cipherText
<-
liftIO
$
Tahoe
.
CHK
.
decode
r
(
second
unWhich
<$>
shareList
)
case
cipherText
of
Nothing
->
pure
$
Left
ShareDecodingFailed
Just
ct
->
pure
.
Right
$
Tahoe
.
CHK
.
Encrypt
.
decrypt
(
readKey
r
)
ct
data
WhichShare
=
CHK
{
unWhich
::
Tahoe
.
CHK
.
Share
.
Share
}
-- \| SDMF SDMF.Share
bytesToShare
::
LB
.
ByteString
->
Either
DeserializeError
WhichShare
bytesToShare
bytes
=
do
case
decodeOrFail
bytes
of
Left
_
->
Left
UnknownDeserializeError
Right
(
_
,
_
,
r
)
->
Right
$
CHK
r
{- | Execute each download task sequentially and return only the successful
{- | Execute each download task sequentially and return only the successful
results.
results.
...
@@ -166,26 +185,21 @@ locateShares servers lookupServer storageIndex required =
...
@@ -166,26 +185,21 @@ locateShares servers lookupServer storageIndex required =
decode them and decrypt the contents of possible.
decode them and decrypt the contents of possible.
-}
-}
decodeShares
::
decodeShares
::
MonadIO
m
=>
(
MonadIO
m
,
Readable
r
v
)
=>
-- | The read capability which allows the contents to be decrypted.
-- | The read capability which allows the contents to be decrypted.
Reade
r
->
r
->
-- | The results of downloading the shares.
-- | The results of downloading the shares.
[
Share
]
->
[
Share
]
->
Int
->
m
(
Either
DownloadError
LB
.
ByteString
)
m
(
Either
DownloadError
LB
.
ByteString
)
decodeShares
cap
@
Reader
{
readKey
,
verifier
=
Verifier
{
..
}}
sha
re
s
=
decodeShares
r
shares
requi
re
d
=
do
-- Filter down to shares we actually got.
-- Filter down to shares we actually got.
let
fewerShares
=
second
decodeOrFail
<$>
shares
let
fewerShares
::
[(
ShareNum
,
Either
DeserializeError
WhichShare
)]
=
second
bytesToShare
<$>
shares
onlyDecoded
=
(
\
(
sharenum
,
Right
(
_
,
_
,
share
)
)
->
(
fromIntegral
sharenum
,
share
)
)
<$>
fewerShares
onlyDecoded
=
rights
$
(
\
(
a
,
b
)
->
(
fromIntegral
a
,)
<$>
b
)
<$>
fewerShares
in
if
length
onlyDecoded
<
fromIntegral
required
if
length
onlyDecoded
<
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
print'
"Interpreted shares, decoding them"
decodeShare
r
onlyDecoded
ciphertext
<-
liftIO
$
Tahoe
.
CHK
.
decode
cap
onlyDecoded
print'
"Decoded them, might decrypt them"
case
ciphertext
of
Nothing
->
pure
$
Left
ShareDecodingFailed
Just
ct
->
pure
.
Right
$
Tahoe
.
CHK
.
Encrypt
.
decrypt
readKey
ct
{- | Figure the total number of distinct shares reported by all of the servers
{- | Figure the total number of distinct shares reported by all of the servers
we asked.
we asked.
...
...
This diff is collapsed.
Click to expand it.
src/Tahoe/Download/Internal/Client.hs
+
2
−
0
View file @
1683964c
...
@@ -117,3 +117,5 @@ data LookupError
...
@@ -117,3 +117,5 @@ data LookupError
|
-- | The structure of the server's URI was unparseable.
|
-- | The structure of the server's URI was unparseable.
AnnouncementStructureUnmatched
AnnouncementStructureUnmatched
deriving
(
Eq
,
Ord
,
Show
)
deriving
(
Eq
,
Ord
,
Show
)
data
DeserializeError
=
UnknownDeserializeError
-- add more later?
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