tahoe-great-black-swamp 0.3.1.0 → 0.4.0.1

raw patch · 17 files changed

+1065/−646 lines, 17 filesdep +data-intervaldep +extradep +quickcheck-classes

Dependencies added: data-interval, extra, quickcheck-classes

Files

• ChangeLog.md +16/−0
• src/TahoeLAFS/Internal/Client.hs +7/−5
• src/TahoeLAFS/Storage/API.hs +71/−63
• src/TahoeLAFS/Storage/APIDocs.hs +10/−14
• src/TahoeLAFS/Storage/Backend.hs +42/−20
• src/TahoeLAFS/Storage/Backend/Filesystem.hs +160/−118
• src/TahoeLAFS/Storage/Backend/Memory.hs +318/−123
• src/TahoeLAFS/Storage/Backend/Null.hs +2/−17
• src/TahoeLAFS/Storage/Client.hs +2/−0
• src/TahoeLAFS/Storage/Server.hs +42/−49
• tahoe-great-black-swamp.cabal +5/−2
• test/CBORSpec.hs +3/−1
• test/HTTPSpec.hs +17/−43
• test/Lib.hs +48/−5
• test/Main.hs +2/−2
• test/MiscSpec.hs +14/−15
• test/SemanticSpec.hs +306/−169

@@ -1,5 +1,21 @@ # Changelog for tahoe-great-black-swamp +## 0.4.0.1++* Package metadata improvements.++## 0.4.0.0++* ``TahoeLAFS.Storage.Backend.Backend`` has received a number of incompatible+   changes to bring it up-to-date with the latest upstream Great Black Swamp+   specification.++* The memory and filesystem backends have been updated to reflect these Great+  Black Swamp specification changes.++* The memory and filesystem backends now make at least a token effort to+  implement the mutable portions of the API.+ ## 0.3.1.0  * ``TahoeLAFS.Storage.Client.runGBS`` is a new high-level API for performing an interaction with a GBS server.

@@ -155,17 +155,19 @@      addHeader :: Header -> [Header] -> [Header]     addHeader (name, value) [] = [(name, value)]-    addHeader (name, value) (o@(name', value') : xs)+    addHeader (name, value) (o@(name', _) : xs)         | name == name' = o : xs         | otherwise = o : addHeader (name, value) xs  addAuthorizationPrint :: T.Text -> Request -> IO Request addAuthorizationPrint swissnum req = do-    print "Before"+    p "Before"     print req-    print "--------"+    p "--------"     r <- addAuthorization swissnum req-    print "After"+    p "After"     print r-    print "--------"+    p "--------"     pure r+  where+    p = print :: String -> IO ()

@@ -28,16 +28,17 @@     WriteVector (..),     ReadTestWriteVectors (..),     ReadTestWriteResult (..),-    ReadVectors,-    ReadVector,+    ReadVector (..),     QueryRange,-    TestVector (TestVector),+    TestVector (..),     ReadResult,-    CorruptionDetails (CorruptionDetails),-    SlotSecrets (..),+    CorruptionDetails (..),     TestOperator (..),     StorageAPI,     LeaseSecret (..),+    UploadSecret (..),+    WriteEnablerSecret (..),+    isUploadSecret,     api,     renewSecretLength,     writeEnablerSecretLength,@@ -45,6 +46,9 @@     leaseCancelSecretLength,     CBOR,     CBORSet (..),+    readv,+    writev,+    testv, ) where  import Codec.CBOR.Encoding (encodeBytes)@@ -69,9 +73,11 @@     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,  )@@ -97,9 +103,9 @@     Post,     PostCreated,     Proxy (Proxy),-    QueryParams,+    Put,     ReqBody,-    StdMethod (PUT),+    StdMethod (PATCH),     Verb,     (:<|>),     (:>),@@ -118,8 +124,6 @@     toInteger,  ) -type PutCreated = Verb 'PUT 201- tahoeJSONOptions :: Options tahoeJSONOptions =     defaultOptions@@ -143,8 +147,6 @@ type QueryRange = Maybe ByteRanges  -- TODO These should probably all be byte strings instead.-type RenewSecret = String-type CancelSecret = String type StorageIndex = String type ShareData = B.ByteString @@ -351,11 +353,8 @@ instance FromJSON Version where     parseJSON = genericParseJSON tahoeJSONOptions --- XXX Remove the secret fields from this record. data AllocateBuckets = AllocateBuckets-    { renewSecret :: RenewSecret-    , cancelSecret :: CancelSecret-    , shareNumbers :: [ShareNumber]+    { shareNumbers :: [ShareNumber]     , allocatedSize :: Size     }     deriving (Show, Eq, Generic)@@ -413,8 +412,18 @@     toUrlPiece _ = error "Cannot serialize ByteRanges to URL piece"     toQueryParam _ = error "Cannot serialize ByteRanges to query params" -data LeaseSecret = Renew B.ByteString | Cancel B.ByteString | Upload B.ByteString | Write B.ByteString+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+isUploadSecret (Upload _) = True+isUploadSecret _ = False+ instance FromHttpApiData LeaseSecret where     parseHeader bs =         do@@ -422,8 +431,8 @@             case key of                 "lease-renew-secret" -> bimap T.pack Renew $ Base64.decode val                 "lease-cancel-secret" -> bimap T.pack Cancel $ Base64.decode val-                "upload-secret" -> bimap T.pack Upload $ Base64.decode val-                "write-enabler" -> bimap T.pack Write $ Base64.decode val+                "upload-secret" -> bimap T.pack (Upload . UploadSecret) $ Base64.decode val+                "write-enabler" -> bimap T.pack (Write . WriteEnablerSecret) $ Base64.decode val                 _ -> Left $ T.concat ["Cannot interpret secret: ", T.pack . show $ key]      parseUrlPiece _ = Left "Cannot parse LeaseSecret from URL piece"@@ -440,8 +449,8 @@ instance ToHttpApiData LeaseSecret where     toHeader (Renew bs) = "lease-renew-secret " <> Base64.encode bs     toHeader (Cancel bs) = "lease-cancel-secret " <> Base64.encode bs-    toHeader (Upload bs) = "lease-cancel-secret " <> Base64.encode bs-    toHeader (Write bs) = "write-enabler " <> Base64.encode bs+    toHeader (Upload (UploadSecret bs)) = "lease-cancel-secret " <> Base64.encode bs+    toHeader (Write (WriteEnablerSecret bs)) = "write-enabler " <> Base64.encode bs      toUrlPiece _ = error "Cannot serialize LeaseSecret to URL piece"     toQueryParam _ = error "Cannot serialize LeaseSecret to query params"@@ -451,27 +460,34 @@     toUrlPiece _ = error "Cannot serialize [LeaseSecret] to URL piece"     toQueryParam _ = error "Cannot serialize [LeaseSecret] to query params" +-- Request authorization information+type Authz = Header "X-Tahoe-Authorization" [LeaseSecret]+ -- GET .../version -- Retrieve information about the server version and behavior type GetVersion = "version" :> Get '[CBOR, JSON] Version  -- PUT .../lease/:storage_index-type RenewLease = "lease" :> Capture "storage_index" StorageIndex :> Header "X-Tahoe-Authorization" [LeaseSecret] :> Get '[CBOR, JSON] ()+type RenewLease = "lease" :> Capture "storage_index" StorageIndex :> Authz :> Get '[CBOR, JSON] ()  -- POST .../immutable/:storage_index -- Initialize a new immutable storage index-type CreateImmutableStorageIndex = "immutable" :> Capture "storage_index" StorageIndex :> ReqBody '[CBOR, JSON] AllocateBuckets :> PostCreated '[CBOR, JSON] AllocationResult+type CreateImmutableStorageIndex = "immutable" :> Capture "storage_index" StorageIndex :> Authz :> ReqBody '[CBOR, JSON] AllocateBuckets :> PostCreated '[CBOR, JSON] AllocationResult  ----- PUT .../immutable/:storage_index/:share_number+-- PATCH .../immutable/:storage_index/:share_number -- Write data for an immutable share to an allocated storage index -- -- Note this accepts JSON to facilitate code generation by servant-py.  This -- is total nonsense and supplying JSON here will almost certainly break. -- At some point hopefully we'll fix servant-py to not need this and then -- fix the signature here.-type WriteImmutableShareData = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> ReqBody '[OctetStream, JSON] ShareData :> Header "Content-Range" ByteRanges :> PutCreated '[CBOR, JSON] ()+type WriteImmutableShareData = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> Authz :> ReqBody '[OctetStream, JSON] ShareData :> Header "Content-Range" ByteRanges :> Verb 'PATCH 201 '[CBOR, JSON] () +-- PUT .../immutable/:storage_index/:share_number/unstableSort+-- Cancel an incomplete immutable share upload.+type AbortImmutableUpload = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> "abort" :> Authz :> Put '[JSON] ()+ -- POST .../immutable/:storage_index/:share_number/corrupt -- Advise the server of a corrupt share data type AdviseCorrupt = Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> "corrupt" :> ReqBody '[CBOR, JSON] CorruptionDetails :> Post '[CBOR, JSON] ()@@ -485,9 +501,9 @@ -- Read from an immutable storage index, possibly from multiple shares, possibly limited to certain ranges type ReadImmutableShareData = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> Header "Content-Range" ByteRanges :> Get '[OctetStream, JSON] ShareData --- POST /v1/mutable/:storage_index/read-test-write+-- POST .../v1/mutable/:storage_index/read-test-write -- General purpose read-test-and-write operation.-type ReadTestWrite = "mutable" :> Capture "storage_index" StorageIndex :> "read-test-write" :> ReqBody '[CBOR, JSON] ReadTestWriteVectors :> Post '[CBOR, JSON] ReadTestWriteResult+type ReadTestWrite = "mutable" :> Capture "storage_index" StorageIndex :> "read-test-write" :> Authz :> ReqBody '[CBOR, JSON] ReadTestWriteVectors :> Post '[CBOR, JSON] ReadTestWriteResult  -- GET /v1/mutable/:storage_index/:share_number -- Read from a mutable storage index@@ -501,6 +517,7 @@                 -- Immutables                 :<|> CreateImmutableStorageIndex                 :<|> WriteImmutableShareData+                :<|> AbortImmutableUpload                 :<|> ReadImmutableShareData                 :<|> "immutable" :> GetShareNumbers                 :<|> "immutable" :> AdviseCorrupt@@ -513,18 +530,6 @@  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@@ -541,8 +546,7 @@     parseJSON = genericParseJSON tahoeJSONOptions  data ReadTestWriteVectors = ReadTestWriteVectors-    { secrets :: SlotSecrets-    , testWriteVectors :: Map ShareNumber TestWriteVectors+    { testWriteVectors :: Map ShareNumber TestWriteVectors     , readVector :: [ReadVector]     }     deriving (Show, Eq, Generic)@@ -574,12 +578,39 @@ data TestWriteVectors = TestWriteVectors     { test :: [TestVector]     , write :: [WriteVector]+    , newLength :: Maybe Integer     }     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@@ -610,30 +641,7 @@     }     deriving (Show, Eq, Generic, ToJSON, FromJSON) --- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise WriteVector---- XXX These fields moved to an HTTP Header, this type is probably not useful--- anymore?-data SlotSecrets = SlotSecrets-    { writeEnabler :: WriteEnablerSecret-    , leaseRenew :: LeaseRenewSecret-    , leaseCancel :: LeaseCancelSecret-    }-    deriving (Show, Eq, Generic)---- XXX This derived instance is surely not compatible with Tahoe-LAFS.-instance Serialise SlotSecrets--instance ToJSON SlotSecrets where-    toJSON = genericToJSON tahoeJSONOptions--instance FromJSON SlotSecrets where-    parseJSON = genericParseJSON tahoeJSONOptions--type WriteEnablerSecret = String-type LeaseRenewSecret = String-type LeaseCancelSecret = String  api :: Proxy StorageAPI api = Proxy

