Memory backend passes the external test suite

src/TahoeLAFS/Storage/Backend/Memory.hs

 {-# LANGUAGE FlexibleInstances #-}
 
-module TahoeLAFS.Storage.Backend.Memory (
-    MemoryBackend (MemoryBackend),
-    memoryBackend,
-    MutableShareSize (..),
-    shareDataSize,
-    toMutableShareSize,
-) where
+module TahoeLAFS.Storage.Backend.Memory where
 
 import Control.Exception (
     throw,
     throwIO,
  )
 import Control.Foldl.ByteString (Word8)
+import Data.Bifunctor (second)
 import Data.ByteArray (constEq)
 import qualified Data.ByteString as B
+import Data.Composition ((.:))
 import Data.IORef (
     IORef,
     atomicModifyIORef',
@@ -24,13 +20,14 @@ import Data.IORef (
  )
 import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe, isNothing)
-import Data.Monoid (Last (Last, getLast))
+import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
+import Data.Monoid (All (All, getAll), First (First, getFirst), Last (Last, getLast))
 import qualified Data.Set as Set
 import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix))
-import TahoeLAFS.Storage.API (
+import Tahoe.Storage.Backend (
     AllocateBuckets (AllocateBuckets),
     AllocationResult (..),
+    Backend (..),
     CBORSet (..),
     Offset,
     QueryRange,
@@ -41,17 +38,17 @@ import TahoeLAFS.Storage.API (
     ShareNumber,
     Size,
     StorageIndex,
+    TestVector (..),
     TestWriteVectors (..),
     UploadSecret (UploadSecret),
     Version (..),
     Version1Parameters (..),
     WriteEnablerSecret (WriteEnablerSecret),
+    WriteImmutableError (..),
+    WriteMutableError (..),
     WriteVector (..),
  )
 import TahoeLAFS.Storage.Backend (
-    Backend (..),
-    WriteImmutableError (..),
-    WriteMutableError (..),
     withUploadSecret,
  )
 import Prelude hiding (
@@ -66,7 +63,10 @@ data Bucket = Bucket
     , bucketShares :: Map.Map ShareNumber ImmutableShare
     }
 
-data SecretProtected a = SecretProtected WriteEnablerSecret a
+data SecretProtected a = SecretProtected WriteEnablerSecret a deriving (Eq)
+
+instance Show a => Show (SecretProtected a) where
+    show (SecretProtected _ a) = "SecretProtected " <> show a
 
 readSecret :: SecretProtected a -> WriteEnablerSecret
 readSecret (SecretProtected s _) = s
@@ -140,10 +140,10 @@ allocate ::
     (MemoryBackend, AllocationResult)
 allocate storageIndex shareNumbers uploadSecret size backend@MemoryBackend{memoryBackendBuckets}
     | maybe size bucketSize existing /= size = throw ShareSizeMismatch
-    | size > maxSize =
+    | size > maximumShareSize =
         throw
             MaximumShareSizeExceeded
-                { maximumShareSizeExceededLimit = maxSize
+                { maximumShareSizeExceededLimit = maximumShareSize
                 , maximumShareSizeExceededGiven = size
                 }
     | otherwise =
@@ -154,8 +154,6 @@ allocate storageIndex shareNumbers uploadSecret size backend@MemoryBackend{memor
     existing = Map.lookup storageIndex memoryBackendBuckets
     updated = Map.insertWith mergeBuckets storageIndex newBucket memoryBackendBuckets
 
-    maxSize = maximumImmutableShareSize . makeVersionParams $ 0
-
     alreadyHave = maybe [] (Map.keys . bucketShares) existing
     allocated = filter (`notElem` alreadyHave) shareNumbers
     result = AllocationResult alreadyHave allocated
@@ -215,10 +213,13 @@ writeImm storageIndex shareNum (UploadSecret uploadSecret) newData b@MemoryBacke
 instance Show MemoryBackend where
     show _ = "<MemoryBackend>"
 
+maximumShareSize :: Integral i => i
+maximumShareSize = fromIntegral (maxBound :: Int)
+
 makeVersionParams totalSize =
     Version1Parameters
-        { maximumImmutableShareSize = 1024 * 1024 * 64
-        , maximumMutableShareSize = 1024 * 1024 * 64
+        { maximumImmutableShareSize = maximumShareSize
+        , maximumMutableShareSize = maximumShareSize
         , availableSpace = (1024 * 1024 * 1024) - totalSize
         }
 
@@ -241,17 +242,12 @@ instance Backend (IORef MemoryBackend) where
             $ sharemap
 
     readvAndTestvAndWritev :: IORef MemoryBackend -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadTestWriteResult
-    readvAndTestvAndWritev
-        backend
-        storageIndex
-        secret
-        (ReadTestWriteVectors testWritev readv) = do
-            -- TODO implement testv parts.
-
+    readvAndTestvAndWritev backend storageIndex secret (ReadTestWriteVectors testWritev readv) = do
         (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 ->
@@ -269,20 +265,26 @@ instance Backend (IORef MemoryBackend) where
             SecretMismatch ->
                 throwIO IncorrectWriteEnablerSecret
       where
-            readvToQueryRange :: [ReadVector] -> QueryRange
-            --            readvToQueryRange [] = Nothing
-            readvToQueryRange rv = Just (go rv)
-              where
-                go [] = []
-                go (r : rs) = ByteRangeFromTo off end : go rs
+        checkTestVectors :: MutableShareStorage -> Map.Map ShareNumber TestWriteVectors -> Bool
+        checkTestVectors mutableShares = getAll . Map.foldMapWithKey (foldMap2 $ All .: checkTestVector mutableShares) . Map.map test
+
+        checkTestVector :: MutableShareStorage -> ShareNumber -> TestVector -> Bool
+        checkTestVector mutableShares shareNum TestVector{..} =
+            specimen == actual
           where
-                    off = offset r
-                    end = off + readSize r - 1
+            actual =
+                readMutableShare''
+                    mutableShares
+                    storageIndex
+                    shareNum
+                    ReadVector{offset = testOffset, readSize = fromIntegral $ B.length specimen}
 
-            tryWrite m@MemoryBackend{mutableShares} =
+        tryWrite m@MemoryBackend{mutableShares}
+            | checkTestVectors mutableShares testWritev =
                 case addShares storageIndex secret mutableShares (Map.map write testWritev) of
                     Nothing -> (m, SecretMismatch)
                     Just newShares -> (m{mutableShares = newShares}, TestSuccess)
+            | otherwise = (m, TestFail)
 
     readMutableShare backend storageIndex shareNum queryRange =
         B.concat <$> readMutableShare' backend storageIndex shareNum queryRange
@@ -331,7 +333,7 @@ addShare storageIndex secret shareNum writev =
     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)
+    newShare = SecretProtected secret (Map.singleton shareNum (reverse writev))
 
 addShares :: StorageIndex -> WriteEnablerSecret -> MutableShareStorage -> Map.Map ShareNumber [WriteVector] -> Maybe MutableShareStorage
 addShares storageIndex secret existing updates
@@ -343,6 +345,32 @@ addShares storageIndex secret existing updates
 
     existingSecret = readSecret <$> Map.lookup storageIndex existing
 
+readvToQueryRange :: [ReadVector] -> QueryRange
+readvToQueryRange rv = Just (go rv)
+  where
+    go [] = []
+    go (r : rs) = ByteRangeFromTo off end : go rs
+      where
+        off = offset r
+        end = off + readSize r - 1
+
+queryRangeToReadVector :: Size -> QueryRange -> [ReadVector]
+queryRangeToReadVector shareSize Nothing = [ReadVector 0 shareSize]
+queryRangeToReadVector shareSize (Just ranges) = toReadVector <$> ranges
+  where
+    toReadVector (ByteRangeFrom start) = ReadVector offset size
+      where
+        offset = max 0 start
+        size = shareSize - offset
+    toReadVector (ByteRangeFromTo start end) = ReadVector offset size
+      where
+        offset = min shareSize (max 0 start)
+        size = min (shareSize - offset) (end - start + 1)
+    toReadVector (ByteRangeSuffix len) = ReadVector offset size
+      where
+        offset = max 0 $ shareSize - len
+        size = min (shareSize - offset) len
+
 memoryBackend :: IO (IORef MemoryBackend)
 memoryBackend = do
     newIORef $ MemoryBackend mempty mempty
@@ -350,31 +378,14 @@ memoryBackend = do
 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)
+    let shareSize = maybe 0 shareDataSize (getShareData storage storageIndex shareNum)
+    pure $ readMutableShare'' storage storageIndex shareNum <$> (queryRangeToReadVector shareSize queryRange)
 
-    queryRangeToReadVector :: MutableShareStorage -> QueryRange -> [ReadVector]
-    queryRangeToReadVector storage Nothing = [ReadVector 0 size]
-      where
-        size = maybe 0 shareDataSize (getShareData storage)
-    queryRangeToReadVector storage (Just ranges) = toReadVector <$> ranges
+readMutableShare'' :: MutableShareStorage -> StorageIndex -> ShareNumber -> ReadVector -> ShareData
+readMutableShare'' storage storageIndex shareNum rv =
+    maybe "" (readOneVector rv) theShareData
   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)
+    theShareData = getShareData storage storageIndex shareNum
 
     readOneVector :: ReadVector -> [WriteVector] -> ShareData
     readOneVector ReadVector{offset, readSize} wv =
@@ -385,15 +396,18 @@ readMutableShare' backend storageIndex shareNum queryRange = do
         extractBytes :: Integer -> Word8
         extractBytes p = fromMaybe 0 (go wv)
           where
-            -- New writes are added to the end of the list so give the Last
+            -- New writes are added to the front of the list so give the First
             -- write precedence over others.
-            go = getLast . foldMap (Last . byteFromShare p)
+            go = getFirst . foldMap (First . 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
 
+getShareData storage storageIndex shareNum =
+    Map.lookup storageIndex storage >>= Map.lookup shareNum . readProtected
+
 -- | Internal type tracking the result of an attempted mutable write.
 data WriteResult
     = -- | The test condition succeeded and the write was performed.
@@ -402,3 +416,6 @@ data WriteResult
       TestFail
     | -- | The supplied secret was incorrect and the write was not performed.
       SecretMismatch
+
+foldMap2 :: (Foldable o, Monoid c) => (a -> b -> c) -> (a -> o b -> c)
+foldMap2 f a = foldMap (f a)

tahoe-great-black-swamp.cabal

@@ -112,6 +112,7 @@ library
     , base64-bytestring              >=1.0.0.3  && <1.3
     , cborg                          >=0.2.4    && <0.3
     , cborg-json                     >=0.2.2    && <0.3
+    , composition                    >=1.0      && <1.1
     , connection                     >=0.3.1    && <0.4
     , cryptonite                     >=0.27     && <0.31
     , data-default-class             >=0.1      && <0.2

test/SemanticSpec.hs

-{-# LANGUAGE FlexibleInstances #-}
-
 module SemanticSpec (
     spec,
 ) where
 
-import Prelude hiding (
-    lookup,
-    toInteger,
- )
-
 import Control.Monad (
     void,
     when,
  )
-
 import Data.Bits (
     xor,
  )
-
+import qualified Data.ByteString as B
+import Data.Data (Proxy (Proxy))
+import Data.IORef (IORef)
+import Data.Interval (Boundary (Closed, Open), Extended (Finite), Interval, interval, lowerBound, upperBound)
+import qualified Data.IntervalSet as IS
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 import GHC.Word (
     Word8,
  )
-
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-
+import Network.HTTP.Types (ByteRange (ByteRangeSuffix))
 import System.Directory (
     removeDirectoryRecursive,
  )
-
 import System.IO.Temp (
     createTempDirectory,
     getCanonicalTemporaryDirectory,
  )
-
-import Test.Hspec (
-    Spec,
-    context,
-    describe,
-    it,
-    shouldBe,
-    shouldThrow,
- )
-import Test.QuickCheck (
-    Gen,
-    NonEmptyList (getNonEmpty),
-    NonNegative (NonNegative),
-    Positive (..),
-    Property,
-    chooseInteger,
-    counterexample,
-    forAll,
-    ioProperty,
-    oneof,
-    property,
-    vector,
-    (==>),
- )
-
-import Test.QuickCheck.Monadic (
-    monadicIO,
-    run,
+import Tahoe.Storage.Testing.Spec (
+    ShareNumbers (..),
+    genStorageIndex,
+    makeStorageSpec,
  )
-
-import qualified Data.ByteString as B
-
 import TahoeLAFS.Storage.API (
     AllocateBuckets (AllocateBuckets),
     AllocationResult (AllocationResult),
@@ -88,7 +55,6 @@ import TahoeLAFS.Storage.API (
     toInteger,
     writev,
  )
-
 import TahoeLAFS.Storage.Backend (
     Backend (
         abortImmutableUpload,
@@ -102,29 +68,52 @@ import TahoeLAFS.Storage.Backend (
     WriteImmutableError (..),
     writeMutableShare,
  )
-
-import Data.IORef (IORef)
-
+import TahoeLAFS.Storage.Backend.Filesystem (
+    FilesystemBackend (FilesystemBackend),
+ )
 import TahoeLAFS.Storage.Backend.Memory (
     MemoryBackend (..),
-    MutableShareSize (MutableShareSize),
+    MutableShareSize (..),
+    SecretProtected (..),
+    addShares,
     memoryBackend,
+    queryRangeToReadVector,
+    readvToQueryRange,
     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 Tahoe.Storage.Testing.Spec (
-    ShareNumbers (..),
-    genStorageIndex,
-    makeStorageSpec,
+import Test.Hspec (
+    Spec,
+    context,
+    describe,
+    it,
+    shouldBe,
+    shouldThrow,
  )
-import TahoeLAFS.Storage.Backend.Filesystem (
-    FilesystemBackend (FilesystemBackend),
+import Test.QuickCheck (
+    Gen,
+    NonEmptyList (getNonEmpty),
+    NonNegative (NonNegative),
+    Positive (..),
+    Property,
+    chooseInteger,
+    counterexample,
+    forAll,
+    ioProperty,
+    oneof,
+    property,
+    vector,
+    (==>),
  )
 import Test.QuickCheck.Classes (Laws (..), semigroupMonoidLaws)
+import Test.QuickCheck.Monadic (
+    monadicIO,
+    run,
+ )
+import Prelude hiding (
+    lookup,
+    toInteger,
+ )
 
 -- | Create a Spec that checks the given Laws.
 lawsCheck :: Laws -> Spec
@@ -137,7 +126,7 @@ lawsCheck Laws{lawsTypeclass, lawsProperties} =
 spec :: Spec
 spec = do
     context "utilities" $ do
-        describe "MutableShareStorage" $ do
+        describe "toMutableShareSize" $ do
             it "finds the larger size for some cases" $ do
                 toMutableShareSize (WriteVector 0 "x") <> toMutableShareSize (WriteVector 1 "x")
                     `shouldBe` MutableShareSize 0 2
@@ -151,6 +140,26 @@ spec = do
                 toMutableShareSize (WriteVector 0 "Hello") <> toMutableShareSize (WriteVector 3 "world")
                     `shouldBe` MutableShareSize 0 8
 
+        describe "addShares" $ do
+            it "prepends the new write to the share storage" $ do
+                let si = "storageindex"
+                    enabler = WriteEnablerSecret "enabler"
+                    addShares' = addShares si enabler
+                    shareNum = ShareNumber 0
+                    Just a = addShares' mempty (Map.fromList [(shareNum, [WriteVector 1 "first"])])
+                    Just b = addShares' a (Map.fromList [(shareNum, [WriteVector 2 "second"])])
+
+                b `shouldBe` Map.fromList [(si, SecretProtected enabler (Map.fromList [(shareNum, [WriteVector 2 "second", WriteVector 1 "first"])]))]
+
+            it "puts later elements in a single WriteVector list earlier in the MutableShareStorage list" $ do
+                let si = "storageindex"
+                    enabler = WriteEnablerSecret "enabler"
+                    addShares' = addShares si enabler
+                    shareNum = ShareNumber 0
+                    Just a = addShares' mempty (Map.fromList [(shareNum, [WriteVector 1 "first", WriteVector 2 "second"])])
+
+                a `shouldBe` Map.fromList [(si, SecretProtected enabler (Map.fromList [(shareNum, [WriteVector 2 "second", WriteVector 1 "first"])]))]
+
         describe "shareDataSize" $ do
             it "converts list of WriteVector to a size" $ do
                 shareDataSize [WriteVector 2 "foo", WriteVector 10 "quux"]
@@ -172,6 +181,14 @@ spec = do
             . semigroupMonoidLaws
             $ (Proxy :: Proxy ReadTestWriteVectors)
 
+        describe "ReadVector" $ do
+            it "it round-trips through queryRangeToReadVector / readvToQueryRange" $
+                property $ \rvs ->
+                    (queryRangeToReadVector 1234 . readvToQueryRange) rvs `shouldBe` rvs
+
+            it "imposes a lower bound of zero on offset" $ do
+                queryRangeToReadVector 1 (Just [ByteRangeSuffix 2]) `shouldBe` [ReadVector 0 1]
+
     context "memory" $ makeStorageSpec memoryBackend cleanupMemory
     context "filesystem" $ makeStorageSpec filesystemBackend cleanupFilesystem