Newer
Older
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 Data.Word (Word16)
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 qualified Tahoe.CHK
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)
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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
-- 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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
, 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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
-- 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