@@ -18,15 +18,14 @@  )  import Servant (-    Capture (..),-    Optional,+    Capture,     QueryParams,  )  import Servant.Docs (     DocCapture (DocCapture),     DocQueryParam (DocQueryParam),-    ParamKind (List, Normal),+    ParamKind (List),     ToCapture (toCapture),     ToParam (toParam),     ToSample (toSamples),@@ -37,16 +36,13 @@ import TahoeLAFS.Storage.API (     AllocateBuckets (AllocateBuckets),     AllocationResult (AllocationResult),-    ApplicationVersion,     CorruptionDetails (CorruptionDetails),-    Offset,     ReadResult,     ReadTestWriteResult (ReadTestWriteResult),     ReadTestWriteVectors (ReadTestWriteVectors),     ReadVector,     ShareData,     ShareNumber (ShareNumber),-    SlotSecrets (SlotSecrets),     StorageIndex,     TestOperator (Eq),     TestVector (TestVector),@@ -54,10 +50,6 @@     Version (Version),     Version1Parameters (Version1Parameters),     WriteVector (WriteVector),-    leaseCancelSecretLength,-    leaseRenewSecretLength,-    renewSecretLength,-    writeEnablerSecretLength,  )  instance ToCapture (Capture "storage_index" StorageIndex) where@@ -87,8 +79,6 @@     toSamples _ =         singleSample             ( AllocateBuckets-                (example renewSecretLength "a")-                (example renewSecretLength "b")                 [ShareNumber 1, ShareNumber 3]                 1024             )@@ -114,7 +104,6 @@     toSamples _ =         singleSample $             ReadTestWriteVectors-                (SlotSecrets (example writeEnablerSecretLength "c") (example leaseRenewSecretLength "d") (example leaseCancelSecretLength "e"))                 sampleTestWriteVectors                 sampleReadVector @@ -126,7 +115,14 @@ sampleTestWriteVectors :: Map ShareNumber TestWriteVectors sampleTestWriteVectors =     fromList-        [(ShareNumber 0, TestWriteVectors [TestVector 32 33 Eq "x"] [WriteVector 32 "y"])]+        [+            ( ShareNumber 0+            , TestWriteVectors+                [TestVector 32 33 Eq "x"]+                [WriteVector 32 "y"]+                (Just 100)+            )+        ]  sampleReadVector :: [ReadVector] sampleReadVector = mempty

@@ -2,48 +2,53 @@  module TahoeLAFS.Storage.Backend (     Backend (..),-    ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+    WriteImmutableError (..),     writeMutableShare,+    withUploadSecret, ) where  import Control.Exception (     Exception,     throw,+    throwIO,  )  import Data.Map.Strict (     fromList,  ) -import qualified Data.Set as Set import Network.HTTP.Types (     ByteRanges,  ) import TahoeLAFS.Storage.API (     AllocateBuckets,     AllocationResult,-    CBOR,     CBORSet (..),     CorruptionDetails,-    LeaseSecret,-    Offset,+    LeaseSecret (..),     QueryRange,-    ReadResult,     ReadTestWriteResult (..),     ReadTestWriteVectors (..),     ShareData,     ShareNumber,-    Size,-    SlotSecrets,     StorageIndex,     TestWriteVectors (..),+    UploadSecret (..),     Version,+    WriteEnablerSecret,     WriteVector (..),+    isUploadSecret,  ) -data ImmutableShareAlreadyWritten = ImmutableShareAlreadyWritten-    deriving (Show)-instance Exception ImmutableShareAlreadyWritten+data WriteImmutableError+    = MissingUploadSecret+    | ShareSizeMismatch+    | ImmutableShareAlreadyWritten+    | ShareNotAllocated+    | IncorrectUploadSecret+    | IncorrectWriteEnablerSecret+    deriving (Ord, Eq, Show)+instance Exception WriteImmutableError  class Backend b where     version :: b -> IO Version@@ -52,16 +57,27 @@     -- given storage index.     renewLease :: b -> StorageIndex -> [LeaseSecret] -> IO () -    createImmutableStorageIndex :: b -> StorageIndex -> AllocateBuckets -> IO AllocationResult+    createImmutableStorageIndex :: b -> StorageIndex -> Maybe [LeaseSecret] -> AllocateBuckets -> IO AllocationResult      -- May throw ImmutableShareAlreadyWritten-    writeImmutableShare :: b -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()+    writeImmutableShare :: b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> ShareData -> Maybe ByteRanges -> IO ()+    abortImmutableUpload :: b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> IO ()     adviseCorruptImmutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()     getImmutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)     readImmutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData -    createMutableStorageIndex :: b -> StorageIndex -> AllocateBuckets -> IO AllocationResult-    readvAndTestvAndWritev :: b -> StorageIndex -> ReadTestWriteVectors -> IO ReadTestWriteResult+    -- | Read some ranges of all shares held and/or, if test conditions are+    -- met, overwrite some ranges of some shares.+    readvAndTestvAndWritev ::+        b ->+        -- | The storage index at which to operate.+        StorageIndex ->+        -- | A shared secret which the backend can use to authorize the writes.+        WriteEnablerSecret ->+        -- | The reads, tests, and writes to perform.+        ReadTestWriteVectors ->+        IO ReadTestWriteResult+     readMutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData     getMutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)     adviseCorruptMutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()@@ -69,13 +85,13 @@ writeMutableShare ::     Backend b =>     b ->-    SlotSecrets ->     StorageIndex ->     ShareNumber ->+    WriteEnablerSecret ->     ShareData ->     Maybe ByteRanges ->     IO ()-writeMutableShare b secrets storageIndex shareNumber shareData Nothing = do+writeMutableShare b storageIndex shareNumber writeEnablerSecret shareData Nothing = do     let testWriteVectors =             fromList                 [@@ -88,16 +104,16 @@                                 , shareData = shareData                                 }                             ]+                        , newLength = Nothing -- XXX expose this?                         }                     )                 ]     let vectors =             ReadTestWriteVectors-                { secrets = secrets-                , testWriteVectors = testWriteVectors+                { testWriteVectors = testWriteVectors                 , readVector = mempty                 }-    result <- readvAndTestvAndWritev b storageIndex vectors+    result <- readvAndTestvAndWritev b storageIndex writeEnablerSecret vectors     if success result         then return ()         else throw WriteRefused@@ -105,3 +121,9 @@  data WriteRefused = WriteRefused deriving (Show, Eq) instance Exception WriteRefused++withUploadSecret :: Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a+withUploadSecret ss f =+    case filter isUploadSecret <$> ss of+        Just [Upload s] -> f s+        _ -> throwIO MissingUploadSecret

@@ -9,82 +9,79 @@     incomingPathOf, ) where -import Prelude hiding (-    readFile,-    writeFile,+import Control.Exception (+    throwIO,+    try,+    tryJust,  )-+import Control.Monad (unless, when)+import Control.Monad.Extra (concatMapM)+import Data.Bifunctor (Bifunctor (bimap, second))+import Data.ByteArray (constEq) import Data.ByteString (     hPut,     readFile,     writeFile,  )-import qualified Data.Set as Set-import Network.HTTP.Types (-    ByteRanges,- )--import Control.Exception (-    throwIO,-    tryJust,- )-+import qualified Data.ByteString as B+import qualified Data.List+import qualified Data.Map.Strict as Map import Data.Maybe (     mapMaybe,  )--import Data.Map.Strict (-    fromList,-    toList,+import qualified Data.Set as Set+import Data.Tuple.Extra ((&&&))+import System.Directory (+    createDirectoryIfMissing,+    doesPathExist,+    listDirectory,+    removeFile,+    renameFile,  )-+import System.FilePath (+    takeDirectory,+    (</>),+ ) import System.IO (     Handle,-    IOMode (ReadWriteMode),+    IOMode (ReadMode, ReadWriteMode),     SeekMode (AbsoluteSeek),     hSeek,     withBinaryFile,  )-import System.IO.Error (-    isDoesNotExistError,- )--import System.FilePath (-    takeDirectory,-    (</>),- )--import System.Directory (-    createDirectoryIfMissing,-    doesPathExist,-    listDirectory,-    renameFile,- )-+import System.IO.Error (isDoesNotExistError) import TahoeLAFS.Storage.API (     AllocateBuckets (..),     AllocationResult (..),     CBORSet (..),     Offset,-    QueryRange,+    ReadResult,     ReadTestWriteResult (ReadTestWriteResult, readData, success),     ReadTestWriteVectors (ReadTestWriteVectors),+    ReadVector (..),     ShareData,     ShareNumber,+    Size,     StorageIndex,-    TestWriteVectors (write),+    TestVector (..),+    TestWriteVectors (..),+    UploadSecret (..),     Version (..),     Version1Parameters (..),+    WriteEnablerSecret (..),     WriteVector (WriteVector),     shareNumber,  )- import qualified TahoeLAFS.Storage.API as Storage- import TahoeLAFS.Storage.Backend (     Backend (..),-    ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+    WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret),+    withUploadSecret,  )+import Prelude hiding (+    readFile,+    writeFile,+ )  newtype FilesystemBackend = FilesystemBackend FilePath     deriving (Show)@@ -107,7 +104,7 @@ --  base-32 chars).  instance Backend FilesystemBackend where-    version (FilesystemBackend path) = do+    version (FilesystemBackend _path) = do         -- Hard-code some arbitrary amount of space.  There is a statvfs         -- package that can inspect the system and tell us a more correct         -- answer but it is somewhat unmaintained and fails to build in some@@ -126,35 +123,42 @@                         }                 } -    createImmutableStorageIndex :: FilesystemBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult-    createImmutableStorageIndex backend storageIndex params = do-        let exists = haveShare backend storageIndex-        (alreadyHave, allocated) <- partitionM exists (shareNumbers params)-        allocatev backend storageIndex allocated-        return-            AllocationResult-                { alreadyHave = alreadyHave-                , allocated = allocated-                }+    createImmutableStorageIndex backend storageIndex secrets params =+        withUploadSecret secrets $ \uploadSecret -> do+            let exists = haveShare backend storageIndex+            (alreadyHave, allocated) <- partitionM exists (shareNumbers params)+            mapM_ (flip (allocate backend storageIndex) uploadSecret) allocated+            return+                AllocationResult+                    { alreadyHave = alreadyHave+                    , allocated = allocated+                    }      -- TODO Handle ranges.     -- TODO Make sure the share storage was allocated.     -- TODO Don't allow target of rename to exist.     -- TODO Concurrency-    writeImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()-    writeImmutableShare (FilesystemBackend root) storageIndex shareNumber' shareData Nothing = do-        alreadyHave <- haveShare (FilesystemBackend root) storageIndex shareNumber'-        if alreadyHave-            then throwIO ImmutableShareAlreadyWritten-            else do-                let finalSharePath = pathOfShare root storageIndex shareNumber'-                let incomingSharePath = incomingPathOf root storageIndex shareNumber'-                writeFile incomingSharePath shareData-                let createParents = True-                createDirectoryIfMissing createParents $ takeDirectory finalSharePath-                renameFile incomingSharePath finalSharePath+    writeImmutableShare (FilesystemBackend root) storageIndex shareNumber' secrets shareData Nothing =+        withUploadSecret secrets $ \uploadSecret -> do+            alreadyHave <- haveShare (FilesystemBackend root) storageIndex shareNumber'+            if alreadyHave+                then throwIO ImmutableShareAlreadyWritten+                else do+                    let finalSharePath = pathOfShare root storageIndex shareNumber'+                    let incomingSharePath = incomingPathOf root storageIndex shareNumber'+                    checkUploadSecret incomingSharePath uploadSecret+                    writeFile incomingSharePath shareData+                    let createParents = True+                    createDirectoryIfMissing createParents $ takeDirectory finalSharePath+                    removeFile (secretPath incomingSharePath)+                    renameFile incomingSharePath finalSharePath -    getImmutableShareNumbers :: FilesystemBackend -> StorageIndex -> IO (CBORSet ShareNumber)+    abortImmutableUpload (FilesystemBackend root) storageIndex shareNumber' secrets =+        withUploadSecret secrets $ \uploadSecret -> do+            let incomingSharePath = incomingPathOf root storageIndex shareNumber'+            checkUploadSecret incomingSharePath uploadSecret+            removeFile incomingSharePath+     getImmutableShareNumbers (FilesystemBackend root) storageIndex = do         let storageIndexPath = pathOfStorageIndex root storageIndex         storageIndexChildren <-@@ -167,58 +171,77 @@      -- TODO Handle ranges.     -- TODO Make sure the share storage was allocated.-    readImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO Storage.ShareData     readImmutableShare (FilesystemBackend root) storageIndex shareNum _qr =         let _storageIndexPath = pathOfStorageIndex root storageIndex             readShare = readFile . pathOfShare root storageIndex          in readShare shareNum -    createMutableStorageIndex = createImmutableStorageIndex-     getMutableShareNumbers = getImmutableShareNumbers      readvAndTestvAndWritev-        (FilesystemBackend root)+        backend@(FilesystemBackend root)         storageIndex-        (ReadTestWriteVectors _secrets testWritev _readv) = do-            -- TODO implement readv and testv parts.  implement secrets part.-            mapM_ (applyWriteVectors root storageIndex) $ toList testWritev+        secret+        (ReadTestWriteVectors testWritev readv) = do+            checkWriteEnabler secret (pathOfStorageIndex root storageIndex)+            readData <- runAllReads+            success <- fmap and . concatMapM (uncurry checkTestVectors . second test) . Map.toList $ testWritev+            when success $ mapM_ applyWriteVectors $ Map.toList testWritev             return                 ReadTestWriteResult-                    { success = True-                    , readData = mempty+                    { success = success+                    , readData = readData                     }           where+            runAllReads :: IO ReadResult+            runAllReads = do+                (CBORSet allShareNumbers) <- getMutableShareNumbers backend storageIndex+                let allShareNumbers' = Set.toList allShareNumbers+                Map.fromList . zip allShareNumbers' <$> mapM readvOneShare allShareNumbers'++            readvOneShare :: ShareNumber -> IO [ShareData]+            readvOneShare shareNum =+                mapM (uncurry (readShare shareNum) . (offset &&& readSize)) readv++            checkTestVectors :: ShareNumber -> [TestVector] -> IO [Bool]+            checkTestVectors = mapM . checkTestVector++            checkTestVector :: ShareNumber -> TestVector -> IO Bool+            checkTestVector shareNum TestVector{..} = (specimen ==) <$> readShare shareNum testOffset testSize++            readShare :: ShareNumber -> Offset -> Size -> IO ShareData+            readShare shareNum offset size = withBinaryFile path ReadMode $ \shareFile -> do+                hSeek shareFile AbsoluteSeek offset+                B.hGetSome shareFile (fromIntegral size)+              where+                path = pathOfShare root storageIndex shareNum+             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 ::     FilesystemBackend -> -- The backend to check@@ -249,41 +272,60 @@ storageStartSegment [_] = storageStartSegment [] storageStartSegment (a : b : _) = [a, b] --- Create a space to write data for an incoming share.+-- Create spaces to write data for several incoming shares. allocate ::     FilesystemBackend ->     StorageIndex ->     ShareNumber ->-    IO ()-allocate backend storageIndex shareNumber' =-    allocatev backend storageIndex [shareNumber']---- Create spaces to write data for several incoming shares.-allocatev ::-    FilesystemBackend ->-    StorageIndex ->-    [ShareNumber] ->+    UploadSecret ->     IO ()-allocatev _backend _storageIndex [] = return ()-allocatev (FilesystemBackend root) storageIndex (shareNumber : rest) =-    let sharePath = incomingPathOf root storageIndex shareNumber+allocate (FilesystemBackend root) storageIndex shareNum (UploadSecret secret) =+    let sharePath = incomingPathOf root storageIndex shareNum         shareDirectory = takeDirectory sharePath         createParents = True      in do             createDirectoryIfMissing createParents shareDirectory+            writeFile (secretPath sharePath) secret             writeFile sharePath ""-            allocatev (FilesystemBackend root) storageIndex rest             return () +{- | Given the path of an immutable share, construct a path to use to hold the+ upload secret for that share.+-}+secretPath :: FilePath -> FilePath+secretPath = (<> ".secret")++{- | Compare the upload secret for an immutable share at a given path to a+ given upload secret and produce unit if and only if they are equal.++ If they are not, throw IncorrectUploadSecret.+-}+checkUploadSecret :: FilePath -> UploadSecret -> IO ()+checkUploadSecret sharePath (UploadSecret uploadSecret) = do+    matches <- constEq uploadSecret <$> readFile (secretPath sharePath)+    unless matches (throwIO IncorrectUploadSecret)++-- | Partition a list based on the result of a monadic predicate. partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM pred' items = do-    (yes, no) <- partitionM' pred' items [] []-    -- re-reverse them to maintain input order-    return (reverse yes, reverse no)+partitionM pred' items = bimap (fst <$>) (fst <$>) . Data.List.partition snd . zip items <$> mapM pred' items++{- | Throw IncorrectUploadSecret if the given secret does not match the+ existing secret for the given storage index path or succeed with () if it+ does.  If there is no secret yet, record the given one and succeed with ().+-}+checkWriteEnabler :: WriteEnablerSecret -> FilePath -> IO ()+checkWriteEnabler (WriteEnablerSecret given) storageIndexPath = do+    x <- try . B.readFile $ path+    case x of+        Left e+            | isDoesNotExistError e -> do+                -- If there is no existing value, this check initializes it to the given+                -- value.+                createDirectoryIfMissing True (takeDirectory path)+                B.writeFile path given+            | otherwise -> throwIO e+        Right existing+            | WriteEnablerSecret given == WriteEnablerSecret existing -> pure ()+            | otherwise -> throwIO IncorrectWriteEnablerSecret   where-    partitionM' _ [] yes no = return (yes, no)-    partitionM' pred'' (item : rest) yes no = do-        result <- pred'' item-        if result-            then partitionM' pred'' rest (item : yes) no-            else partitionM' pred'' rest yes (item : no)+    path = secretPath storageIndexPath

