diff --git a/cabal.project b/cabal.project
index 55be17a13a683db9dd1f7743b243c5f56a0f587a..80fc512d3f3319213956e32b7fef370e50b09ec5 100644
--- a/cabal.project
+++ b/cabal.project
@@ -2,6 +2,7 @@ packages: .
-- These aren't released on hackage yet so we have to grab them
-- straight from the vcs host. Probably should do some releases
-- soon.
+ ../tahoe-ssk
https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.1/tahoe-chk-0.1.0.1.tar.gz
https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/archive/0.2.0.2/tahoe-great-black-swamp-0.2.0.2.tar.gz
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index ba2597aa1d6bdb02aadeb79eb14fd2a3f267a66b..af2f068d8bb5584e08c77673d60a82ea56fa2254 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -109,6 +109,7 @@ library
, servant-client-core
, tahoe-chk
, tahoe-great-black-swamp >=0.2 && <0.3
+ , tahoe-ssk
, text
, yaml
@@ -174,18 +175,23 @@ test-suite gbs-downloader-test
-- Test dependencies.
build-depends:
+ , asn1-encoding
+ , asn1-types
, base
, base32
, binary
, bytestring
, containers
, crypto-api
+ , cryptonite
, data-default-class
, gbs-downloader
, hedgehog
, tahoe-chk
+ , tahoe-ssk
, tasty
, tasty-hedgehog
, tasty-hunit
, text
+ , x509
, yaml
diff --git a/test/Generators.hs b/test/Generators.hs
index 3adc7c662bbccce84fecc99c0cb6251bac5eb1fa..7827221f4e4200997a4ff55165e44577bdcb0af1 100644
--- a/test/Generators.hs
+++ b/test/Generators.hs
@@ -1,11 +1,19 @@
module Generators where
+import qualified Crypto.PubKey.RSA as RSA
+import Data.ASN1.BinaryEncoding (DER (DER))
+import Data.ASN1.Encoding (ASN1Decoding (decodeASN1))
+import Data.ASN1.Types (ASN1Object (fromASN1))
+import Data.Bifunctor (Bifunctor (first))
import Data.ByteString.Base32 (encodeBase32Unpadded)
+import qualified Data.ByteString.Lazy as LB
import Data.Int (Int64)
import qualified Data.Text as T
+import Data.X509 (PrivKey (PrivKeyRSA))
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
+import System.IO.Unsafe (unsafePerformIO)
import Tahoe.Announcement (Announcements (..), StorageServerAnnouncement (..))
import Tahoe.CHK.Types (Parameters (..))
@@ -37,3 +45,30 @@ genStorageServerAnnouncements =
<$> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)
<*> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii)
<*> Gen.maybe (Gen.bytes $ Range.singleton 32)
+
+{- | Build RSA key pairs.
+
+ Because the specific bits of the key pair shouldn't make any difference to
+ any application logic, generating new RSA key pairs is expensive, and
+ generating new RSA key pairs in a way that makes sense in Hedgehog is
+ challenging, this implementation just knows a few RSA key pairs already and
+ will give back one of them.
+-}
+genRSAKeys :: MonadGen m => m RSA.PrivateKey
+genRSAKeys = Gen.element (map rsaKeyPair rsaKeyPairBytes)
+
+-- I'm not sure how to do IO in MonadGen so do the IO up front unsafely (but
+-- hopefully not really unsafely).
+rsaKeyPairBytes :: [LB.ByteString]
+{-# NOINLINE rsaKeyPairBytes #-}
+rsaKeyPairBytes = unsafePerformIO $ mapM (\n -> LB.readFile ("test/data/rsa-privkey-" <> show n <> ".der")) [0 .. 4 :: Int]
+
+rsaKeyPair :: LB.ByteString -> RSA.PrivateKey
+rsaKeyPair bs = do
+ let (Right kp) = do
+ asn1s <- first show (decodeASN1 DER bs)
+ (r, _) <- fromASN1 asn1s
+ case r of
+ PrivKeyRSA pk -> pure pk
+ _ -> error "Expected RSA Private Key"
+ kp
diff --git a/test/Spec.hs b/test/Spec.hs
index 91a9191fd9cb0223b4fb905c9838bf9d612c93df..69fffcd68e29ef8b612a464257afc9a33b53d86e 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -3,6 +3,7 @@ module Main where
import Control.Exception (Exception, throwIO)
import Control.Monad (replicateM, zipWithM_)
import Control.Monad.IO.Class (liftIO)
+import Crypto.Cipher.Types (nullIV)
import Crypto.Classes (buildKey)
import qualified Data.Binary as Binary
import qualified Data.ByteString as B
@@ -15,7 +16,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16)
import qualified Data.Yaml as Yaml
-import Generators (genAnnouncements, genParameters)
+import Generators (genAnnouncements, genParameters, genRSAKeys)
import Hedgehog (MonadGen, diff, forAll, property, tripping)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
@@ -41,6 +42,8 @@ import Tahoe.Download (
LookupServer,
download,
)
+import qualified Tahoe.SDMF as SDMF
+import qualified Tahoe.SDMF.Keys as SDMF.Keys
import Tahoe.Server (memoryStorageServer)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertEqual, testCase)
@@ -244,7 +247,7 @@ tests =
"download should fail with details about unreachable server"
(Left (NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = 3, notEnoughDecodedSharesFound = 0}))
result
- , testProperty "success" $
+ , testProperty "chk success" $
property $ do
-- If we can recover enough distinct, decodeable shares from the
-- configured servers then we can recover the application data.
@@ -291,6 +294,51 @@ tests =
-- Recover the plaintext from the servers.
result <- liftIO $ download serverAnnouncements cap lookupServer
diff (Right plaintext) (==) result
+ , testProperty "ssk success" $
+ property $ do
+ -- Like "chk success" above, but for SDMF (a case of SSK).
+ plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)
+ sequenceNumber <- forAll $ Gen.integral (Range.exponential 1 10000)
+ keypair <- SDMF.Keys.KeyPair <$> forAll genRSAKeys
+ Parameters{paramRequiredShares = required, paramTotalShares = total} <- forAll genParameters
+
+ -- Since multiple shares can be placed on a single server, as long
+ -- as we have one server we have a valid case. Since some shares
+ -- might be placed non-optimally it is also nice to allow for some
+ -- empty servers so allow for that as well.
+ let numServers = Range.linear 1 (fromIntegral total + 1)
+ serverIDs = Gen.text (Range.singleton 2) Gen.ascii
+ serverIDs' <- forAll $ Gen.set numServers serverIDs
+
+ perServerShareCount <-
+ forAll $
+ genListWithSum (length serverIDs') (fromIntegral total)
+
+ -- Make the servers.
+ servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer
+
+ -- Derive the keys, encode the data.
+ let -- Not a very good IV choice in reality but it's okay for
+ -- 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
+ -- Distribute the shares.
+ liftIO $ placeMutable writeCap (Binary.encode <$> shares) perServerShareCount servers 0
+
+ let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers
+ lookupServer = someServers serverMap
+ serverAnnouncements = Map.fromSet makeAnn serverIDs'
+
+ -- Recover the plaintext from the servers.
+ result <- liftIO $ download serverAnnouncements readCap lookupServer
+ diff (Right plaintext) (==) result
, testCase "immutable upload/download to using Great Black Swamp" $ do
pure ()
-- Consider moving these tests to another module, they're pretty
@@ -323,6 +371,9 @@ tests =
-- Exactly match the nonsense makeAnn spits out
parseURL = T.take 2 . T.drop 5
+ placeMutable :: SDMF.Writer -> [BL.ByteString] -> [Int] -> [StorageServer] -> Int -> IO ()
+ placeMutable = undefined
+
--- PHILOSOFY
-- We wish that share numbers were an opaque type instead of a
-- numeric/integral type. This is not the place to argue the point