diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs
index ad2a9b13209c1452bc46cfe5dee69424ed510b37..b4b5bd0b35ac40816fd5e4cb117b972eb5fdc3c3 100644
--- a/src/TahoeLAFS/Storage/API.hs
+++ b/src/TahoeLAFS/Storage/API.hs
@@ -28,10 +28,9 @@ module TahoeLAFS.Storage.API (
WriteVector (..),
ReadTestWriteVectors (..),
ReadTestWriteResult (..),
- ReadVectors,
- ReadVector,
+ ReadVector (..),
QueryRange,
- TestVector (TestVector),
+ TestVector (..),
ReadResult,
CorruptionDetails (..),
TestOperator (..),
@@ -47,6 +46,9 @@ module TahoeLAFS.Storage.API (
leaseCancelSecretLength,
CBOR,
CBORSet (..),
+ readv,
+ writev,
+ testv,
) where
import Codec.CBOR.Encoding (encodeBytes)
@@ -71,9 +73,11 @@ import Data.Aeson.Types (
toJSONKeyText,
)
import Data.Bifunctor (Bifunctor (bimap))
+import Data.ByteArray (constEq)
import qualified Data.ByteString as B
import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import qualified Data.Map as Map
+import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import Data.Map.Strict (
Map,
)
@@ -411,6 +415,9 @@ instance ToHttpApiData ByteRanges where
newtype UploadSecret = UploadSecret B.ByteString
newtype WriteEnablerSecret = WriteEnablerSecret B.ByteString
+instance Eq WriteEnablerSecret where
+ (WriteEnablerSecret left) == (WriteEnablerSecret right) = constEq left right
+
data LeaseSecret = Renew B.ByteString | Cancel B.ByteString | Upload UploadSecret | Write WriteEnablerSecret
isUploadSecret :: LeaseSecret -> Bool
@@ -523,18 +530,6 @@ type StorageAPI =
type ReadResult = Map ShareNumber [ShareData]
-data ReadVectors = ReadVectors
- { shares :: [ShareNumber]
- , readVectors :: [ReadVector]
- }
- deriving (Show, Eq, Generic)
-
-instance ToJSON ReadVectors where
- toJSON = genericToJSON tahoeJSONOptions
-
-instance FromJSON ReadVectors where
- parseJSON = genericParseJSON tahoeJSONOptions
-
data ReadTestWriteResult = ReadTestWriteResult
{ success :: Bool
, readData :: ReadResult
@@ -587,9 +582,35 @@ data TestWriteVectors = TestWriteVectors
}
deriving (Show, Eq, Generic, ToJSON, FromJSON)
+instance Semigroup TestWriteVectors where
+ (TestWriteVectors testL writeL _) <> (TestWriteVectors testR writeR newLengthR) =
+ TestWriteVectors (testL <> testR) (writeL <> writeR) newLengthR
+
+instance Monoid TestWriteVectors where
+ mempty = TestWriteVectors mempty mempty Nothing
+
+instance Monoid ReadTestWriteVectors where
+ mempty = ReadTestWriteVectors mempty []
+
+instance Semigroup ReadTestWriteVectors where
+ (ReadTestWriteVectors wv0 rv0) <> (ReadTestWriteVectors wv1 rv1) =
+ ReadTestWriteVectors (merge preserveMissing preserveMissing (zipWithMatched $ \_ l r -> l <> r) wv0 wv1) (rv0 <> rv1)
+
-- XXX This derived instance is surely not compatible with Tahoe-LAFS.
instance Serialise TestWriteVectors
+readv :: Offset -> Size -> ReadTestWriteVectors
+readv offset size = mempty{readVector = [ReadVector offset size]}
+
+writev :: ShareNumber -> Offset -> ShareData -> ReadTestWriteVectors
+writev shareNum offset bytes = mempty{testWriteVectors = Map.singleton shareNum (mempty{write = [WriteVector offset bytes]})}
+
+testv :: ShareNumber -> Offset -> ShareData -> ReadTestWriteVectors
+testv shareNum offset specimen =
+ mempty
+ { testWriteVectors = Map.singleton shareNum (mempty{test = [TestVector offset (fromIntegral $ B.length specimen) Eq specimen]})
+ }
+
-- XXX Most of these operators have been removed from the spec.
data TestOperator
= Lt
@@ -620,7 +641,6 @@ data WriteVector = WriteVector
}
deriving (Show, Eq, Generic, ToJSON, FromJSON)
--- XXX This derived instance is surely not compatible with Tahoe-LAFS.
instance Serialise WriteVector
api :: Proxy StorageAPI
diff --git a/src/TahoeLAFS/Storage/Backend.hs b/src/TahoeLAFS/Storage/Backend.hs
index dd99152eafbd481bab4162b8d8f3d891925e1f1f..5d772befe6ff8222a7668ae25212a8a2801f75ba 100644
--- a/src/TahoeLAFS/Storage/Backend.hs
+++ b/src/TahoeLAFS/Storage/Backend.hs
@@ -46,6 +46,7 @@ data WriteImmutableError
| ImmutableShareAlreadyWritten
| ShareNotAllocated
| IncorrectUploadSecret
+ | IncorrectWriteEnablerSecret
deriving (Ord, Eq, Show)
instance Exception WriteImmutableError
diff --git a/src/TahoeLAFS/Storage/Backend/Filesystem.hs b/src/TahoeLAFS/Storage/Backend/Filesystem.hs
index 6b2babfe56dca1f9b076aa40d0fdf99acca72056..e42c0d04e51691e982ecc0089fe10d933603bdae 100644
--- a/src/TahoeLAFS/Storage/Backend/Filesystem.hs
+++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs
@@ -180,7 +180,7 @@ instance Backend FilesystemBackend where
(ReadTestWriteVectors testWritev _readv) = do
-- TODO implement readv and testv parts.
-- TODO implement secrets
- mapM_ (applyWriteVectors root storageIndex) $ toList testWritev
+ mapM_ applyWriteVectors $ toList testWritev
return
ReadTestWriteResult
{ success = True
@@ -188,34 +188,30 @@ instance Backend FilesystemBackend where
}
where
applyWriteVectors ::
- FilePath ->
- StorageIndex ->
(ShareNumber, TestWriteVectors) ->
IO ()
- applyWriteVectors _root _storageIndex (shareNumber', testWriteVectors) =
- mapM_ (applyShareWrite root storageIndex shareNumber') (write testWriteVectors)
+ applyWriteVectors (shareNumber', testWriteVectors) =
+ mapM_ (applyShareWrite shareNumber') (write testWriteVectors)
applyShareWrite ::
- FilePath ->
- StorageIndex ->
ShareNumber ->
WriteVector ->
IO ()
- applyShareWrite _root _storageIndex shareNumber' (WriteVector offset shareData) =
- let sharePath = pathOfShare root storageIndex shareNumber'
- createParents = True
- in do
- createDirectoryIfMissing createParents $ takeDirectory sharePath
- withBinaryFile sharePath ReadWriteMode (writeAtPosition offset shareData)
+ applyShareWrite shareNumber' (WriteVector offset shareData) = do
+ createDirectoryIfMissing createParents $ takeDirectory sharePath
+ withBinaryFile sharePath ReadWriteMode (writeAtPosition offset shareData)
where
- writeAtPosition ::
- Offset ->
- ShareData ->
- Handle ->
- IO ()
- writeAtPosition _offset shareData' handle = do
- hSeek handle AbsoluteSeek offset
- hPut handle shareData'
+ sharePath = pathOfShare root storageIndex shareNumber'
+ createParents = True
+
+ writeAtPosition ::
+ Offset ->
+ ShareData ->
+ Handle ->
+ IO ()
+ writeAtPosition offset shareData' handle = do
+ hSeek handle AbsoluteSeek offset
+ hPut handle shareData'
-- Does the given backend have the complete share indicated?
haveShare ::
diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs
index 7efbd7da583cf6bde9c4b52711a4529372b5d32c..b10ee5413361df315fe5dece9d5f44247f34ee8d 100644
--- a/src/TahoeLAFS/Storage/Backend/Memory.hs
+++ b/src/TahoeLAFS/Storage/Backend/Memory.hs
@@ -3,11 +3,16 @@
module TahoeLAFS.Storage.Backend.Memory (
MemoryBackend (MemoryBackend),
memoryBackend,
+ MutableShareSize (..),
+ shareDataSize,
+ toMutableShareSize,
) where
import Control.Exception (
throw,
+ throwIO,
)
+import Control.Foldl.ByteString (Word8)
import Data.ByteArray (constEq)
import qualified Data.ByteString as B
import Data.IORef (
@@ -17,25 +22,21 @@ import Data.IORef (
newIORef,
readIORef,
)
-import Data.Map.Strict (
- Map,
- adjust,
- fromList,
- insert,
- keys,
- lookup,
- map,
- toList,
- )
+import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import qualified Data.Map.Strict as Map
-import Data.Maybe (isNothing)
+import Data.Maybe (fromMaybe, isNothing)
+import Data.Monoid (Last (Last, getLast))
import qualified Data.Set as Set
+import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix))
import TahoeLAFS.Storage.API (
AllocateBuckets (AllocateBuckets),
AllocationResult (..),
CBORSet (..),
+ Offset,
+ QueryRange,
ReadTestWriteResult (..),
ReadTestWriteVectors (..),
+ ReadVector (ReadVector, offset, readSize),
ShareData,
ShareNumber,
Size,
@@ -44,12 +45,12 @@ import TahoeLAFS.Storage.API (
UploadSecret (UploadSecret),
Version (..),
Version1Parameters (..),
- WriteEnablerSecret,
+ WriteEnablerSecret (WriteEnablerSecret),
WriteVector (..),
)
import TahoeLAFS.Storage.Backend (
Backend (..),
- WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, ShareNotAllocated, ShareSizeMismatch),
+ WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret, ShareNotAllocated, ShareSizeMismatch),
withUploadSecret,
)
import Prelude hiding (
@@ -57,18 +58,58 @@ import Prelude hiding (
map,
)
-data Share = Complete ShareData | Uploading UploadSecret ShareData
+data ImmutableShare = Complete ShareData | Uploading UploadSecret ShareData
data Bucket = Bucket
{ bucketSize :: Size
- , bucketShares :: Map ShareNumber Share
+ , bucketShares :: Map.Map ShareNumber ImmutableShare
}
-type ShareStorage = Map StorageIndex (Map ShareNumber ShareData)
+data SecretProtected a = SecretProtected WriteEnablerSecret a
+
+readSecret :: SecretProtected a -> WriteEnablerSecret
+readSecret (SecretProtected s _) = s
+
+readProtected :: SecretProtected a -> a
+readProtected (SecretProtected _ p) = p
+
+{- | Apply a function in a SecretProtected to a value in a SecretProtected. The
+ result is in SecretProtected with the function's secret.
+
+ This is almost liftA2 but it's not clear to me how to have lawful handling of
+ the secret.
+-}
+liftProtected2 :: (a -> a -> a) -> SecretProtected a -> SecretProtected a -> SecretProtected a
+liftProtected2 f (SecretProtected secretL x) (SecretProtected _ y) = SecretProtected secretL (f x y)
+
+instance Functor SecretProtected where
+ fmap f (SecretProtected secret a) = SecretProtected secret (f a)
+
+type MutableShareStorage = Map.Map StorageIndex (SecretProtected (Map.Map ShareNumber [WriteVector]))
+
+data MutableShareSize = MutableShareSize Offset Size deriving (Show, Eq)
+
+instance Semigroup MutableShareSize where
+ (MutableShareSize writeOffsetL sizeL) <> (MutableShareSize writeOffsetR sizeR) =
+ MutableShareSize minOffset maxSize
+ where
+ minOffset = min writeOffsetL writeOffsetR
+ maxSize = max (writeOffsetL + sizeL) (writeOffsetR + sizeR) - minOffset
+
+instance Monoid MutableShareSize where
+ mempty = MutableShareSize 0 0
+
+toMutableShareSize :: WriteVector -> MutableShareSize
+toMutableShareSize (WriteVector offset bytes) = MutableShareSize offset (fromIntegral $ B.length bytes)
+
+shareDataSize :: [WriteVector] -> Size
+shareDataSize writev = offset + size
+ where
+ (MutableShareSize offset size) = foldMap toMutableShareSize writev
data MemoryBackend = MemoryBackend
- { memoryBackendBuckets :: Map StorageIndex Bucket -- Completely or partially written immutable share data
- , mutableShares :: ShareStorage -- Completely written mutable shares
+ { memoryBackendBuckets :: Map.Map StorageIndex Bucket -- Completely or partially written immutable share data
+ , mutableShares :: MutableShareStorage -- Completely written mutable shares
}
getShareNumbers :: StorageIndex -> MemoryBackend -> CBORSet ShareNumber
@@ -125,13 +166,13 @@ abort ::
(MemoryBackend, ())
abort storageIndex shareNumber (UploadSecret abortSecret) b@MemoryBackend{memoryBackendBuckets} = (b{memoryBackendBuckets = updated memoryBackendBuckets}, ())
where
- updated :: Map StorageIndex Bucket -> Map StorageIndex Bucket
+ updated :: Map.Map StorageIndex Bucket -> Map.Map StorageIndex Bucket
updated = Map.adjust abortIt storageIndex
abortIt :: Bucket -> Bucket
abortIt bucket@Bucket{bucketShares} = bucket{bucketShares = Map.update abortIt' shareNumber bucketShares}
- abortIt' :: Share -> Maybe Share
+ abortIt' :: ImmutableShare -> Maybe ImmutableShare
abortIt' (Uploading (UploadSecret existingSecret) _) = if constEq existingSecret abortSecret then Nothing else throw IncorrectUploadSecret
abortIt' _ = throw ImmutableShareAlreadyWritten
@@ -151,7 +192,7 @@ writeImm storageIndex shareNum (UploadSecret uploadSecret) newData b@MemoryBacke
size = bucketSize <$> bucket
updated = Map.adjust (\bkt -> bkt{bucketShares = Map.adjust writeToShare shareNum (bucketShares bkt)}) storageIndex memoryBackendBuckets
- writeToShare :: Share -> Share
+ writeToShare :: ImmutableShare -> ImmutableShare
writeToShare (Complete _) = throw ImmutableShareAlreadyWritten
writeToShare (Uploading (UploadSecret existingSecret) existingData)
| authorized =
@@ -181,35 +222,59 @@ instance Backend (IORef MemoryBackend) where
getMutableShareNumbers :: IORef MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)
getMutableShareNumbers backend storageIndex = do
- shares' <- mutableShares <$> readIORef backend
- return $
- CBORSet . Set.fromList $
- maybe [] keys $
- lookup storageIndex shares'
+ sharemap <- fmap readProtected . Map.lookup storageIndex . mutableShares <$> readIORef backend
+ return
+ . CBORSet
+ . Set.fromList
+ . maybe [] Map.keys
+ $ sharemap
readvAndTestvAndWritev :: IORef MemoryBackend -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadTestWriteResult
readvAndTestvAndWritev
backend
storageIndex
- _secrets
- (ReadTestWriteVectors testWritev _readv) = do
- -- TODO implement readv and testv parts.
- -- TODO implement secret check
- modifyIORef backend $ \m@MemoryBackend{mutableShares} -> m{mutableShares = addShares storageIndex (shares' testWritev) mutableShares}
- return
- ReadTestWriteResult
- { success = True
- , readData = mempty
- }
+ secret
+ (ReadTestWriteVectors testWritev readv) = do
+ -- TODO implement testv parts.
+
+ (CBORSet allShareNums) <- getMutableShareNumbers backend storageIndex
+ let queryRange = readvToQueryRange readv
+
+ readData <- mapM (\shareNum -> (shareNum,) <$> readMutableShare' backend storageIndex shareNum queryRange) (Set.toList allShareNums)
+ outcome <- atomicModifyIORef' backend tryWrite
+ case outcome of
+ TestSuccess ->
+ return
+ ReadTestWriteResult
+ { readData = Map.fromList readData
+ , success = True
+ }
+ TestFail ->
+ return
+ ReadTestWriteResult
+ { readData = Map.fromList readData
+ , success = False
+ }
+ SecretMismatch ->
+ throwIO IncorrectWriteEnablerSecret
where
- shares' ::
- Map ShareNumber TestWriteVectors ->
- [(ShareNumber, ShareData)]
- shares' testWritevs =
- [ (shareNumber, shareData writev)
- | (shareNumber, testWritev') <- toList testWritevs
- , writev <- write testWritev'
- ]
+ readvToQueryRange :: [ReadVector] -> QueryRange
+ -- readvToQueryRange [] = Nothing
+ readvToQueryRange rv = Just (go rv)
+ where
+ go [] = []
+ go (r : rs) = ByteRangeFromTo off end : go rs
+ where
+ off = offset r
+ end = off + readSize r - 1
+
+ tryWrite m@MemoryBackend{mutableShares} =
+ case addShares storageIndex secret mutableShares (Map.map write testWritev) of
+ Nothing -> (m, SecretMismatch)
+ Just newShares -> (m{mutableShares = newShares}, TestSuccess)
+
+ readMutableShare backend storageIndex shareNum queryRange =
+ B.concat <$> readMutableShare' backend storageIndex shareNum queryRange
createImmutableStorageIndex backend storageIndex secrets (AllocateBuckets shareNums size) =
withUploadSecret secrets $ \secret ->
@@ -231,9 +296,9 @@ instance Backend (IORef MemoryBackend) where
readImmutableShare backend storageIndex shareNum _qr = do
buckets <- memoryBackendBuckets <$> readIORef backend
- case lookup storageIndex buckets of
+ case Map.lookup storageIndex buckets of
Nothing -> pure mempty
- Just bucket -> case lookup shareNum (bucketShares bucket) of
+ Just bucket -> case Map.lookup shareNum (bucketShares bucket) of
Just (Complete shareData) -> pure shareData
_ -> pure mempty
@@ -241,25 +306,88 @@ totalShareSize :: MemoryBackend -> IO Size
totalShareSize backend = do
let imm = memoryBackendBuckets backend
mut = mutableShares backend
- let immSize = sum $ map bucketTotalSize imm
- let mutSize = sum $ map length mut
+ let immSize = sum $ Map.map bucketTotalSize imm
+ let mutSize = sum $ Map.map (length . readProtected) mut
return $ toInteger $ immSize + fromIntegral mutSize
bucketTotalSize :: Bucket -> Size
bucketTotalSize Bucket{bucketSize, bucketShares} = bucketSize * fromIntegral (Map.size bucketShares)
-addShares :: StorageIndex -> [(ShareNumber, ShareData)] -> ShareStorage -> ShareStorage
-addShares _storageIndex [] shareStorage = shareStorage
-addShares storageIndex ((shareNumber, shareData) : rest) shareStorage =
- let added = case lookup storageIndex shareStorage of
- Nothing ->
- insert storageIndex (fromList [(shareNumber, shareData)]) shareStorage
- Just _shares ->
- adjust addShare' storageIndex shareStorage
- where
- addShare' = insert shareNumber shareData
- in addShares storageIndex rest added
+addShare :: StorageIndex -> WriteEnablerSecret -> ShareNumber -> [WriteVector] -> MutableShareStorage -> MutableShareStorage
+addShare storageIndex secret shareNum writev =
+ Map.insertWith (liftProtected2 f) storageIndex newShare
+ where
+ f :: Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector]
+ f = merge preserveMissing preserveMissing (zipWithMatched (const (<>)))
+
+ newShare = SecretProtected secret (Map.singleton shareNum writev)
+
+addShares :: StorageIndex -> WriteEnablerSecret -> MutableShareStorage -> Map.Map ShareNumber [WriteVector] -> Maybe MutableShareStorage
+addShares storageIndex secret existing updates
+ | isNothing existingSecret = Just go
+ | existingSecret == Just secret = Just go
+ | otherwise = Nothing
+ where
+ go = Map.foldrWithKey (addShare storageIndex secret) existing updates
+
+ existingSecret = readSecret <$> Map.lookup storageIndex existing
memoryBackend :: IO (IORef MemoryBackend)
memoryBackend = do
newIORef $ MemoryBackend mempty mempty
+
+readMutableShare' :: IORef MemoryBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO [ShareData]
+readMutableShare' backend storageIndex shareNum queryRange = do
+ storage <- mutableShares <$> readIORef backend
+ pure $ doOneRead <$> rv storage <*> pure storage
+ where
+ rv :: MutableShareStorage -> [ReadVector]
+ rv storage = queryRangeToReadVector storage queryRange
+
+ getShareData storage =
+ Map.lookup storageIndex storage >>= Map.lookup shareNum . readProtected
+
+ doOneRead :: ReadVector -> MutableShareStorage -> ShareData
+ doOneRead readv storage =
+ maybe "" (readOneVector readv) (getShareData storage)
+
+ queryRangeToReadVector :: MutableShareStorage -> QueryRange -> [ReadVector]
+ queryRangeToReadVector storage Nothing = [ReadVector 0 size]
+ where
+ size = maybe 0 shareDataSize (getShareData storage)
+ queryRangeToReadVector storage (Just ranges) = toReadVector <$> ranges
+ where
+ toReadVector (ByteRangeFrom start) = ReadVector start size
+ where
+ size = maybe 0 shareDataSize (getShareData storage)
+ toReadVector (ByteRangeFromTo start end) = ReadVector start (end - start + 1)
+ toReadVector (ByteRangeSuffix len) = ReadVector (size - len) len
+ where
+ size = maybe 0 shareDataSize (getShareData storage)
+
+ readOneVector :: ReadVector -> [WriteVector] -> ShareData
+ readOneVector ReadVector{offset, readSize} wv =
+ B.pack (extractBytes <$> positions)
+ where
+ positions = [offset .. (offset + readSize - 1)]
+
+ extractBytes :: Integer -> Word8
+ extractBytes p = fromMaybe 0 (go wv)
+ where
+ -- New writes are added to the end of the list so give the Last
+ -- write precedence over others.
+ go = getLast . foldMap (Last . byteFromShare p)
+
+ byteFromShare :: Integer -> WriteVector -> Maybe Word8
+ byteFromShare p (WriteVector off bytes)
+ | p >= off && p < off + fromIntegral (B.length bytes) = Just (B.index bytes (fromIntegral $ p - off))
+ | otherwise = Nothing
+
+-- | Internal type tracking the result of an attempted mutable write.
+data WriteResult
+ = -- | The test condition succeeded and the write was performed.
+ TestSuccess
+ | -- | The test condition failed and the write was not performed.
+ TestFail
+ | -- | The supplied secret was incorrect and the write was not performed.
+ SecretMismatch
diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal
index a644e9c3340ef6764ef917f857f7eefa3956f0d1..26b37f6958b472a9df7b89b704a6b0d1ad12edf2 100644
--- a/tahoe-great-black-swamp.cabal
+++ b/tahoe-great-black-swamp.cabal
@@ -217,6 +217,7 @@ test-suite http-tests
, cborg >=0.2.4 && <0.3
, connection >=0.3 && <0.4
, data-default-class >=0.1 && <0.2
+ , data-interval
, hspec <2.12
, hspec-expectations <0.9
, hspec-wai <0.12
@@ -224,6 +225,7 @@ test-suite http-tests
, network >=3.1 && <3.2
, network-simple-tls >=0.4 && <0.5
, QuickCheck <2.15
+ , quickcheck-classes >=0.6 && <0.7
, quickcheck-instances <0.4
, serialise >=0.2.3 && <0.3
, servant >=0.16.2 && <0.21
diff --git a/test/Lib.hs b/test/Lib.hs
index d33432877382756c98ce145fad3b5e70614ed04f..e4a21217bb1a3364e4dab8848daa84761ca028aa 100644
--- a/test/Lib.hs
+++ b/test/Lib.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
module Lib (
gen10String,
@@ -22,10 +23,12 @@ import Data.ByteString (
import qualified Data.Text as Text
+import qualified Data.Map.Strict as Map
import Test.QuickCheck (
Arbitrary (arbitrary),
Gen,
- NonNegative (getNonNegative),
+ NonNegative (NonNegative, getNonNegative),
+ Positive (getPositive),
shuffle,
sublistOf,
suchThatMap,
@@ -36,8 +39,16 @@ import Test.QuickCheck (
import Test.QuickCheck.Instances.ByteString ()
import TahoeLAFS.Storage.API (
+ Offset,
+ ReadTestWriteResult (ReadTestWriteResult),
+ ReadTestWriteVectors (ReadTestWriteVectors),
+ ReadVector (ReadVector),
ShareNumber (..),
StorageIndex,
+ TestOperator (Eq),
+ TestVector (TestVector),
+ TestWriteVectors (TestWriteVectors),
+ WriteVector (..),
)
gen10String :: Gen String
@@ -65,7 +76,7 @@ b32decode :: String -> ByteString
b32decode base32 =
Base32.toBytes b32table $ Base32.fromText b32table $ Text.pack base32
-newtype ShareNumbers = ShareNumbers [ShareNumber] deriving (Eq, Ord, Show)
+newtype ShareNumbers = ShareNumbers {getShareNumbers :: [ShareNumber]} deriving (Eq, Ord, Show)
{- | An Arbitrary instance that guarantees ShareNumbers are unique and
non-empty (without invoking discard).
@@ -77,3 +88,24 @@ instance Arbitrary ShareNumbers where
arbitrary
>>= (shuffle . enumFromTo 0) . getNonNegative
>>= \(num : rest) -> (num :) <$> sublistOf rest
+
+instance Arbitrary ShareNumber where
+ arbitrary = ShareNumber <$> arbNonNeg
+
+instance Arbitrary ReadTestWriteVectors where
+ arbitrary = ReadTestWriteVectors <$> arbitrary <*> arbitrary
+
+instance Arbitrary TestWriteVectors where
+ arbitrary = TestWriteVectors <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary TestVector where
+ arbitrary = TestVector <$> arbNonNeg <*> arbNonNeg <*> pure Eq <*> arbitrary
+
+instance Arbitrary WriteVector where
+ arbitrary = WriteVector <$> arbNonNeg <*> arbitrary
+
+instance Arbitrary ReadVector where
+ arbitrary = ReadVector <$> arbNonNeg <*> (getPositive <$> arbitrary)
+
+arbNonNeg :: Gen Offset
+arbNonNeg = getNonNegative <$> arbitrary
diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs
index c2fd18421c0b3282b6fb34b2538a573fec7c63bb..4a9092e78b9d16397780c38d0c354c245122428d 100644
--- a/test/SemanticSpec.hs
+++ b/test/SemanticSpec.hs
@@ -22,6 +22,7 @@ import GHC.Word (
Word8,
)
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import System.Directory (
@@ -38,14 +39,22 @@ import Test.Hspec (
context,
describe,
it,
+ shouldBe,
shouldThrow,
)
-
import Test.QuickCheck (
+ Gen,
+ NonEmptyList (getNonEmpty),
Positive (..),
Property,
+ chooseInteger,
+ counterexample,
forAll,
+ ioProperty,
+ oneof,
property,
+ vector,
+ (==>),
)
import Test.QuickCheck.Monadic (
@@ -53,26 +62,30 @@ import Test.QuickCheck.Monadic (
run,
)
-import Data.ByteString (
- ByteString,
- length,
- map,
- )
+import qualified Data.ByteString as B
import TahoeLAFS.Storage.API (
AllocateBuckets (AllocateBuckets),
AllocationResult (AllocationResult),
CBORSet (..),
LeaseSecret (..),
+ Offset,
+ ReadTestWriteResult (readData, success),
+ ReadTestWriteVectors,
+ ReadVector (ReadVector),
ShareData,
ShareNumber (ShareNumber),
Size,
StorageIndex,
+ TestWriteVectors,
UploadSecret (UploadSecret),
WriteEnablerSecret (WriteEnablerSecret),
+ WriteVector (WriteVector),
allocated,
alreadyHave,
+ readv,
toInteger,
+ writev,
)
import TahoeLAFS.Storage.Backend (
@@ -82,6 +95,7 @@ import TahoeLAFS.Storage.Backend (
getImmutableShareNumbers,
getMutableShareNumbers,
readImmutableShare,
+ readvAndTestvAndWritev,
writeImmutableShare
),
WriteImmutableError (..),
@@ -90,7 +104,6 @@ import TahoeLAFS.Storage.Backend (
import Data.IORef (IORef)
--- We also get the Arbitrary ShareNumber instance from here.
import Lib (
ShareNumbers (..),
genStorageIndex,
@@ -98,16 +111,23 @@ import Lib (
import TahoeLAFS.Storage.Backend.Memory (
MemoryBackend (..),
+ MutableShareSize (MutableShareSize),
memoryBackend,
+ shareDataSize,
+ toMutableShareSize,
)
+import Data.Data (Proxy (Proxy))
+import Data.Interval (Boundary (Closed, Open), Extended (Finite), Interval, interval, lowerBound, upperBound)
+import qualified Data.IntervalSet as IS
import TahoeLAFS.Storage.Backend.Filesystem (
FilesystemBackend (FilesystemBackend),
)
+import Test.QuickCheck.Classes (Laws (..), semigroupMonoidLaws)
-permuteShare :: ByteString -> ShareNumber -> ByteString
+permuteShare :: B.ByteString -> ShareNumber -> B.ByteString
permuteShare seed number =
- Data.ByteString.map xor' seed
+ B.map xor' seed
where
xor' :: Word8 -> Word8
xor' = xor $ fromInteger $ toInteger number
@@ -149,11 +169,11 @@ immutableWriteAndEnumerateShares ::
IO b ->
StorageIndex ->
ShareNumbers ->
- ByteString ->
+ B.ByteString ->
Property
immutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do
let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers
- size = fromIntegral (Data.ByteString.length shareSeed)
+ size = fromIntegral (B.length shareSeed)
allocate = AllocateBuckets shareNumbers size
run $
withBackend makeBackend $ \backend -> do
@@ -172,10 +192,10 @@ immutableWriteAndRewriteShare ::
IO b ->
StorageIndex ->
ShareNumbers ->
- ByteString ->
+ B.ByteString ->
Property
immutableWriteAndRewriteShare makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do
- let size = fromIntegral (Data.ByteString.length shareSeed)
+ let size = fromIntegral (B.length shareSeed)
allocate = AllocateBuckets shareNumbers size
aShareNumber = head shareNumbers
aShare = permuteShare shareSeed aShareNumber
@@ -196,11 +216,11 @@ immutableWriteAndReadShare ::
IO b ->
StorageIndex ->
ShareNumbers ->
- ByteString ->
+ B.ByteString ->
Property
immutableWriteAndReadShare makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do
let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers
- let size = fromIntegral (Data.ByteString.length shareSeed)
+ let size = fromIntegral (B.length shareSeed)
let allocate = AllocateBuckets shareNumbers size
run $
withBackend makeBackend $ \backend -> do
@@ -219,7 +239,7 @@ mutableWriteAndEnumerateShares ::
IO b ->
StorageIndex ->
ShareNumbers ->
- ByteString ->
+ B.ByteString ->
Property
mutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do
let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers
@@ -231,9 +251,17 @@ mutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbe
when (readShareNumbers /= Set.fromList shareNumbers) $
fail (show readShareNumbers ++ " /= " ++ show shareNumbers)
--- The specification for a storage backend.
+-- | Create a Spec that checks the given Laws.
+lawsCheck :: Laws -> Spec
+lawsCheck Laws{lawsTypeclass, lawsProperties} =
+ describe lawsTypeclass $
+ mapM_ oneLawProp lawsProperties
+ where
+ oneLawProp (lawName, lawProp) = it lawName lawProp
+
+-- | The specification for a storage backend.
storageSpec :: (Backend b, Mess b) => IO b -> Spec
-storageSpec makeBackend =
+storageSpec makeBackend = do
context "v1" $ do
context "immutable" $ do
describe "allocate a storage index" $
@@ -292,11 +320,122 @@ storageSpec makeBackend =
property $
forAll genStorageIndex (mutableWriteAndEnumerateShares makeBackend)
+ it "rejects an update with the wrong write enabler" $
+ forAll genStorageIndex $ \storageIndex shareNum (secret, wrongSecret) (shareData, junkData) offset ->
+ (secret /= wrongSecret)
+ && (shareData /= junkData)
+ && (B.length shareData > 0)
+ && (B.length junkData > 0)
+ ==> monadicIO
+ . run
+ . withBackend makeBackend
+ $ \backend -> do
+ first <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (writev shareNum offset shareData)
+ success first `shouldBe` True
+ readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret wrongSecret) (writev shareNum offset junkData)
+ `shouldThrow` (== IncorrectWriteEnablerSecret)
+ third <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (readv offset (fromIntegral $ B.length shareData))
+ readData third `shouldBe` Map.singleton shareNum [shareData]
+
+ it "overwrites older data with newer data" $
+ property $ \storageIndex (readVectors :: NonEmptyList ReadVector) secret shareNum -> do
+ let is = readVectorToIntervalSet (getNonEmpty readVectors)
+ sp = IS.span is
+ (lower, upper) = toFiniteBounds sp
+ size = upper - lower
+ bs <- B.pack <$> vector (fromIntegral size)
+ writeVectors <- writesThatResultIn bs lower size
+ pure $
+ counterexample ("write vectors: " <> show writeVectors) $
+ ioProperty $
+ withBackend makeBackend $ \backend -> do
+ let x = foldMap (\(WriteVector off shareData) -> writev shareNum off shareData) writeVectors
+ writeResult <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) x
+ success writeResult `shouldBe` True
+
+ let y = foldMap (\(ReadVector off sz) -> readv off sz) (getNonEmpty readVectors)
+ readResult <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) y
+ Map.map B.concat (readData readResult)
+ `shouldBe` Map.singleton shareNum (B.concat $ extractRead lower bs <$> getNonEmpty readVectors)
+
+extractRead :: Integral a => a -> B.ByteString -> ReadVector -> B.ByteString
+extractRead lower bs (ReadVector offset size) = B.take (fromIntegral size) . B.drop (fromIntegral offset - fromIntegral lower) $ bs
+
+toFiniteBounds :: Show r => Interval r -> (r, r)
+toFiniteBounds i = (lower, upper)
+ where
+ lower = toFinite (lowerBound i)
+ upper = toFinite (upperBound i)
+
+ toFinite n = case n of
+ Finite r -> r
+ e -> error ("Non-finite bound " <> show e)
+
+readVectorToIntervalSet :: [ReadVector] -> IS.IntervalSet Integer
+readVectorToIntervalSet rvs = foldr IS.insert IS.empty (f <$> rvs)
+ where
+ f (ReadVector offset size) = interval (Finite offset, Closed) (Finite $ offset + size, Open)
+
+writesThatResultIn :: B.ByteString -> Offset -> Size -> Gen [WriteVector]
+writesThatResultIn "" _ _ = pure []
+writesThatResultIn bs offset size =
+ oneof
+ [ -- The whole thing as one write
+ pure [WriteVector offset bs]
+ , -- Or divide and conquer arbitrarily
+ do
+ prefixLen <- chooseInteger (0, fromIntegral $ B.length bs)
+ pfx <- writesThatResultIn (B.take (fromIntegral prefixLen) bs) offset prefixLen
+ sfx <- writesThatResultIn (B.drop (fromIntegral prefixLen) bs) (offset + prefixLen) (size - prefixLen)
+ pure $ pfx <> sfx
+ , -- Or write some other random somewhere in this range first, to
+ -- later be overwritten.
+ (:) <$> (WriteVector <$> chooseInteger (offset, offset + size) <*> (chooseInteger (1, size) >>= bytes)) <*> writesThatResultIn bs offset size
+ ]
+
+bytes :: Integer -> Gen B.ByteString
+bytes len = B.pack <$> vector (fromIntegral len)
+
spec :: Spec
spec = do
- Test.Hspec.context "memory" $ storageSpec memoryBackend
-
- Test.Hspec.context "filesystem" $ storageSpec filesystemBackend
+ context "utilities" $ do
+ describe "MutableShareStorage" $ do
+ it "finds the larger size for some cases" $ do
+ toMutableShareSize (WriteVector 0 "x") <> toMutableShareSize (WriteVector 1 "x")
+ `shouldBe` MutableShareSize 0 2
+
+ toMutableShareSize (WriteVector 0 "Hello") <> toMutableShareSize (WriteVector 1 "bye")
+ `shouldBe` MutableShareSize 0 5
+
+ toMutableShareSize (WriteVector 0 "x") <> toMutableShareSize (WriteVector 3 "x")
+ `shouldBe` MutableShareSize 0 4
+
+ toMutableShareSize (WriteVector 0 "Hello") <> toMutableShareSize (WriteVector 3 "world")
+ `shouldBe` MutableShareSize 0 8
+
+ describe "shareDataSize" $ do
+ it "converts list of WriteVector to a size" $ do
+ shareDataSize [WriteVector 2 "foo", WriteVector 10 "quux"]
+ `shouldBe` 14
+ shareDataSize [WriteVector 0 "foobar", WriteVector 2 "q"]
+ `shouldBe` 6
+ shareDataSize []
+ `shouldBe` 0
+ shareDataSize [WriteVector 2 "foo", WriteVector 3 "quux"]
+ `shouldBe` 7
+
+ describe "TestWriteVectors"
+ . lawsCheck
+ . semigroupMonoidLaws
+ $ (Proxy :: Proxy TestWriteVectors)
+
+ describe "ReadTestWriteVectors"
+ . lawsCheck
+ . semigroupMonoidLaws
+ $ (Proxy :: Proxy ReadTestWriteVectors)
+
+ context "memory" $ storageSpec memoryBackend
+ context "filesystem" $ storageSpec filesystemBackend
anUploadSecret :: LeaseSecret
anUploadSecret = Upload $ UploadSecret "anuploadsecret"