@@ -1,22 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+ module TahoeLAFS.Storage.Backend.Memory (     MemoryBackend (MemoryBackend),     memoryBackend,+    MutableShareSize (..),+    shareDataSize,+    toMutableShareSize, ) where -import Prelude hiding (-    lookup,-    map,- )--import Network.HTTP.Types (-    ByteRanges,- )- import Control.Exception (+    throw,     throwIO,  )-import Data.Maybe (fromMaybe)-+import Control.Foldl.ByteString (Word8)+import Data.ByteArray (constEq)+import qualified Data.ByteString as B import Data.IORef (     IORef,     atomicModifyIORef',@@ -24,60 +22,193 @@     newIORef,     readIORef,  )-import Data.Map.Strict (-    Map,-    adjust,-    filterWithKey,-    fromList,-    insert,-    keys,-    lookup,-    map,-    toList,- )+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 qualified Data.Set as Set-+import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix)) import TahoeLAFS.Storage.API (-    AllocateBuckets,+    AllocateBuckets (AllocateBuckets),     AllocationResult (..),     CBORSet (..),-    CorruptionDetails,     Offset,     QueryRange,-    ReadResult,     ReadTestWriteResult (..),     ReadTestWriteVectors (..),+    ReadVector (ReadVector, offset, readSize),     ShareData,     ShareNumber,     Size,     StorageIndex,     TestWriteVectors (..),+    UploadSecret (UploadSecret),     Version (..),     Version1Parameters (..),+    WriteEnablerSecret (WriteEnablerSecret),     WriteVector (..),-    shareNumbers,  )- import TahoeLAFS.Storage.Backend (     Backend (..),-    ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+    WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret, ShareNotAllocated, ShareSizeMismatch),+    withUploadSecret,  )+import Prelude hiding (+    lookup,+    map,+ ) -type ShareStorage = Map StorageIndex (Map ShareNumber ShareData)-type BucketStorage = Map StorageIndex (Map ShareNumber (Size, ShareData))+data ImmutableShare = Complete ShareData | Uploading UploadSecret ShareData +data Bucket = Bucket+    { bucketSize :: Size+    , bucketShares :: Map.Map ShareNumber ImmutableShare+    }++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-    { immutableShares :: IORef ShareStorage -- Completely written immutable shares-    , mutableShares :: IORef ShareStorage -- Completely written mutable shares-    , buckets :: IORef BucketStorage -- In-progress immutable share uploads+    { memoryBackendBuckets :: Map.Map StorageIndex Bucket -- Completely or partially written immutable share data+    , mutableShares :: MutableShareStorage -- Completely written mutable shares     } +getShareNumbers :: StorageIndex -> MemoryBackend -> CBORSet ShareNumber+getShareNumbers storageIndex backend = shareSet+  where+    shareSet = CBORSet . Set.fromList $ shareNumbers+    shareNumbers = case Map.lookup storageIndex (memoryBackendBuckets backend) of+        Nothing -> mempty+        Just bucket -> Map.keys . bucketShares $ bucket++-- Attempt to allocate space at a certain storage index for some numbered+-- shares.  The space is only allocated if there is not yet any data for those+-- share numbers at that storage index.  The modified backend and a report of+-- the allocation done are returned.+allocate ::+    -- | The storage index at which to attempt the allocation.+    StorageIndex ->+    -- | The share numbers to attempt to allocate.+    [ShareNumber] ->+    -- | A shared secret authorizing write attempts to the allocated shares.+    UploadSecret ->+    -- | The size in bytes to allocate for each share.+    Size ->+    -- | The backend in which to do the allocation.+    MemoryBackend ->+    -- | The modified backend and the results of the allocation.+    (MemoryBackend, AllocationResult)+allocate storageIndex shareNumbers uploadSecret size backend@MemoryBackend{memoryBackendBuckets}+    | maybe size bucketSize existing /= size = throw ShareSizeMismatch+    | otherwise =+        ( backend{memoryBackendBuckets = updated}+        , result+        )+  where+    existing = Map.lookup storageIndex memoryBackendBuckets+    updated = Map.insertWith mergeBuckets storageIndex newBucket memoryBackendBuckets++    alreadyHave = maybe [] (Map.keys . bucketShares) existing+    allocated = filter (`notElem` alreadyHave) shareNumbers+    result = AllocationResult alreadyHave allocated++    -- Merge two buckets given precedence to the right-hand bucket for overlap.+    mergeBuckets (Bucket _ newShares) (Bucket _ oldShares) = Bucket size (newShares <> oldShares)++    -- The bucket we would allocate if there were no relevant existing state.+    newBucket = Bucket size (Map.fromList (zip shareNumbers (repeat newUpload)))+    newUpload = Uploading uploadSecret ""++abort ::+    StorageIndex ->+    ShareNumber ->+    UploadSecret ->+    MemoryBackend ->+    (MemoryBackend, ())+abort storageIndex shareNumber (UploadSecret abortSecret) b@MemoryBackend{memoryBackendBuckets} = (b{memoryBackendBuckets = updated memoryBackendBuckets}, ())+  where+    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' :: ImmutableShare -> Maybe ImmutableShare+    abortIt' (Uploading (UploadSecret existingSecret) _) = if constEq existingSecret abortSecret then Nothing else throw IncorrectUploadSecret+    abortIt' _ = throw ImmutableShareAlreadyWritten++writeImm ::+    StorageIndex ->+    ShareNumber ->+    UploadSecret ->+    B.ByteString ->+    MemoryBackend ->+    (MemoryBackend, ())+writeImm storageIndex shareNum (UploadSecret uploadSecret) newData b@MemoryBackend{memoryBackendBuckets}+    | isNothing share = throw ShareNotAllocated+    | otherwise = (b{memoryBackendBuckets = updated}, ())+  where+    bucket = Map.lookup storageIndex memoryBackendBuckets+    share = bucket >>= Map.lookup shareNum . bucketShares+    size = bucketSize <$> bucket+    updated = Map.adjust (\bkt -> bkt{bucketShares = Map.adjust writeToShare shareNum (bucketShares bkt)}) storageIndex memoryBackendBuckets++    writeToShare :: ImmutableShare -> ImmutableShare+    writeToShare (Complete _) = throw ImmutableShareAlreadyWritten+    writeToShare (Uploading (UploadSecret existingSecret) existingData)+        | authorized =+            (if Just True == (complete existingData newData <$> size) then Complete else Uploading (UploadSecret existingSecret)) (existingData <> newData)+        | otherwise = throw IncorrectUploadSecret+      where+        authorized = constEq existingSecret uploadSecret++    complete x y = (B.length x + B.length y ==) . fromIntegral+ instance Show MemoryBackend where     show _ = "<MemoryBackend>" -instance Backend MemoryBackend where+instance Backend (IORef MemoryBackend) where     version backend = do-        totalSize <- totalShareSize backend+        totalSize <- readIORef backend >>= totalShareSize         return             Version                 { applicationVersion = "(memory)"@@ -89,110 +220,174 @@                         }                 } -    createMutableStorageIndex :: MemoryBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult-    createMutableStorageIndex _backend _storageIndex params =-        return-            AllocationResult-                { alreadyHave = mempty-                , allocated = shareNumbers params-                }--    getMutableShareNumbers :: MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)+    getMutableShareNumbers :: IORef MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)     getMutableShareNumbers backend storageIndex = do-        shares' <- readIORef $ mutableShares 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 :: MemoryBackend -> StorageIndex -> ReadTestWriteVectors -> IO ReadTestWriteResult+    readvAndTestvAndWritev :: IORef MemoryBackend -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadTestWriteResult     readvAndTestvAndWritev         backend         storageIndex-        (ReadTestWriteVectors _secrets testWritev _readv) = do-            -- TODO implement readv and testv parts.  implement secrets part.-            let shares = mutableShares backend-            modifyIORef shares $ addShares storageIndex (shares' testWritev)-            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 -    createImmutableStorageIndex :: MemoryBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult-    createImmutableStorageIndex _backend _idx params =-        return-            AllocationResult-                { alreadyHave = mempty-                , allocated = shareNumbers params-                }+            tryWrite m@MemoryBackend{mutableShares} =+                case addShares storageIndex secret mutableShares (Map.map write testWritev) of+                    Nothing -> (m, SecretMismatch)+                    Just newShares -> (m{mutableShares = newShares}, TestSuccess) -    writeImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()-    writeImmutableShare backend storageIndex shareNumber shareData Nothing = do-        -- shares <- readIORef (immutableShares backend) -- XXX uh, is this right?!-        changed <- atomicModifyIORef' (immutableShares backend) $-            \shares ->-                case lookup storageIndex shares >>= lookup shareNumber of-                    Just _ ->-                        -- It is not allowed to write new data for an immutable share that-                        -- has already been written.-                        (shares, False)-                    Nothing ->-                        (addShares storageIndex [(shareNumber, shareData)] shares, True)-        if changed-            then return ()-            else throwIO ImmutableShareAlreadyWritten-    writeImmutableShare _ _ _ _ _ = error "writeImmutableShare got bad input"+    readMutableShare backend storageIndex shareNum queryRange =+        B.concat <$> readMutableShare' backend storageIndex shareNum queryRange -    adviseCorruptImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()+    createImmutableStorageIndex backend storageIndex secrets (AllocateBuckets shareNums size) =+        withUploadSecret secrets $ \secret ->+            atomicModifyIORef' backend (allocate storageIndex shareNums secret size)++    abortImmutableUpload backend storageIndex shareNumber secrets =+        withUploadSecret secrets $ \secret ->+            atomicModifyIORef' backend (abort storageIndex shareNumber secret)++    writeImmutableShare backend storageIndex shareNumber secrets shareData Nothing = do+        withUploadSecret secrets $ \secret ->+            atomicModifyIORef' backend (writeImm storageIndex shareNumber secret shareData)+    writeImmutableShare _ _ _ _ _ _ = error "writeImmutableShare got bad input"+     adviseCorruptImmutableShare _backend _ _ _ =         return mempty -    getImmutableShareNumbers :: MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)-    getImmutableShareNumbers backend storageIndex = do-        shares' <- readIORef $ immutableShares backend-        return $ CBORSet . Set.fromList $ maybe [] keys $ lookup storageIndex shares'+    getImmutableShareNumbers backend storageIndex = getShareNumbers storageIndex <$> readIORef backend -    readImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData     readImmutableShare backend storageIndex shareNum _qr = do-        shares' <- readIORef $ immutableShares backend-        let result = case lookup storageIndex shares' of-                Nothing -> mempty-                Just shares'' -> lookup shareNum shares''-        pure $ fromMaybe mempty result+        buckets <- memoryBackendBuckets <$> readIORef backend+        case Map.lookup storageIndex buckets of+            Nothing -> pure mempty+            Just bucket -> case Map.lookup shareNum (bucketShares bucket) of+                Just (Complete shareData) -> pure shareData+                _ -> pure mempty  totalShareSize :: MemoryBackend -> IO Size totalShareSize backend = do-    imm <- readIORef $ immutableShares backend-    mut <- readIORef $ mutableShares backend-    let immSize = sum $ map length imm-    let mutSize = sum $ map length mut-    return $ toInteger $ immSize + mutSize+    let imm = memoryBackendBuckets backend+        mut = mutableShares backend+    let immSize = sum $ Map.map bucketTotalSize imm+    let mutSize = sum $ Map.map (length . readProtected) mut+    return $ toInteger $ immSize + fromIntegral mutSize -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+bucketTotalSize :: Bucket -> Size+bucketTotalSize Bucket{bucketSize, bucketShares} = bucketSize * fromIntegral (Map.size bucketShares) -memoryBackend :: IO MemoryBackend+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-    immutableShares <- newIORef mempty-    mutableShares <- newIORef mempty-    buckets <- newIORef mempty-    return $ MemoryBackend immutableShares mutableShares buckets+    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

