diff --git a/src/TahoeLAFS/Storage/Backend.hs b/src/TahoeLAFS/Storage/Backend.hs
index 66e3677754d52154c4baeb461fbee4ca1c0396bc..dd99152eafbd481bab4162b8d8f3d891925e1f1f 100644
--- a/src/TahoeLAFS/Storage/Backend.hs
+++ b/src/TahoeLAFS/Storage/Backend.hs
@@ -46,7 +46,6 @@ data WriteImmutableError
| ImmutableShareAlreadyWritten
| ShareNotAllocated
| IncorrectUploadSecret
- | IncorrectWriteEnabler
deriving (Ord, Eq, Show)
instance Exception WriteImmutableError
diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs
index cfe5e25d3c795480107d913a4a6f828948a38c3e..43228cc53f03515973dfc6edfe95099fab4f1131 100644
--- a/src/TahoeLAFS/Storage/Backend/Memory.hs
+++ b/src/TahoeLAFS/Storage/Backend/Memory.hs
@@ -17,7 +17,7 @@ import Data.IORef (
newIORef,
readIORef,
)
-import Data.Map.Merge.Strict (merge, preserveMissing, zipWithAMatched)
+import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import qualified Data.Map.Strict as Map
import Data.Maybe (isNothing)
import qualified Data.Set as Set
@@ -57,12 +57,25 @@ data Bucket = Bucket
data SecretProtected a = SecretProtected WriteEnablerSecret a
-type ShareStorage = Map.Map StorageIndex (SecretProtected (Map.Map ShareNumber ShareData))
+readSecret :: SecretProtected a -> WriteEnablerSecret
+readSecret (SecretProtected s _) = s
-protectedWrite :: WriteEnablerSecret -> (a -> a) -> SecretProtected a -> Maybe (SecretProtected a)
-protectedWrite proposed f (SecretProtected actual a)
- | proposed == actual = Just (SecretProtected actual (f a))
- | otherwise = Nothing
+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 ShareStorage = Map.Map StorageIndex (SecretProtected (Map.Map ShareNumber ShareData))
data MemoryBackend = MemoryBackend
{ memoryBackendBuckets :: Map.Map StorageIndex Bucket -- Completely or partially written immutable share data
@@ -179,27 +192,33 @@ 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 [] Map.keys $
- Map.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
- (WriteEnablerSecret secret)
+ secret
(ReadTestWriteVectors testWritev _readv) = do
-- TODO implement readv and testv parts.
- -- TODO implement secret check
-- TODO handle offsets correctly
- modifyIORef backend $ \m@MemoryBackend{mutableShares} -> m{mutableShares = addShares storageIndex mutableShares (Map.map write testWritev)}
+ success <- atomicModifyIORef' backend tryWrite
+
return
ReadTestWriteResult
- { success = True
- , readData = mempty
+ { readData = mempty
+ , success = success
}
+ where
+ tryWrite m@MemoryBackend{mutableShares} =
+ case addShares storageIndex secret mutableShares (Map.map write testWritev) of
+ Nothing -> (m, False)
+ Just newShares -> (m{mutableShares = newShares}, True)
createImmutableStorageIndex backend storageIndex secrets (AllocateBuckets shareNums size) =
withUploadSecret secrets $ \secret ->
@@ -232,21 +251,32 @@ totalShareSize backend = do
let imm = memoryBackendBuckets backend
mut = mutableShares backend
let immSize = sum $ Map.map bucketTotalSize imm
- let mutSize = sum $ Map.map length mut
+ 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)
-addShare :: StorageIndex -> ShareNumber -> [WriteVector] -> ShareStorage -> ShareStorage
-addShare storageIndex shareNum writev =
- Map.insertWith f storageIndex (Map.singleton shareNum (mconcat $ shareData <$> writev))
+addShare :: StorageIndex -> WriteEnablerSecret -> ShareNumber -> [WriteVector] -> ShareStorage -> ShareStorage
+addShare storageIndex secret shareNum writev =
+ Map.insertWith (liftProtected2 f) storageIndex newShare
where
f :: Map.Map ShareNumber ShareData -> Map.Map ShareNumber ShareData -> Map.Map ShareNumber ShareData
- f = merge preserveMissing preserveMissing (zipWithAMatched $ \_key _old new -> pure new)
+ f = merge preserveMissing preserveMissing (zipWithMatched applyWrites)
+
+ applyWrites :: ShareNumber -> ShareData -> ShareData -> ShareData
+ applyWrites _ _ replacement = replacement -- XXX Need to merge new data into old, not replace it. Probably replace ShareData with a different type that makes this easier.
+ newShare = SecretProtected secret (Map.singleton shareNum (mconcat (shareData <$> writev)))
+
+addShares :: StorageIndex -> WriteEnablerSecret -> ShareStorage -> Map.Map ShareNumber [WriteVector] -> Maybe ShareStorage
+addShares storageIndex secret existing updates
+ | isNothing writeEnabler = Just go
+ | writeEnabler == Just secret = Just go
+ | otherwise = Nothing
+ where
+ go = Map.foldrWithKey (addShare storageIndex secret) existing updates
-addShares :: StorageIndex -> ShareStorage -> Map.Map ShareNumber [WriteVector] -> ShareStorage
-addShares storageIndex = Map.foldrWithKey (addShare storageIndex)
+ writeEnabler = readSecret <$> Map.lookup storageIndex existing
memoryBackend :: IO (IORef MemoryBackend)
memoryBackend = do
diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs
index a1150c73a97f60835677630eb5e9efe00b9aedd2..ae7c52548c6fc82da002ea697bfb29be90813fd3 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,11 +39,11 @@ import Test.Hspec (
context,
describe,
it,
+ shouldBe,
shouldThrow,
)
import Test.QuickCheck (
- Arbitrary (arbitrary),
Positive (..),
Property,
forAll,
@@ -55,27 +56,25 @@ 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 (..),
- ReadTestWriteVectors (ReadTestWriteVectors),
+ ReadTestWriteResult (readData, success),
+ ReadTestWriteVectors,
ShareData,
ShareNumber (ShareNumber),
Size,
StorageIndex,
- TestWriteVectors (TestWriteVectors),
+ TestWriteVectors,
UploadSecret (UploadSecret),
WriteEnablerSecret (WriteEnablerSecret),
allocated,
alreadyHave,
+ readv,
toInteger,
writev,
)
@@ -106,16 +105,15 @@ import TahoeLAFS.Storage.Backend.Memory (
memoryBackend,
)
-import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Data (Proxy (Proxy))
import TahoeLAFS.Storage.Backend.Filesystem (
FilesystemBackend (FilesystemBackend),
)
import Test.QuickCheck.Classes (lawsCheck, 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
@@ -157,11 +155,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
@@ -180,10 +178,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
@@ -204,11 +202,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
@@ -227,7 +225,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
@@ -312,14 +310,21 @@ storageSpec makeBackend = do
forAll genStorageIndex (mutableWriteAndEnumerateShares makeBackend)
it "rejects an update with the wrong write enabler" $
- property $ \storageIndex shareNum secret wrongSecret shareData offset ->
- secret /= wrongSecret ==> monadicIO $
- run $
+ 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
- void $ readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (writev (ShareNumber shareNum) offset shareData)
- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret wrongSecret) (writev (ShareNumber shareNum) offset shareData)
- `shouldThrow` (== IncorrectWriteEnabler)
+ first <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (writev shareNum offset shareData)
+ success first `shouldBe` True
+ second <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret wrongSecret) (writev shareNum offset junkData)
+ success second `shouldBe` False
+ third <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (readv offset (fromIntegral $ B.length shareData))
+ readData third `shouldBe` Map.singleton shareNum [shareData]
spec :: Spec
spec = do