diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal index af2f068d8bb5584e08c77673d60a82ea56fa2254..689cd0afb54c7155f167cd137f393f718ec19235 100644 --- a/gbs-downloader.cabal +++ b/gbs-downloader.cabal @@ -81,6 +81,7 @@ library exposed-modules: Tahoe.Announcement Tahoe.Download + Tahoe.Download.Internal.Capability Tahoe.Download.Internal.Client Tahoe.Download.Internal.Immutable diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs index 43706659462c98cf87cba98637912a093b570808..19a7a4644bc3184770c13fdcd7be2a3d37a00bbd 100644 --- a/src/Tahoe/Download.hs +++ b/src/Tahoe/Download.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} {- | A high-level interface to downloading share data as bytes from storage servers. @@ -17,7 +16,7 @@ module Tahoe.Download ( import Control.Exception (Exception (displayException), SomeException, try) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Bifunctor (Bifunctor (bimap, first, second)) +import Data.Bifunctor (Bifunctor (first, second)) import Data.Binary (Word16, decodeOrFail) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -26,21 +25,11 @@ import Data.List (foldl') import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Tahoe.Announcement (StorageServerAnnouncement) -import qualified Tahoe.CHK -import Tahoe.CHK.Capability (Reader (..), Verifier (..)) -import qualified Tahoe.CHK.Capability as CHK -import qualified Tahoe.CHK.Encrypt import Tahoe.CHK.Server (StorageServer (..), StorageServerID) -import qualified Tahoe.CHK.Share import Tahoe.CHK.Types (ShareNum, StorageIndex) +import Tahoe.Download.Internal.Capability import Tahoe.Download.Internal.Client import Tahoe.Download.Internal.Immutable -import qualified Tahoe.SDMF as SDMF -import qualified Tahoe.SDMF.Keys as SDMF.Keys - -print' :: MonadIO m => String -> m () --- print' = liftIO . print -print' = const $ pure () -- | Partially describe one share download. type DownloadTask = (ShareNum, StorageServer) @@ -52,12 +41,12 @@ type Share = (ShareNum, LB.ByteString) given servers, if possible. -} download :: - (MonadIO m, Verifiable v, Readable r v) => + (MonadIO m, Verifiable verifyCap, Readable readCap verifyCap) => -- | Information about the servers from which to consider downloading shares -- representing the application data. Map.Map StorageServerID StorageServerAnnouncement -> -- | The read capability for the application data. - r -> + readCap -> -- | Get functions for interacting with a server given its URL. LookupServer m -> -- | Either a description of how the recovery failed or the recovered @@ -70,10 +59,10 @@ download servers cap lookupServer = do -- TODO: If getRequiredTotal fails on the first storage server, we may -- need to try more. If it fails for all of them, we need to represent -- the failure coherently. - someParam <- firstSuccessful lookupServer (getRequiredTotal verifier) (Map.elems servers) + someParam <- firstRightM lookupServer (getRequiredTotal verifier) (Map.elems servers) case someParam of - Nothing -> pure $ Left NoConfiguredServers -- XXX Maybe not quite the right error - Just (required, _) -> do + Left errs -> pure . Left $ if servers == mempty then NoConfiguredServers else NoReachableServers (StorageServerUnreachable <$> errs) + Right (required, _) -> do locationE <- locateShares servers lookupServer storageIndex (fromIntegral required) print' "Finished locating shares" case locationE of @@ -89,95 +78,24 @@ download servers cap lookupServer = do print' "Decoded them" pure s -firstSuccessful :: MonadIO m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> m (Maybe d) -firstSuccessful _ _ [] = pure Nothing -firstSuccessful f op (x : xs) = do +{- | Apply a monadic operation to each element of a list and another monadic + operation values in the resulting Rights. If all of the results are Lefts or + Nothings, return a list of the values in the Lefts. Otherwise, return the + *first* Right. +-} +firstRightM :: MonadIO m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> m (Either [b] d) +firstRightM _ _ [] = pure $ Left [] +firstRightM f op (x : xs) = do s <- f x case s of - Left _ -> recurse + Left bs -> first (bs :) <$> recurse Right ss -> do r <- op ss case r of Nothing -> recurse - d -> pure d + Just d -> pure $ Right d where - recurse = firstSuccessful f op xs - --- | A capability which confers the ability to locate and verify some stored data. -class Verifiable v where - -- | Ask a storage server which share numbers related to this capability it - -- is holding. This is an unverified result and the storage server could - -- present incorrect information. Even if it correctly reports that it - -- holds a share, it could decline to give it out when asked. - getShareNumbers :: MonadIO m => v -> StorageServer -> m (Set.Set ShareNum) - - -- | Get the encoding parameters used for the shares of this capability. - -- The information is presented as a tuple of (required, total). - getRequiredTotal :: MonadIO m => v -> StorageServer -> m (Maybe (Int, Int)) - - -- | Get the location information for shares of this capability. - getStorageIndex :: v -> StorageIndex - -instance Verifiable CHK.Verifier where - getShareNumbers v s = liftIO $ storageServerGetBuckets s (storageIndex v) - getStorageIndex Verifier{storageIndex} = storageIndex - - -- CHK is pure, we don't have to ask the StorageServer - getRequiredTotal Verifier{required, total} _ = pure $ pure (fromIntegral required, fromIntegral total) - -instance Verifiable SDMF.Verifier where - getShareNumbers v s = liftIO $ storageServerGetBuckets s (SDMF.Keys.unStorageIndex $ SDMF.verifierStorageIndex v) - getStorageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex - getRequiredTotal SDMF.Verifier{..} ss = do - shareBytes <- liftIO $ storageServerRead ss (SDMF.Keys.unStorageIndex verifierStorageIndex) 0 - case decodeOrFail (LB.fromStrict shareBytes) of - Left _ -> pure Nothing - Right (_, _, sh) -> pure $ pure (fromIntegral $ SDMF.shareRequiredShares sh, fromIntegral $ SDMF.shareTotalShares sh) - -{- | A capability which confers the ability to interpret some stored data to - recover the original plaintext. Additionally, it can be attentuated to a - Verifiable. --} -class (Verifiable v) => Readable r v | r -> v where - -- | Attentuate the capability. - getVerifiable :: r -> v - - -- | Interpret the required number of shares to recover the plaintext. - -- - -- Note: might want to split the two functions below out of decodeShare - -- - -- shareToCipherText :: r -> [(Int, WhichShare)] -> LB.ByteString - -- - -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString - decodeShare :: MonadIO m => r -> [(Int, WhichShare)] -> m (Either DownloadError LB.ByteString) - -instance Readable CHK.Reader CHK.Verifier where - getVerifiable = verifier - decodeShare r shareList = do - cipherText <- liftIO $ Tahoe.CHK.decode r (second unWhichCHK <$> shareList) - case cipherText of - Nothing -> pure $ Left ShareDecodingFailed - Just ct -> - pure . Right $ Tahoe.CHK.Encrypt.decrypt (readKey r) ct - -instance Readable SDMF.Reader SDMF.Verifier where - getVerifiable = SDMF.readerVerifier - decodeShare r shareList = do - cipherText <- Right <$> liftIO (SDMF.decode r (bimap fromIntegral unWhichSDMF <$> shareList)) - case cipherText of - Left _ -> pure $ Left ShareDecodingFailed - Right ct -> - pure . Right $ SDMF.decrypt dataKey ct - where - Just dataKey = SDMF.Keys.deriveDataKey iv readKey - iv = SDMF.shareIV (unWhichSDMF . snd . head $ shareList) - readKey = SDMF.readerReadKey r - -{- | Represent the kind of share to operate on. This forms a closed world of - share types. It might eventually be interesting to make an open world - variation instead. --} -data WhichShare = CHK {unWhichCHK :: Tahoe.CHK.Share.Share} | SDMF {unWhichSDMF :: SDMF.Share} + recurse = firstRightM f op xs {- | Deserialize some bytes representing some kind of share to that kind of share, if possible. @@ -243,9 +161,9 @@ locateShares servers lookupServer storageIndex required = decode them and decrypt the contents of possible. -} decodeShares :: - (MonadIO m, Readable r v) => + (MonadIO m, Readable readCap verifyCap) => -- | The read capability which allows the contents to be decrypted. - r -> + readCap -> -- | The results of downloading the shares. [Share] -> Int -> diff --git a/src/Tahoe/Download/Internal/Capability.hs b/src/Tahoe/Download/Internal/Capability.hs new file mode 100644 index 0000000000000000000000000000000000000000..435138756447097e5e0cf29f246f42618981b0ae --- /dev/null +++ b/src/Tahoe/Download/Internal/Capability.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Tahoe.Download.Internal.Capability where + +import Control.Monad.IO.Class +import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (decodeOrFail) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Set as Set +import qualified Tahoe.CHK +import qualified Tahoe.CHK.Capability as CHK +import qualified Tahoe.CHK.Encrypt +import Tahoe.CHK.Server +import qualified Tahoe.CHK.Share +import Tahoe.CHK.Types +import Tahoe.Download.Internal.Client +import qualified Tahoe.SDMF as SDMF +import qualified Tahoe.SDMF.Internal.Keys as SDMF.Keys + +{- | Represent the kind of share to operate on. This forms a closed world of + share types. It might eventually be interesting to make an open world + variation instead. +-} +data WhichShare + = CHK {unWhichCHK :: Tahoe.CHK.Share.Share} + | SDMF {unWhichSDMF :: SDMF.Share} + +-- | A capability which confers the ability to locate and verify some stored data. +class Verifiable v where + -- | Ask a storage server which share numbers related to this capability it + -- is holding. This is an unverified result and the storage server could + -- present incorrect information. Even if it correctly reports that it + -- holds a share, it could decline to give it out when asked. + getShareNumbers :: MonadIO m => v -> StorageServer -> m (Set.Set ShareNum) + + -- | Get the encoding parameters used for the shares of this capability. + -- The information is presented as a tuple of (required, total). + getRequiredTotal :: MonadIO m => v -> StorageServer -> m (Maybe (Int, Int)) + + -- | Get the location information for shares of this capability. + getStorageIndex :: v -> StorageIndex + +class (Verifiable v) => Readable r v | r -> v where + -- | Attentuate the capability. + getVerifiable :: r -> v + + -- | Interpret the required number of shares to recover the plaintext. + -- + -- Note: might want to split the two functions below out of decodeShare + -- + -- shareToCipherText :: r -> [(Int, WhichShare)] -> LB.ByteString + -- + -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString + decodeShare :: MonadIO m => r -> [(Int, WhichShare)] -> m (Either DownloadError LB.ByteString) + +instance Verifiable CHK.Verifier where + getShareNumbers v s = liftIO $ storageServerGetBuckets s (CHK.storageIndex v) + getStorageIndex CHK.Verifier{storageIndex} = storageIndex + + -- CHK is pure, we don't have to ask the StorageServer + getRequiredTotal CHK.Verifier{required, total} _ = pure $ pure (fromIntegral required, fromIntegral total) + +{- | A capability which confers the ability to interpret some stored data to + recover the original plaintext. Additionally, it can be attentuated to a + Verifiable. +-} +instance Readable CHK.Reader CHK.Verifier where + getVerifiable = CHK.verifier + decodeShare r shareList = do + cipherText <- liftIO $ Tahoe.CHK.decode r (second unWhichCHK <$> shareList) + case cipherText of + Nothing -> pure $ Left ShareDecodingFailed + Just ct -> + pure . Right $ Tahoe.CHK.Encrypt.decrypt (CHK.readKey r) ct + +instance Verifiable SDMF.Verifier where + getShareNumbers v s = liftIO $ storageServerGetBuckets s (SDMF.Keys.unStorageIndex $ SDMF.verifierStorageIndex v) + getStorageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex + getRequiredTotal SDMF.Verifier{..} ss = do + shareBytes <- liftIO $ storageServerRead ss (SDMF.Keys.unStorageIndex verifierStorageIndex) 0 + case decodeOrFail (LB.fromStrict shareBytes) of + Left _ -> pure Nothing + Right (_, _, sh) -> pure $ pure (fromIntegral $ SDMF.shareRequiredShares sh, fromIntegral $ SDMF.shareTotalShares sh) + +instance Readable SDMF.Reader SDMF.Verifier where + getVerifiable = SDMF.readerVerifier + decodeShare r shareList = do + cipherText <- Right <$> liftIO (SDMF.decode r (bimap fromIntegral unWhichSDMF <$> shareList)) + case cipherText of + Left _ -> pure $ Left ShareDecodingFailed + Right ct -> do + print' ("Got some ciphertext: " <> show ct) + print' ("Decrypting with iv: " <> show iv) + pure . Right $ SDMF.decrypt readKey iv ct + where + readKey = SDMF.readerReadKey r + iv = SDMF.shareIV (unWhichSDMF . snd . head $ shareList) + +print' :: MonadIO m => String -> m () +-- print' = liftIO . putStrLn +print' = const $ pure () diff --git a/test/Spec.hs b/test/Spec.hs index 6104525c8d35f4d334f2e290d3d54d8f53a0e91c..f9111f66f629bfb092760f0eccc88869082f071a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,7 +17,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Word (Word16) import qualified Data.Yaml as Yaml import Generators (genAnnouncements, genParameters, genRSAKeys) -import Hedgehog (MonadGen, diff, forAll, property, tripping) +import Hedgehog (MonadGen, annotateShow, diff, forAll, property, tripping) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import System.IO (hSetEncoding, stderr, stdout, utf8) @@ -322,15 +322,14 @@ tests = -- this test where confidentiality and key secrecy is not -- particularly a concern. iv = SDMF.Keys.SDMF_IV nullIV - signatureKey = SDMF.Keys.toSignatureKey keypair - (Just writeKey) = SDMF.Keys.deriveWriteKey signatureKey - (Just readKey) = SDMF.Keys.deriveReadKey writeKey - (Just dataKey) = SDMF.Keys.deriveDataKey iv readKey - ciphertext = SDMF.encrypt dataKey plaintext - (shares, writeCap) <- liftIO $ SDMF.encode keypair sequenceNumber required total ciphertext - let readCap = SDMF.writerReader writeCap + ciphertext = SDMF.encrypt keypair iv plaintext + annotateShow ciphertext + annotateShow iv + (shares, writeCap) <- liftIO $ SDMF.encode keypair iv sequenceNumber required total ciphertext + let storageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex . SDMF.readerVerifier . SDMF.writerReader $ writeCap + readCap = SDMF.writerReader writeCap -- Distribute the shares. - liftIO $ placeShares (SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex . SDMF.readerVerifier . SDMF.writerReader $ writeCap) (Binary.encode <$> shares) perServerShareCount servers 0 + liftIO $ placeShares storageIndex (Binary.encode <$> shares) perServerShareCount servers 0 let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers lookupServer = someServers serverMap