diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/src/TahoeLAFS/Internal/Client.hs b/src/TahoeLAFS/Internal/Client.hs --- a/src/TahoeLAFS/Internal/Client.hs +++ b/src/TahoeLAFS/Internal/Client.hs @@ -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 () diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs --- a/src/TahoeLAFS/Storage/API.hs +++ b/src/TahoeLAFS/Storage/API.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/APIDocs.hs b/src/TahoeLAFS/Storage/APIDocs.hs --- a/src/TahoeLAFS/Storage/APIDocs.hs +++ b/src/TahoeLAFS/Storage/APIDocs.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Backend.hs b/src/TahoeLAFS/Storage/Backend.hs --- a/src/TahoeLAFS/Storage/Backend.hs +++ b/src/TahoeLAFS/Storage/Backend.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Backend/Filesystem.hs b/src/TahoeLAFS/Storage/Backend/Filesystem.hs --- a/src/TahoeLAFS/Storage/Backend/Filesystem.hs +++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs --- a/src/TahoeLAFS/Storage/Backend/Memory.hs +++ b/src/TahoeLAFS/Storage/Backend/Memory.hs @@ -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 _ = "" -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 diff --git a/src/TahoeLAFS/Storage/Backend/Null.hs b/src/TahoeLAFS/Storage/Backend/Null.hs --- a/src/TahoeLAFS/Storage/Backend/Null.hs +++ b/src/TahoeLAFS/Storage/Backend/Null.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Client.hs b/src/TahoeLAFS/Storage/Client.hs --- a/src/TahoeLAFS/Storage/Client.hs +++ b/src/TahoeLAFS/Storage/Client.hs @@ -11,6 +11,7 @@ -- Immutable operations createImmutableStorageIndex, writeImmutableShare, + abortImmutableUpload, readImmutableShare, getImmutableShareNumbers, adviseCorruptImmutableShare, @@ -63,6 +64,7 @@ :<|> renewLease :<|> createImmutableStorageIndex :<|> writeImmutableShare + :<|> abortImmutableUpload :<|> readImmutableShare :<|> getImmutableShareNumbers :<|> adviseCorruptImmutableShare diff --git a/src/TahoeLAFS/Storage/Server.hs b/src/TahoeLAFS/Storage/Server.hs --- a/src/TahoeLAFS/Storage/Server.hs +++ b/src/TahoeLAFS/Storage/Server.hs @@ -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 diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal --- a/tahoe-great-black-swamp.cabal +++ b/tahoe-great-black-swamp.cabal @@ -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 diff --git a/test/CBORSpec.hs b/test/CBORSpec.hs --- a/test/CBORSpec.hs +++ b/test/CBORSpec.hs @@ -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 diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -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" $ diff --git a/test/Lib.hs b/test/Lib.hs --- a/test/Lib.hs +++ b/test/Lib.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,7 +7,7 @@ import Spec ( spec, ) +import Test.Hspec (parallel) main :: IO () -main = do - hspec spec +main = hspec . parallel $ spec diff --git a/test/MiscSpec.hs b/test/MiscSpec.hs --- a/test/MiscSpec.hs +++ b/test/MiscSpec.hs @@ -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 ) diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs --- a/test/SemanticSpec.hs +++ b/test/SemanticSpec.hs @@ -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