@@ -4,24 +4,13 @@     NullBackend (NullBackend), ) where +import qualified Data.Set as Set import TahoeLAFS.Storage.API (-    AllocateBuckets,     AllocationResult (..),-    ApplicationVersion,     CBORSet (..),-    CorruptionDetails,-    Offset,-    QueryRange,-    ReadResult,-    ShareData,-    ShareNumber,-    Size,-    StorageIndex,     Version (..),     Version1Parameters (..),  )--import qualified Data.Set as Set import TahoeLAFS.Storage.Backend (     Backend (..),  )@@ -42,8 +31,7 @@                         }                 } -    createImmutableStorageIndex :: NullBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult-    createImmutableStorageIndex NullBackend _ _ =+    createImmutableStorageIndex NullBackend _ _ _ =         return             AllocationResult                 { alreadyHave = mempty@@ -53,13 +41,10 @@     writeImmutableShare NullBackend _ _ _ _ =         return mempty -    adviseCorruptImmutableShare :: NullBackend -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()     adviseCorruptImmutableShare NullBackend _ _ _ =         return mempty -    getImmutableShareNumbers :: NullBackend -> StorageIndex -> IO (CBORSet ShareNumber)     getImmutableShareNumbers NullBackend _ =         return (CBORSet $ Set.fromList []) -    readImmutableShare :: NullBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData     readImmutableShare NullBackend _ _ _ = mempty

@@ -11,6 +11,7 @@     -- Immutable operations     createImmutableStorageIndex,     writeImmutableShare,+    abortImmutableUpload,     readImmutableShare,     getImmutableShareNumbers,     adviseCorruptImmutableShare,@@ -63,6 +64,7 @@         :<|> renewLease         :<|> createImmutableStorageIndex         :<|> writeImmutableShare+        :<|> abortImmutableUpload         :<|> readImmutableShare         :<|> getImmutableShareNumbers         :<|> adviseCorruptImmutableShare

@@ -9,79 +9,71 @@     throw,  ) import Control.Monad.IO.Class (-    MonadIO,     liftIO,  ) import Data.Maybe (fromMaybe)-+import Network.HTTP.Types (+    ByteRanges,+ )+import Network.Wai (+    Application,+ )+import Network.Wai.Handler.Warp (+    Port,+    defaultSettings,+    runSettings,+    setPort,+ )+import Network.Wai.Handler.WarpTLS (+    runTLS,+    tlsSettings,+ )+import Servant (+    Handler,+    Server,+    serve,+    (:<|>) (..),+ ) import TahoeLAFS.Storage.API (     AllocateBuckets,     AllocationResult (..),     CBORSet (..),     CorruptionDetails,-    LeaseSecret,-    Offset,+    LeaseSecret (Write),     QueryRange,-    ReadResult,     ReadTestWriteResult (..),     ReadTestWriteVectors,     ShareData,     ShareNumber,-    Size,     StorageAPI,     StorageIndex,     Version (..),     api,  )-+import TahoeLAFS.Storage.Backend (WriteImmutableError (MissingUploadSecret)) import qualified TahoeLAFS.Storage.Backend as Backend import TahoeLAFS.Storage.Backend.Filesystem (     FilesystemBackend (FilesystemBackend),  ) -import Servant (-    Handler,-    Server,-    serve,-    (:<|>) (..),- )--import Network.HTTP.Types (-    ByteRange,-    ByteRanges,- )--import Network.Wai (-    Application,- )--import Network.Wai.Handler.Warp (-    Port,-    defaultSettings,-    runSettings,-    setPort,- )--import Network.Wai.Handler.WarpTLS (-    runTLS,-    tlsSettings,- )- version :: Backend.Backend b => b -> Handler Version version backend =     liftIO (Backend.version backend) -renewLease :: (MonadIO m, Backend.Backend b) => b -> StorageIndex -> Maybe [LeaseSecret] -> m ()+renewLease :: Backend.Backend b => b -> StorageIndex -> Maybe [LeaseSecret] -> Handler () renewLease backend storageIndex secrets = liftIO (Backend.renewLease backend storageIndex (fromMaybe [] secrets)) -createImmutableStorageIndex :: Backend.Backend b => b -> StorageIndex -> AllocateBuckets -> Handler AllocationResult-createImmutableStorageIndex backend storage_index params =-    liftIO (Backend.createImmutableStorageIndex backend storage_index params)+createImmutableStorageIndex :: Backend.Backend b => b -> StorageIndex -> Maybe [LeaseSecret] -> AllocateBuckets -> Handler AllocationResult+createImmutableStorageIndex backend storageIndex secrets params =+    liftIO (Backend.createImmutableStorageIndex backend storageIndex secrets params) -writeImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> Handler ()-writeImmutableShare backend storage_index share_number share_data content_ranges =-    liftIO (Backend.writeImmutableShare backend storage_index share_number share_data content_ranges)+writeImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> ShareData -> Maybe ByteRanges -> Handler ()+writeImmutableShare backend storage_index share_number secrets share_data content_ranges =+    liftIO (Backend.writeImmutableShare backend storage_index share_number secrets share_data content_ranges) +abortImmutableUpload :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> Handler ()+abortImmutableUpload backend storageIndex shareNum secrets = liftIO (Backend.abortImmutableUpload backend storageIndex shareNum secrets)+ adviseCorruptImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> CorruptionDetails -> Handler () adviseCorruptImmutableShare backend storage_index share_number details =     liftIO (Backend.adviseCorruptImmutableShare backend storage_index share_number details)@@ -96,13 +88,13 @@     -- TODO Need to make sure content-range is set in the header otherwise     liftIO (Backend.readImmutableShare backend storage_index share_number qr) -createMutableStorageIndex :: Backend.Backend b => b -> StorageIndex -> AllocateBuckets -> Handler AllocationResult-createMutableStorageIndex backend storage_index params =-    liftIO (Backend.createMutableStorageIndex backend storage_index params)--readvAndTestvAndWritev :: Backend.Backend b => b -> StorageIndex -> ReadTestWriteVectors -> Handler ReadTestWriteResult-readvAndTestvAndWritev backend storage_index vectors =-    liftIO (Backend.readvAndTestvAndWritev backend storage_index vectors)+readvAndTestvAndWritev :: Backend.Backend b => b -> StorageIndex -> Maybe [LeaseSecret] -> ReadTestWriteVectors -> Handler ReadTestWriteResult+readvAndTestvAndWritev _ _ Nothing _ = throw MissingUploadSecret+readvAndTestvAndWritev _ _ (Just []) _ = throw MissingUploadSecret+readvAndTestvAndWritev backend storageIndex (Just (Write secret : _)) vectors =+    liftIO (Backend.readvAndTestvAndWritev backend storageIndex secret vectors)+readvAndTestvAndWritev backend storageIndex (Just (_ : ss)) vectors =+    readvAndTestvAndWritev backend storageIndex (Just ss) vectors  readMutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> QueryRange -> Handler ShareData readMutableShare backend storage_index share_numbers params =@@ -138,6 +130,7 @@             :<|> renewLease backend             :<|> createImmutableStorageIndex backend             :<|> writeImmutableShare backend+            :<|> abortImmutableUpload backend             :<|> readImmutableShare backend             :<|> getImmutableShareNumbers backend             :<|> adviseCorruptImmutableShare backend

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               tahoe-great-black-swamp-version:            0.3.1.0+version:            0.4.0.1 build-type:         Simple synopsis:           An implementation of the "Great Black Swamp" LAFS protocol. description:@@ -66,6 +66,7 @@     , containers            >=0.6.0.1  && <0.7     , deriving-aeson        >=0.2.6    && <0.3     , directory             >=1.3.3    && <1.4+    , extra                 >=1.7      && <1.8     , filepath              >=1.4.2    && <1.5     , foldl                 >=1.4.6    && <1.5     , http-types            >=0.12.3   && <0.13@@ -209,7 +210,7 @@     Vectors    default-language: Haskell2010-  ghc-options:      -Wall+  ghc-options:      -Wall -threaded   build-depends:     , base                     >=4.7      && <5     , base32string             >=0.9.1    && <0.10@@ -217,6 +218,7 @@     , cborg                    >=0.2.4    && <0.3     , connection               >=0.3      && <0.4     , data-default-class       >=0.1      && <0.2+    , data-interval            >=2.0.1    && <2.2     , hspec                    <2.12     , hspec-expectations       <0.9     , hspec-wai                <0.12@@ -224,6 +226,7 @@     , 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

@@ -48,8 +48,10 @@         it "works for CBORSet" $             deserialise (serialise cborSet) `shouldBe` cborSet -readRes = "strict bytestring" :: BS.ByteString+readRes :: BS.ByteString+readRes = "strict bytestring" +cborSet :: CBORSet ShareNumber cborSet = CBORSet (Set.fromList $ ShareNumber <$> [1, 2, 3])  testAV :: ApplicationVersion

@@ -4,44 +4,32 @@     spec, ) where -import Prelude hiding (-    replicate,- )--import qualified Data.Map.Strict as Map-import qualified Data.Vector as Vector-import GHC.Int (-    Int64,- )--import Data.Aeson.Types (-    Value (Array, Number, String),- )- import Data.Aeson (     encode,  )--import Data.ByteString (-    ByteString,+import Data.Aeson.Types (+    Value (Array, Number, String),  )- import qualified Data.ByteString.Lazy as L-+import qualified Data.Map.Strict as Map+import qualified Data.Vector as Vector import Network.HTTP.Types.Method (     methodGet,+    methodPatch,     methodPost,-    methodPut,  )-+import TahoeLAFS.Storage.Backend.Null (+    NullBackend (NullBackend),+ )+import TahoeLAFS.Storage.Server (+    app,+ ) import Test.Hspec (     Spec,     describe,     it,  )- import Test.Hspec.Wai (-    WaiSession,     matchBody,     matchHeaders,     request,@@ -49,21 +37,11 @@     with,     (<:>),  )- import Test.Hspec.Wai.Matcher (     bodyEquals,  )--import Network.Wai.Test (-    SResponse,- )--import TahoeLAFS.Storage.Backend.Null (-    NullBackend (NullBackend),- )--import TahoeLAFS.Storage.Server (-    app,+import Prelude hiding (+    replicate,  )  -- WaiSession changed incompatibly between hspec-wai 0.9.2 and 0.11.1.  We@@ -86,9 +64,9 @@         [("Content-Type", "application/json"), ("Accept", "application/json")]  -- putShare :: ByteString -> Int64 -> WaiSession st SResponse-putShare path size =+patchShare path size =     request-        methodPut+        methodPatch         path         [("Content-Type", "application/octet-stream"), ("Accept", "application/json")]         (L.replicate size 0xdd)@@ -122,10 +100,6 @@ -- Simple enough I won't go through Aeson here sharesResultJSON = "[]" -readResultJSON :: L.ByteString--- Simple, again.-readResultJSON = "{}"- spec :: Spec spec = with (return $ app NullBackend) $     describe "v1" $ do@@ -145,9 +119,9 @@                         , matchBody = bodyEquals allocateResultJSON                         } -        describe "PUT /storage/v1/immutable/abcdefgh/1" $ do+        describe "PATCH /storage/v1/immutable/abcdefgh/1" $ do             it "responds with CREATED" $-                putShare "/storage/v1/immutable/abcdefgh/1" 512 `shouldRespondWith` 201+                patchShare "/storage/v1/immutable/abcdefgh/1" 512 `shouldRespondWith` 201          describe "POST /storage/v1/immutable/abcdefgh/1/corrupt" $ do             it "responds with OK" $

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Lib (     gen10String,@@ -6,6 +7,7 @@     positiveIntegers,     b32encode,     b32decode,+    ShareNumbers (..), ) where  import Data.Word (@@ -24,6 +26,11 @@ import Test.QuickCheck (     Arbitrary (arbitrary),     Gen,+    NonNegative (getNonNegative),+    Positive (getPositive),+    oneof,+    shuffle,+    sublistOf,     suchThatMap,     vectorOf,  )@@ -32,9 +39,14 @@ import Test.QuickCheck.Instances.ByteString ()  import TahoeLAFS.Storage.API (-    ShareNumber,+    ReadTestWriteVectors (ReadTestWriteVectors),+    ReadVector (ReadVector),+    ShareNumber (..),     StorageIndex,-    shareNumber,+    TestOperator (Eq),+    TestVector (TestVector),+    TestWriteVectors (TestWriteVectors),+    WriteVector (..),  )  gen10String :: Gen String@@ -52,9 +64,6 @@ positiveIntegers =     suchThatMap (arbitrary :: Gen Integer) (Just . abs) -instance Arbitrary ShareNumber where-    arbitrary = suchThatMap positiveIntegers shareNumber- b32table :: ByteString b32table = "abcdefghijklmnopqrstuvwxyz234567" @@ -64,3 +73,37 @@ b32decode :: String -> ByteString b32decode base32 =     Base32.toBytes b32table $ Base32.fromText b32table $ Text.pack base32++newtype ShareNumbers = ShareNumbers {getShareNumbers :: [ShareNumber]} deriving (Eq, Ord, Show)++{- | An Arbitrary instance that guarantees ShareNumbers are unique and+   non-empty (without invoking discard).+-}+instance Arbitrary ShareNumbers where+    arbitrary = ShareNumbers . fmap ShareNumber <$> nums+      where+        nums =+            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 <*> oneof [pure Nothing, Just <$> arbNonNeg]++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 :: (Arbitrary n, Integral n) => Gen n+arbNonNeg = getNonNegative <$> arbitrary

@@ -7,7 +7,7 @@ import Spec (     spec,  )+import Test.Hspec (parallel)  main :: IO ()-main = do-    hspec spec+main = hspec . parallel $ spec

@@ -22,22 +22,21 @@ import qualified Data.ByteString as BS  import Test.QuickCheck (-    Arbitrary (arbitrary),-    Gen,     forAll,     property,-    vectorOf,  )  import TahoeLAFS.Storage.API (+    ShareNumber (ShareNumber),+    shareNumber,     toInteger,  ) --- We also get the Arbitrary ShareNumber instance from here. import Lib (     b32decode,     b32encode,     genStorageIndex,+    positiveIntegers,  )  import TahoeLAFS.Storage.Backend.Filesystem (@@ -51,11 +50,11 @@ spec = do     describe "partitionM" $         it "handles empty lists" $-            partitionM (\e -> return True) ([] :: [(Integer, Integer)]) `shouldBe` Just ([], [])+            partitionM (const $ pure True) ([] :: [(Integer, Integer)]) `shouldBe` Just ([], [])      describe "partitionM" $         it "puts matching elements in the first list and non-matching in the second" $-            partitionM (return . even) [5, 5, 6, 7, 8, 8]+            partitionM (return . even) [5 :: Int, 5, 6, 7, 8, 8]                 `shouldBe` Just ([6, 8, 8], [5, 5, 7])      describe "storageStartSegment" $@@ -68,9 +67,9 @@             property $                 forAll                     genStorageIndex-                    ( \storageIndex shareNumber ->-                        pathOfShare "/foo" storageIndex shareNumber-                            `shouldBe` printf "/foo/shares/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber)+                    ( \storageIndex shareNum ->+                        pathOfShare "/foo" storageIndex (ShareNumber shareNum)+                            `shouldBe` printf "/foo/shares/%s/%s/%d" (take 2 storageIndex) storageIndex shareNum                     )      describe "incomingPathOf" $@@ -78,9 +77,9 @@             property $                 forAll                     genStorageIndex-                    ( \storageIndex shareNumber ->-                        incomingPathOf "/foo" storageIndex shareNumber-                            `shouldBe` printf "/foo/shares/incoming/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber)+                    ( \storageIndex shareNum ->+                        incomingPathOf "/foo" storageIndex (ShareNumber shareNum)+                            `shouldBe` printf "/foo/shares/incoming/%s/%s/%d" (take 2 storageIndex) storageIndex shareNum                     )      describe "incomingPathOf vs pathOfShare" $@@ -88,9 +87,9 @@             property $                 forAll                     genStorageIndex-                    ( \storageIndex shareNumber ->-                        let path = pathOfShare "/foo" storageIndex shareNumber-                            incoming = incomingPathOf "/foo" storageIndex shareNumber+                    ( \storageIndex shareNum ->+                        let path = pathOfShare "/foo" storageIndex (ShareNumber shareNum)+                            incoming = incomingPathOf "/foo" storageIndex (ShareNumber shareNum)                          in path `shouldNotBe` incoming                     ) 

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleInstances #-}+ module SemanticSpec (     spec, ) where@@ -8,6 +10,7 @@  )  import Control.Monad (+    void,     when,  ) @@ -19,6 +22,7 @@     Word8,  ) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set  import System.Directory (@@ -32,92 +36,99 @@  import Test.Hspec (     Spec,-    SpecWith,-    around,-    before,     context,     describe,     it,+    shouldBe,     shouldThrow,  )-import Test.Hspec.Expectations (-    Selector,- )- import Test.QuickCheck (+    Gen,+    NonEmptyList (getNonEmpty),+    NonNegative (NonNegative),+    Positive (..),     Property,+    chooseInteger,+    counterexample,     forAll,+    ioProperty,+    oneof,     property,+    vector,+    (==>),  )  import Test.QuickCheck.Monadic (-    assert,     monadicIO,-    pre,     run,  ) -import Data.ByteString (-    ByteString,-    concat,-    length,-    map,- )--import Data.List (-    sort,- )+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 (ShareNumber),     Size,-    SlotSecrets (..),     StorageIndex,+    TestWriteVectors,+    UploadSecret (UploadSecret),+    WriteEnablerSecret (WriteEnablerSecret),+    WriteVector (WriteVector),     allocated,     alreadyHave,+    readv,     toInteger,+    writev,  )  import TahoeLAFS.Storage.Backend (     Backend (+        abortImmutableUpload,         createImmutableStorageIndex,-        createMutableStorageIndex,         getImmutableShareNumbers,         getMutableShareNumbers,         readImmutableShare,+        readvAndTestvAndWritev,         writeImmutableShare     ),-    ImmutableShareAlreadyWritten,+    WriteImmutableError (..),     writeMutableShare,  ) --- We also get the Arbitrary ShareNumber instance from here.+import Data.IORef (IORef)+ import Lib (+    ShareNumbers (..),     genStorageIndex,  )  import TahoeLAFS.Storage.Backend.Memory (-    MemoryBackend,+    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),  )--isUnique :: Ord a => [a] -> Bool-isUnique xs = Prelude.length xs == Prelude.length (Set.toList $ Set.fromList xs)---- XXX null ?-hasElements :: [a] -> Bool-hasElements = not . null+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@@ -132,185 +143,311 @@     write shareNumber shareData Nothing     writeShares write rest --- In the result of creating an immutable storage index, the sum of--- ``alreadyHave`` and ``allocated`` equals ``shareNumbers`` from the input. alreadyHavePlusAllocatedImm ::-    Backend b =>-    b -> -- The backend on which to operate-    StorageIndex -> -- The storage index to use-    [ShareNumber] -> -- The share numbers to allocate-    Size -> -- The size of each share-    Property-alreadyHavePlusAllocatedImm backend storageIndex shareNumbers size = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)-    result <- run $ createImmutableStorageIndex backend storageIndex $ AllocateBuckets "renew" "cancel" shareNumbers size-    when (alreadyHave result ++ allocated result /= shareNumbers) $-        fail-            ( show (alreadyHave result)-                ++ " ++ "-                ++ show (allocated result)-                ++ " /= "-                ++ show shareNumbers-            )---- In the result of creating a mutable storage index, the sum of--- ``alreadyHave`` and ``allocated`` equals ``shareNumbers`` from the input.-alreadyHavePlusAllocatedMut ::-    Backend b =>-    b -> -- The backend on which to operate+    (Backend b, Mess b) =>+    IO b -> -- The backend on which to operate     StorageIndex -> -- The storage index to use-    [ShareNumber] -> -- The share numbers to allocate-    Size -> -- The size of each share+    ShareNumbers -> -- The share numbers to allocate+    Positive Size -> -- The size of each share     Property-alreadyHavePlusAllocatedMut backend storageIndex shareNumbers size = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)-    result <- run $ createMutableStorageIndex backend storageIndex $ AllocateBuckets "renew" "cancel" shareNumbers size-    when (alreadyHave result ++ allocated result /= shareNumbers) $-        fail-            ( show (alreadyHave result)-                ++ " ++ "-                ++ show (allocated result)-                ++ " /= "-                ++ show shareNumbers-            )+alreadyHavePlusAllocatedImm makeBackend storageIndex (ShareNumbers shareNumbers) (Positive size) = monadicIO $+    run $+        withBackend makeBackend $ \backend -> do+            result <- createImmutableStorageIndex backend storageIndex (Just [anUploadSecret]) $ AllocateBuckets shareNumbers size+            when (alreadyHave result ++ allocated result /= shareNumbers) $+                fail+                    ( show (alreadyHave result)+                        ++ " ++ "+                        ++ show (allocated result)+                        ++ " /= "+                        ++ show shareNumbers+                    )  -- The share numbers of immutable share data written to the shares of a given -- storage index can be retrieved. immutableWriteAndEnumerateShares ::-    Backend b =>-    b ->+    (Backend b, Mess b) =>+    IO b ->     StorageIndex ->-    [ShareNumber] ->-    ByteString ->+    ShareNumbers ->+    B.ByteString ->     Property-immutableWriteAndEnumerateShares backend storageIndex shareNumbers shareSeed = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)+immutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do     let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers-    let size = fromIntegral (Data.ByteString.length shareSeed)-    let allocate = AllocateBuckets "renew" "cancel" shareNumbers size-    _result <- run $ createImmutableStorageIndex backend storageIndex allocate-    run $ writeShares (writeImmutableShare backend storageIndex) (zip shareNumbers permutedShares)-    readShareNumbers <- run $ getImmutableShareNumbers backend storageIndex-    when (readShareNumbers /= (CBORSet . Set.fromList $ shareNumbers)) $-        fail (show readShareNumbers ++ " /= " ++ show shareNumbers)+        size = fromIntegral (B.length shareSeed)+        allocate = AllocateBuckets shareNumbers size+    run $+        withBackend makeBackend $ \backend -> do+            void $ createImmutableStorageIndex backend storageIndex uploadSecret allocate+            writeShares (\sn -> writeImmutableShare backend storageIndex sn uploadSecret) (zip shareNumbers permutedShares)+            readShareNumbers <- getImmutableShareNumbers backend storageIndex+            when (readShareNumbers /= (CBORSet . Set.fromList $ shareNumbers)) $+                fail (show readShareNumbers ++ " /= " ++ show shareNumbers)+  where+    uploadSecret = Just [anUploadSecret]  -- Immutable share data written to the shares of a given storage index cannot -- be rewritten by a subsequent writeImmutableShare operation. immutableWriteAndRewriteShare ::-    Backend b =>-    b ->+    (Backend b, Mess b) =>+    IO b ->     StorageIndex ->-    [ShareNumber] ->-    ByteString ->+    ShareNumbers ->+    B.ByteString ->     Property-immutableWriteAndRewriteShare backend storageIndex shareNumbers shareSeed = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)-    let size = fromIntegral (Data.ByteString.length shareSeed)-    let allocate = AllocateBuckets "renew" "cancel" shareNumbers size-    let aShareNumber = head shareNumbers-    let aShare = permuteShare shareSeed aShareNumber-    let write =-            writeImmutableShare backend storageIndex aShareNumber aShare Nothing-    run $ do-        _ <- createImmutableStorageIndex backend storageIndex allocate-        write-        write `shouldThrow` (const True :: Selector ImmutableShareAlreadyWritten)+immutableWriteAndRewriteShare makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do+    let size = fromIntegral (B.length shareSeed)+        allocate = AllocateBuckets shareNumbers size+        aShareNumber = head shareNumbers+        aShare = permuteShare shareSeed aShareNumber+    run $+        withBackend makeBackend $ \backend -> do+            void $ createImmutableStorageIndex backend storageIndex uploadSecret allocate+            let write = writeImmutableShare backend storageIndex aShareNumber uploadSecret aShare Nothing+            write+            write `shouldThrow` (== ImmutableShareAlreadyWritten)+  where+    uploadSecret = Just [anUploadSecret]  -- Immutable share data written to the shares of a given storage index can be -- retrieved verbatim and associated with the same share numbers as were -- specified during writing. immutableWriteAndReadShare ::-    Backend b =>-    b ->+    (Backend b, Mess b) =>+    IO b ->     StorageIndex ->-    [ShareNumber] ->-    ByteString ->+    ShareNumbers ->+    B.ByteString ->     Property-immutableWriteAndReadShare backend storageIndex shareNumbers shareSeed = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)+immutableWriteAndReadShare makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do     let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers-    let size = fromIntegral (Data.ByteString.length shareSeed)-    let allocate = AllocateBuckets "renew" "cancel" shareNumbers size-    _result <- run $ createImmutableStorageIndex backend storageIndex allocate-    run $ writeShares (writeImmutableShare backend storageIndex) (zip shareNumbers permutedShares)-    readShares' <- run $ mapM (\sn -> readImmutableShare backend storageIndex sn Nothing) shareNumbers-    when (permutedShares /= readShares') $-        fail (show permutedShares ++ " /= " ++ show readShares')+    let size = fromIntegral (B.length shareSeed)+    let allocate = AllocateBuckets shareNumbers size+    run $+        withBackend makeBackend $ \backend -> do+            void $ createImmutableStorageIndex backend storageIndex uploadSecret allocate+            writeShares (\sn -> writeImmutableShare backend storageIndex sn uploadSecret) (zip shareNumbers permutedShares)+            readShares' <- mapM (\sn -> readImmutableShare backend storageIndex sn Nothing) shareNumbers+            when (permutedShares /= readShares') $+                fail (show permutedShares ++ " /= " ++ show readShares')+  where+    uploadSecret = Just [anUploadSecret]  -- The share numbers of mutable share data written to the shares of a given -- storage index can be retrieved. mutableWriteAndEnumerateShares ::-    Backend b =>-    b ->+    (Backend b, Mess b) =>+    IO b ->     StorageIndex ->-    [ShareNumber] ->-    ByteString ->+    ShareNumbers ->+    B.ByteString ->     Property-mutableWriteAndEnumerateShares backend storageIndex shareNumbers shareSeed = monadicIO $ do-    pre (isUnique shareNumbers)-    pre (hasElements shareNumbers)+mutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do     let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers-    let size = fromIntegral (Data.ByteString.length shareSeed)-    let allocate = AllocateBuckets "renew" "cancel" shareNumbers size-    let nullSecrets =-            SlotSecrets-                { writeEnabler = ""-                , leaseRenew = ""-                , leaseCancel = ""-                }-    _result <- run $ createMutableStorageIndex backend storageIndex allocate-    run $ writeShares (writeMutableShare backend nullSecrets storageIndex) (zip shareNumbers permutedShares)-    (CBORSet readShareNumbers) <- run $ getMutableShareNumbers backend storageIndex-    when (readShareNumbers /= Set.fromList shareNumbers) $-        fail (show readShareNumbers ++ " /= " ++ show shareNumbers)+    let nullSecret = WriteEnablerSecret ""+    run $+        withBackend makeBackend $ \backend -> do+            writeShares (\sn sh -> writeMutableShare backend storageIndex sn nullSecret sh) (zip shareNumbers permutedShares)+            (CBORSet readShareNumbers) <- getMutableShareNumbers backend storageIndex+            when (readShareNumbers /= Set.fromList shareNumbers) $+                fail (show readShareNumbers ++ " /= " ++ show shareNumbers) --- The specification for a storage backend.-storageSpec :: Backend b => SpecWith b-storageSpec =+-- | 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 = do     context "v1" $ do         context "immutable" $ do             describe "allocate a storage index" $-                it "accounts for all allocated share numbers" $ \backend ->+                it "accounts for all allocated share numbers" $                     property $-                        forAll genStorageIndex (alreadyHavePlusAllocatedImm backend)+                        forAll genStorageIndex (alreadyHavePlusAllocatedImm makeBackend) -            context "write a share" $ do-                it "returns the share numbers that were written" $ \backend ->-                    property $-                        forAll genStorageIndex (immutableWriteAndEnumerateShares backend)+        context "write a share" $ do+            it "disallows writes without an upload secret" $+                property $+                    withBackend makeBackend $ \backend -> do+                        AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100)+                        writeImmutableShare backend "storageindex" (ShareNumber 0) Nothing "fooooo" Nothing `shouldThrow` (== MissingUploadSecret) -                it "returns the written data when requested" $ \backend ->-                    property $-                        forAll genStorageIndex (immutableWriteAndReadShare backend)+            it "disallows writes without a matching upload secret" $+                property $+                    withBackend makeBackend $ \backend -> do+                        AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100)+                        -- Supply the wrong secret as an upload secret and the+                        -- right secret marked for some other use - this+                        -- should still fail.+                        writeImmutableShare backend "storageindex" (ShareNumber 0) (Just [Upload (UploadSecret "wrongsecret")]) "fooooo" Nothing `shouldThrow` (== IncorrectUploadSecret) -                it "cannot be written more than once" $ \backend ->-                    property $-                        forAll genStorageIndex (immutableWriteAndRewriteShare backend)+            it "disallows aborts without an upload secret" $+                property $+                    withBackend makeBackend $ \backend -> do+                        abortImmutableUpload backend "storageindex" (ShareNumber 0) Nothing `shouldThrow` (== MissingUploadSecret) -        context "mutable" $ do-            describe "allocate a storage index" $ do-                it "accounts for all allocated share numbers" $ \backend ->-                    property $-                        forAll genStorageIndex (alreadyHavePlusAllocatedMut backend)+            it "disallows aborts without a matching upload secret" $+                property $+                    withBackend makeBackend $ \backend -> do+                        AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100)+                        abortImmutableUpload backend "storageindex" (ShareNumber 0) (Just [Upload (UploadSecret "wrongsecret")]) `shouldThrow` (== IncorrectUploadSecret) +            it "allows aborts with a matching upload secret" $+                property $+                    withBackend makeBackend $ \backend -> do+                        AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100)+                        abortImmutableUpload backend "storageindex" (ShareNumber 0) (Just [anUploadSecret])++            it "returns the share numbers that were written" $+                property $+                    forAll genStorageIndex (immutableWriteAndEnumerateShares makeBackend)++            it "returns the written data when requested" $+                property $+                    forAll genStorageIndex (immutableWriteAndReadShare makeBackend)++            it "cannot be written more than once" $+                property $+                    forAll genStorageIndex (immutableWriteAndRewriteShare makeBackend)++        context "mutable" $ do+            -- XXX There's lots of problems around supplying negative integer+            -- values in most places.  We avoid tripping over those cases here+            -- but we should really fix the implementation to deal with them+            -- sensible.             describe "write a share" $ do-                it "returns the share numbers that were written" $ \backend ->+                it "returns the share numbers that were written" $                     property $-                        forAll genStorageIndex (mutableWriteAndEnumerateShares backend)+                        forAll genStorageIndex (mutableWriteAndEnumerateShares makeBackend) +                it "rejects an update with the wrong write enabler" $+                    forAll genStorageIndex $ \storageIndex shareNum (secret, wrongSecret) (shareData, junkData) (NonNegative 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" $+                    -- XXX We go out of our way to generate a legal storage+                    -- index here.  Illegal storage indexes aren't checked by+                    -- the system anywhere but they really ought to be.+                    forAll genStorageIndex $ \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" $-        Test.Hspec.before memoryBackend storageSpec+    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 -    Test.Hspec.context "filesystem" $-        Test.Hspec.around (withBackend filesystemBackend) storageSpec+                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"+ filesystemBackend :: IO FilesystemBackend filesystemBackend = do     FilesystemBackend <$> createTemporaryDirectory@@ -320,15 +457,15 @@     parent <- getCanonicalTemporaryDirectory     createTempDirectory parent "gbs-semanticspec" -class Mess m where+class Mess a where     -- Cleanup resources belonging to m-    cleanup :: m -> IO ()+    cleanup :: a -> IO ()  instance Mess FilesystemBackend where     cleanup (FilesystemBackend path) = removeDirectoryRecursive path -instance Mess MemoryBackend where-    cleanup _ = return ()+instance Mess (IORef MemoryBackend) where+    cleanup _ = pure ()  withBackend :: (Mess b, Backend b) => IO b -> ((b -> IO ()) -> IO ()) withBackend b action = do