Skip to content
Snippets Groups Projects
Commit 1683964c authored by Shae Erisson's avatar Shae Erisson
Browse files

generalize download and decodeShares, begin capability typeclass

parent c6064d90
No related branches found
No related tags found
1 merge request!4Cleanup immutable factoring
...@@ -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 storageIndex) print' ("Going to download: " <> show (getStorageIndex $ 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.
Reader -> 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{..}} shares = decodeShares r shares required = 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.
......
...@@ -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?
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment