Skip to content
Snippets Groups Projects
Spec.hs 11.9 KiB
Newer Older
  • Learn to ignore specific revisions
  • module Main where
    
    
    import Control.Exception (Exception, throwIO)
    import Control.Monad (replicateM, zipWithM_)
    
    import Control.Monad.IO.Class (liftIO)
    import Crypto.Classes (buildKey)
    
    import qualified Data.Binary as Binary
    
    import qualified Data.ByteString as B
    
    import Data.ByteString.Base32 (encodeBase32Unpadded)
    import qualified Data.ByteString.Lazy as BL
    
    import qualified Data.Map.Strict as Map
    
    import qualified Data.Set as Set
    import Data.Text.Encoding (encodeUtf8)
    
    import Generators (genParameters)
    import Hedgehog (MonadGen, diff, forAll, property)
    import qualified Hedgehog.Gen as Gen
    import qualified Hedgehog.Range as Range
    
    import System.IO (hSetEncoding, stderr, stdout, utf8)
    
    import Tahoe.CHK.Capability (Reader (..), Verifier (..))
    
    import qualified Tahoe.CHK.Encrypt
    import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID)
    import Tahoe.CHK.Types (Parameters (..))
    import Tahoe.CHK.Upload (getConvergentKey)
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    import Tahoe.Download (DownloadError (..), download)
    
    import Tahoe.Server (memoryStorageServer)
    
    import Test.Tasty (TestTree, defaultMain, testGroup)
    import Test.Tasty.HUnit (assertEqual, testCase)
    
    import Test.Tasty.Hedgehog (testProperty)
    
    data PlacementError = RanOutOfPlacementInfo | RanOutOfServers deriving (Eq, Show)
    instance Exception PlacementError
    
    
    tests :: TestTree
    tests =
        testGroup
            "All tests"
            [ testCase "no configured servers" $ do
                -- If there are no servers then we can't possibly get enough
                -- shares to recover the application data.
    
                result <- liftIO $ download mempty (trivialCap 1 1) noServers
    
                assertEqual
                    "download should fail with no servers"
                    (Left NoConfiguredServers)
                    result
    
            , testCase "no reachable servers" $ do
                -- If we can't contact any configured server then we can't
                -- possibly get enough shares to recover the application data.
    
                        Map.fromList
                            [
                                ( "v0-abc123"
                                , StorageServerAnnouncement
                                    { storageServerAnnouncementFURL = Nothing
                                    , storageServerAnnouncementNick = Just "unreachable"
                                    , storageServerAnnouncementPermutationSeed = Nothing
                                    }
                                )
                            ]
    
    
                result <- liftIO $ download anns (trivialCap 1 1) noServers
    
                assertEqual
                    "download should fail with no reachable servers"
                    (Left NoReachableServers)
                    result
    
            , testCase "not enough shares" $ do
                -- If we can't recover enough shares from the configured servers
                -- then we can't possibly get enough shares to recover the
                -- application data.
                let anns =
                        Map.fromList
                            [
                                ( "v0-abc123"
                                , StorageServerAnnouncement
                                    { storageServerAnnouncementFURL = Just "somewhere"
                                    , storageServerAnnouncementNick = Just "abc123"
                                    , storageServerAnnouncementPermutationSeed = Nothing
                                    }
                                )
                            ]
                    cap = trivialCap 3 3
    
                -- Two shares exist.
                server <- memoryStorageServer
                storageServerWrite server (storageIndex . verifier $ cap) 0 0 "Hello world"
                storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world"
    
                -- Make the server reachable.
                let openServer furl =
                        if furl == "somewhere"
                            then pure . pure $ server
                            else pure Nothing
    
    
                -- Try to download the cap which requires three shares to reconstruct.
                result <- liftIO $ download anns cap openServer
                assertEqual
                    "download should fail with not enough shares"
                    (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
                    result
            , testCase "not enough distinct shares" $ do
                -- If we can't recover enough *distinct* shares from the
                -- configured servers then we can't possibly get enough shares to
                -- recover the application data.  Duplicate shares do us no good.
                let anns =
                        Map.fromList
                            [
                                ( "v0-abc123"
                                , StorageServerAnnouncement
                                    { storageServerAnnouncementFURL = Just "somewhere"
                                    , storageServerAnnouncementNick = Just "abc123"
                                    , storageServerAnnouncementPermutationSeed = Nothing
                                    }
                                )
                            ,
                                ( "v0-abc456"
                                , StorageServerAnnouncement
                                    { storageServerAnnouncementFURL = Just "elsewhere"
                                    , storageServerAnnouncementNick = Just "abc123"
                                    , storageServerAnnouncementPermutationSeed = Nothing
                                    }
                                )
                            ]
                    cap = trivialCap 3 3
    
                -- Three shares exist
                somewhere <- memoryStorageServer
                let idx = storageIndex . verifier $ cap
                    offset = 0
                storageServerWrite somewhere idx 0 offset "Hello world"
                storageServerWrite somewhere idx 1 offset "Hello world"
                -- But this one is just a duplicate of share 0 on the other
                -- server.
                elsewhere <- memoryStorageServer
                storageServerWrite elsewhere idx 0 offset "Hello world"
    
                -- Make the server reachable.
                let openServer furl =
                        pure $ case furl of
                            "somewhere" -> pure somewhere
                            "elsewhere" -> pure elsewhere
                            _ -> Nothing
    
    
                -- Try to download the cap which requires three shares to reconstruct.
                result <- liftIO $ download anns cap openServer
                assertEqual
                    "download should fail with not enough shares"
                    (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
                    result
    
            , testProperty "success" $
                property $ do
                    -- If we can recover enough distinct, decodeable shares from the
                    -- configured servers then we can recover the application data.
    
                    -- Generates configurations where it should be possible to recover
                    -- the data (have all the shares, have enough of the shares,
                    -- spread them across many servers, concentrate them on one or a
                    -- few, etc)
    
                    secret <- forAll $ Gen.bytes (Range.singleton 32)
                    plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)
                    params@Parameters{paramTotalShares} <- 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 paramTotalShares + 1)
                        serverIDs = Gen.text (Range.singleton 2) Gen.ascii
                    serverIDs' <- forAll $ Gen.set numServers serverIDs
                    -- Constructor <$> arbitrary <*> arbitrary
    
                    -- Choose a share distribution.  Each element of the resulting
                    -- list tells us how many shares to place on the next server, for
                    -- some arbitrary (stable) server ordering.
                    perServerShareCount <-
                        forAll $
                            genListWithSum (length serverIDs') (fromIntegral paramTotalShares)
    
                    -- Make the servers.
                    servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer
    
                    -- Encrypt and encode the data into shares.
                    let key = getConvergentKey secret params plaintext
                        ciphertext = Tahoe.CHK.Encrypt.encrypt key plaintext
                    (shares, cap) <- liftIO $ Tahoe.CHK.encode key params ciphertext
    
                    -- Distribute the shares.
                    liftIO $ placeShares cap (Binary.encode <$> shares) perServerShareCount servers 0
    
                    -- Recover the plaintext from the servers.
                    result <- liftIO $ download (Map.fromSet makeAnn serverIDs') cap (someServers $ Map.fromList $ zip (encodeUtf8 <$> Set.toList serverIDs') servers)
                    diff (Right plaintext) (==) result
    
        -- A server lookup function that always fails.
    
        noServers _ = pure Nothing
    
        -- A server lookup function that finds servers already present in a Map.
        someServers servers = pure . flip Map.lookup servers . parseURL
          where
            -- Exactly match the nonsense makeAnn spits out
            parseURL = B.take 2 . B.drop 5 . encodeUtf8
    
        --- 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
        -- though.
        placeShares :: Reader -> [BL.ByteString] -> [Int] -> [StorageServer] -> Int -> IO ()
        -- Out of shares, done.
        placeShares _ [] _ _ _ = pure ()
        -- Out of placement info but not out of shares is a programming error.
        placeShares _ _ [] _ _ = throwIO RanOutOfPlacementInfo
        -- Out of servers but not out of shares is a programming error.
        placeShares _ _ _ [] _ = throwIO RanOutOfServers
        -- Having some of all three means we can make progress.
        placeShares cap shares (n : ns) (s : ss) sharesSoFar = do
            -- write the right number of shares to this server
            zipWithM_
                (\shnum share -> storageServerWrite s (storageIndex . verifier $ cap) shnum 0 share)
                [fromIntegral n ..]
                (BL.toStrict <$> take n shares)
            -- recurse to write the rest
            placeShares cap (drop n shares) ns ss (sharesSoFar + n)
    
        -- Make up a distinct (but nonsense) announcement for a given storage
        -- server identifier.
        makeAnn :: StorageServerID -> StorageServerAnnouncement
        makeAnn sid =
            StorageServerAnnouncement
                { storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid
                , storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid
                , storageServerAnnouncementPermutationSeed = Nothing
                }
    
        -- Generate lists of ints that sum to a given total.
        genListWithSum :: MonadGen m => Int -> Int -> m [Int]
        -- We hit the target.
        genListWithSum _ 0 = pure []
        -- We only have room for one more element.
        genListWithSum 1 t = pure [t]
        -- Use up some of what's left on one element and recurse.
        genListWithSum maxLength t = do
            v <- Gen.int (Range.linear 0 t)
            (v :) <$> genListWithSum (maxLength - 1) (t - v)
    
    
    trivialCap :: Word16 -> Word16 -> Reader
    trivialCap required total = Reader{..}
      where
        Just readKey = buildKey $ B.replicate 32 0x00
        storageIndex = B.replicate 32 0x00
        fingerprint = B.replicate 32 0x00
        size = 1234
        verifier = Verifier{..}
    
    
    main :: IO ()
    main = do
        -- Hedgehog writes some non-ASCII and the whole test process will die if
        -- it can't be encoded.  Increase the chances that all of the output can
        -- be encoded by forcing the use of UTF-8 (overriding the LANG-based
        -- choice normally made).
        hSetEncoding stdout utf8
        hSetEncoding stderr utf8
    
        defaultMain tests