diff --git a/ChangeLog.md b/ChangeLog.md index 1f45291edfedfe4b70714f5fdd096014f50cb3f0..bbb7cdeb70f5fc7464cacd87af1f8c3039c1bd19 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for tahoe-great-black-swamp +## 0.5.0.0 + +* The primary definition of most types related to the ``Backend`` class have moved to ``tahoe-great-black-swamp-types``. + They are still re-exported from their original location for convenience but the new location should be preferred. + +* The Filesystem and Memory backends now support operations on mutables. + ## 0.4.0.1 * Package metadata improvements. diff --git a/flake.lock b/flake.lock index 722a7ec905dc3e4d9d58f515ca459283a3e88231..c36c03710617dbbc00c21e5e1bb0e5446503c6f4 100644 --- a/flake.lock +++ b/flake.lock @@ -16,22 +16,6 @@ "type": "github" } }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1673956053, - "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "locked": { "lastModified": 1676283394, @@ -78,12 +62,15 @@ } }, "flake-utils_4": { + "inputs": { + "systems": "systems" + }, "locked": { - "lastModified": 1676283394, - "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=", + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", - "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { @@ -92,32 +79,27 @@ "type": "github" } }, - "gitignore": { + "flake-utils_5": { "inputs": { - "nixpkgs": [ - "hs-flake-utils", - "pre-commit-hooks", - "nixpkgs" - ] + "systems": "systems_2" }, "locked": { - "lastModified": 1660459072, - "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=", - "owner": "hercules-ci", - "repo": "gitignore.nix", - "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73", + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { - "owner": "hercules-ci", - "repo": "gitignore.nix", + "owner": "numtide", + "repo": "flake-utils", "type": "github" } }, - "gitignore_2": { + "gitignore": { "inputs": { "nixpkgs": [ - "tahoe-chk", "hs-flake-utils", "pre-commit-hooks", "nixpkgs" @@ -158,27 +140,6 @@ "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git" } }, - "hs-flake-utils_2": { - "inputs": { - "flake-utils": "flake-utils_4", - "nixpkgs": "nixpkgs_2", - "pre-commit-hooks": "pre-commit-hooks_2" - }, - "locked": { - "lastModified": 1677773826, - "narHash": "sha256-xJmOtHugr4k2zNhP/AF6JdIUnIEyM+TEspLn2n5kloc=", - "ref": "main", - "rev": "d3a83fdd9563546ca41771186427638e685a2e2b", - "revCount": 9, - "type": "git", - "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git" - }, - "original": { - "ref": "main", - "type": "git", - "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git" - } - }, "nixpkgs": { "locked": { "lastModified": 1677624842, @@ -211,38 +172,6 @@ "type": "github" } }, - "nixpkgs-stable_2": { - "locked": { - "lastModified": 1673800717, - "narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-22.11", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { - "locked": { - "lastModified": 1677624842, - "narHash": "sha256-4DF9DbDuK4/+KYx0L6XcPBeDHUFVCtzok2fWtwXtb5w=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "d70f5cd5c3bef45f7f52698f39e7cc7a89daa7f0", - "type": "github" - }, - "original": { - "owner": "nixos", - "ref": "nixos-22.11", - "repo": "nixpkgs", - "type": "github" - } - }, "pre-commit-hooks": { "inputs": { "flake-compat": "flake-compat", @@ -271,69 +200,128 @@ "type": "github" } }, - "pre-commit-hooks_2": { + "root": { "inputs": { - "flake-compat": "flake-compat_2", - "flake-utils": [ - "tahoe-chk", - "hs-flake-utils", - "flake-utils" - ], - "gitignore": "gitignore_2", + "flake-utils": "flake-utils", + "hs-flake-utils": "hs-flake-utils", "nixpkgs": [ - "tahoe-chk", "hs-flake-utils", "nixpkgs" ], - "nixpkgs-stable": "nixpkgs-stable_2" + "tahoe-chk": "tahoe-chk", + "tahoe-great-black-swamp-testing": "tahoe-great-black-swamp-testing", + "tahoe-great-black-swamp-types": "tahoe-great-black-swamp-types" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_2": { "locked": { - "lastModified": 1677722096, - "narHash": "sha256-7mjVMvCs9InnrRybBfr5ohqcOz+pyEX8m22C1XsDilg=", - "owner": "cachix", - "repo": "pre-commit-hooks.nix", - "rev": "61a3511668891c68ebd19d40122150b98dc2fe3b", + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", "type": "github" }, "original": { - "owner": "cachix", - "repo": "pre-commit-hooks.nix", + "owner": "nix-systems", + "repo": "default", "type": "github" } }, - "root": { + "tahoe-chk": { "inputs": { - "flake-utils": "flake-utils", - "hs-flake-utils": "hs-flake-utils", + "flake-utils": "flake-utils_3", + "hs-flake-utils": [ + "hs-flake-utils" + ], "nixpkgs": [ "hs-flake-utils", "nixpkgs" + ] + }, + "locked": { + "lastModified": 1696270283, + "narHash": "sha256-0/6VEsjXe7EvYY2BnkWkmHCVzdp1WcFLjx5mvHDMLnM=", + "ref": "main", + "rev": "57f02ab7d73b831afb0d2c8196bd3b02764bf29c", + "revCount": 488, + "type": "git", + "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk.git" + }, + "original": { + "ref": "main", + "type": "git", + "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk.git" + } + }, + "tahoe-great-black-swamp-testing": { + "inputs": { + "flake-utils": "flake-utils_4", + "hs-flake-utils": [ + "hs-flake-utils" ], - "tahoe-chk": "tahoe-chk" + "nixpkgs": [ + "hs-flake-utils", + "nixpkgs" + ], + "tahoe-great-black-swamp-types": [ + "tahoe-great-black-swamp-types" + ] + }, + "locked": { + "lastModified": 1699477067, + "narHash": "sha256-PwyrDMZXAhLb94XtRx2MIOz/77Zm5I7P8ag23WAFRPE=", + "ref": "main", + "rev": "1b34f87d90e3dbc61401ea46e4f02303c35aaf6d", + "revCount": 6, + "type": "git", + "url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-testing" + }, + "original": { + "ref": "main", + "type": "git", + "url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-testing" } }, - "tahoe-chk": { + "tahoe-great-black-swamp-types": { "inputs": { - "flake-utils": "flake-utils_3", - "hs-flake-utils": "hs-flake-utils_2", + "flake-utils": "flake-utils_5", + "hs-flake-utils": [ + "hs-flake-utils" + ], "nixpkgs": [ "hs-flake-utils", "nixpkgs" ] }, "locked": { - "lastModified": 1696262854, - "narHash": "sha256-0/6VEsjXe7EvYY2BnkWkmHCVzdp1WcFLjx5mvHDMLnM=", - "ref": "refs/tags/0.2.0.0", - "rev": "42ae52257ec6e6d8eaa9a56662ca5edfbce8074b", - "revCount": 487, + "lastModified": 1699453849, + "narHash": "sha256-7qqW8WwJ3yDrEsO9EfL9GxJo8piV5QeR7/GI9yYngaU=", + "ref": "main", + "rev": "bb60f23c8660db38a2ff89ec731aaa3a08c9d7ba", + "revCount": 10, "type": "git", - "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk" + "url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-types" }, "original": { - "ref": "refs/tags/0.2.0.0", + "ref": "main", "type": "git", - "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk" + "url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-types" } } }, diff --git a/flake.nix b/flake.nix index b1126ee4b1666dc7117d829516bd9ef87cb1f41a..792f16bb36fa9eb53a511bf0565bae1d04b8f7d4 100644 --- a/flake.nix +++ b/flake.nix @@ -8,8 +8,20 @@ hs-flake-utils.url = "git+https://whetstone.private.storage/jcalderone/hs-flake-utils.git?ref=main"; tahoe-chk = { - url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-chk?ref=refs/tags/0.2.0.0"; + url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-chk.git?ref=main"; inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs"; + inputs.hs-flake-utils.follows = "hs-flake-utils"; + }; + tahoe-great-black-swamp-types = { + url = "git+https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-types?ref=main"; + inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs"; + inputs.hs-flake-utils.follows = "hs-flake-utils"; + }; + tahoe-great-black-swamp-testing = { + url = "git+https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-testing?ref=main"; + inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs"; + inputs.hs-flake-utils.follows = "hs-flake-utils"; + inputs.tahoe-great-black-swamp-types.follows = "tahoe-great-black-swamp-types"; }; }; @@ -19,6 +31,8 @@ flake-utils, hs-flake-utils, tahoe-chk, + tahoe-great-black-swamp-types, + tahoe-great-black-swamp-testing, }: let ulib = flake-utils.lib; ghcVersion = "ghc8107"; @@ -43,6 +57,8 @@ packageName = "haskell-tahoe-lafs-storage-server"; hsPkgsOverrides = hfinal: hprev: { tahoe-chk = tahoe-chk.outputs.packages.${system}.default; + tahoe-great-black-swamp-types = tahoe-great-black-swamp-types.outputs.packages.${system}.default; + tahoe-great-black-swamp-testing = tahoe-great-black-swamp-testing.outputs.packages.${system}.default; }; }; in { @@ -54,36 +70,30 @@ # library pieces, so make sure pkg-config is around. pkg-config # And the C library pieces, too. - zlib + zlib.dev ]; }; packages = hslib.packages {}; apps = { - generate-cabal-project = { - type = "app"; - program = "${ - pkgs.writeShellApplication { - name = "generate-cabal-project"; - text = '' - cat >cabal.project.local <<EOF - -- This file is auto-generated by the flake devShell's shellHook. Do - -- not edit this file. Make changes in flake.nix. - package zlib - -- by default the cabal build won't use pkg-config to find the - -- underlying zlib c library. this will most likely cause - -- "cabal build" to fail (unless other steps are taken). turn - -- on pkg-config so that the cabal-test app below can succeed. - flags: -bundled-c-zlib -non-blocking-ffi +pkg-config - EOF - ''; - } - }/bin/generate-cabal-project"; + write-cabal-project = hslib.apps.write-cabal-project { + localPackages = { + tahoe-chk = tahoe-chk.sourceInfo.outPath; + tahoe-great-black-swamp-types = tahoe-great-black-swamp-types.sourceInfo.outPath; + tahoe-great-black-swamp-testing = tahoe-great-black-swamp-testing.sourceInfo.outPath; + }; }; cabal-test = hslib.apps.cabal-test { preBuild = '' # Refresh the cabal.project.local file to point to the correct # dependencies, if necessary. - nix run .#generate-cabal-project + nix run .#write-cabal-project + + # Also, zlib doesn't want to use pkg-config by default. Convince + # it... + cat >>cabal.project.local <<EOF + package zlib + flags: +pkg-config + EOF # Here we make zlib discoverable by pkg-config so cabal can find # headers and stuff. diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs index b4b5bd0b35ac40816fd5e4cb117b972eb5fdc3c3..5b0a38bf75c63e7d8388976d103db7ddaa50fd46 100644 --- a/src/TahoeLAFS/Storage/API.hs +++ b/src/TahoeLAFS/Storage/API.hs @@ -1,15 +1,11 @@ {-# LANGUAGE DataKinds #-} --- https://artyom.me/aeson#records-and-json-generics -{-# LANGUAGE DeriveAnyClass #-} --- https://artyom.me/aeson#records-and-json-generics -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} --- Supports derivations for ShareNumber -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeOperators #-} +-- TODO Move the orphans +{-# OPTIONS_GHC -fno-warn-orphans #-} module TahoeLAFS.Storage.API ( Version (..), @@ -59,7 +55,6 @@ import qualified Codec.Serialise.Encoding as CSE import Control.Monad import Data.Aeson ( FromJSON (..), - FromJSONKey (..), ToJSON (..), ToJSONKey (..), camelTo2, @@ -73,11 +68,9 @@ import Data.Aeson.Types ( toJSONKeyText, ) import Data.Bifunctor (Bifunctor (bimap)) -import Data.ByteArray (constEq) import qualified Data.ByteString as B import qualified "base64-bytestring" Data.ByteString.Base64 as Base64 import qualified Data.Map as Map -import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched) import Data.Map.Strict ( Map, ) @@ -86,9 +79,6 @@ import qualified Data.Text as T import Data.Text.Encoding ( decodeUtf8', ) -import GHC.Generics ( - Generic, - ) import Network.HTTP.Types ( ByteRanges, parseByteRanges, @@ -110,6 +100,35 @@ import Servant ( (:<|>), (:>), ) +import Tahoe.Storage.Backend ( + AllocateBuckets (..), + AllocationResult (..), + ApplicationVersion, + CBORSet (..), + CorruptionDetails (..), + LeaseSecret (..), + Offset, + QueryRange, + ReadResult, + ReadTestWriteResult (..), + ReadTestWriteVectors (..), + ReadVector (..), + ShareData, + ShareNumber (..), + Size, + StorageIndex, + TestOperator (..), + TestVector (..), + TestWriteVectors (..), + UploadSecret (..), + Version (..), + Version1Parameters (..), + WriteEnablerSecret (..), + WriteVector (..), + readv, + testv, + writev, + ) import TahoeLAFS.Internal.ServantUtil ( CBOR, ) @@ -141,37 +160,6 @@ leaseRenewSecretLength = 32 leaseCancelSecretLength :: Num a => a leaseCancelSecretLength = 32 -type ApplicationVersion = B.ByteString -type Size = Integer -type Offset = Integer -type QueryRange = Maybe ByteRanges - --- TODO These should probably all be byte strings instead. -type StorageIndex = String -type ShareData = B.ByteString - -newtype ShareNumber = ShareNumber Integer - deriving - ( Show - , Eq - , Ord - , Generic - ) - deriving newtype - ( ToJSON - , FromJSON - , FromJSONKey - ) - -{- | A new type for which we can define our own CBOR serialisation rules. The - cborg library provides a Serialise instance for Set which is not compatible - with the representation required by Tahoe-LAFS. --} -newtype CBORSet a = CBORSet - { getCBORSet :: Set.Set a - } - deriving newtype (ToJSON, FromJSON, Show, Eq) - -- | Encode a CBORSet using a CBOR "set" tag and a determinate length list. encodeCBORSet :: (Serialise a) => CBORSet a -> CSE.Encoding encodeCBORSet (CBORSet theSet) = @@ -237,13 +225,6 @@ shareNumber n = toInteger :: ShareNumber -> Integer toInteger (ShareNumber i) = i -data Version1Parameters = Version1Parameters - { maximumImmutableShareSize :: Size - , maximumMutableShareSize :: Size - , availableSpace :: Size - } - deriving (Show, Eq, Generic) - encodeVersion1Parameters :: Version1Parameters -> CSE.Encoding encodeVersion1Parameters Version1Parameters{..} = CSE.encodeMapLen 3 -- three rings for the elven kings @@ -296,12 +277,6 @@ instance ToJSON Version1Parameters where instance FromJSON Version1Parameters where parseJSON = genericParseJSON tahoeJSONOptions -data Version = Version - { parameters :: Version1Parameters - , applicationVersion :: ApplicationVersion - } - deriving (Show, Eq, Generic) - encodeApplicationVersion :: ApplicationVersion -> CSE.Encoding encodeApplicationVersion = CSE.encodeBytes @@ -353,12 +328,6 @@ instance ToJSON Version where instance FromJSON Version where parseJSON = genericParseJSON tahoeJSONOptions -data AllocateBuckets = AllocateBuckets - { shareNumbers :: [ShareNumber] - , allocatedSize :: Size - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise AllocateBuckets @@ -368,12 +337,6 @@ instance ToJSON AllocateBuckets where instance FromJSON AllocateBuckets where parseJSON = genericParseJSON tahoeJSONOptions -data AllocationResult = AllocationResult - { alreadyHave :: [ShareNumber] - , allocated :: [ShareNumber] - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise AllocationResult @@ -383,11 +346,6 @@ instance ToJSON AllocationResult where instance FromJSON AllocationResult where parseJSON = genericParseJSON tahoeJSONOptions -newtype CorruptionDetails = CorruptionDetails - { reason :: String - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise CorruptionDetails @@ -412,14 +370,6 @@ instance ToHttpApiData ByteRanges where toUrlPiece _ = error "Cannot serialize ByteRanges to URL piece" toQueryParam _ = error "Cannot serialize ByteRanges to query params" -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 @@ -528,14 +478,6 @@ type StorageAPI = :<|> "mutable" :> AdviseCorrupt ) -type ReadResult = Map ShareNumber [ShareData] - -data ReadTestWriteResult = ReadTestWriteResult - { success :: Bool - , readData :: ReadResult - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise ReadTestWriteResult @@ -545,12 +487,6 @@ instance ToJSON ReadTestWriteResult where instance FromJSON ReadTestWriteResult where parseJSON = genericParseJSON tahoeJSONOptions -data ReadTestWriteVectors = ReadTestWriteVectors - { testWriteVectors :: Map ShareNumber TestWriteVectors - , readVector :: [ReadVector] - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise ReadTestWriteVectors @@ -560,12 +496,6 @@ instance ToJSON ReadTestWriteVectors where instance FromJSON ReadTestWriteVectors where parseJSON = genericParseJSON tahoeJSONOptions -data ReadVector = ReadVector - { offset :: Offset - , readSize :: Size - } - deriving (Show, Eq, Generic) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise ReadVector @@ -575,72 +505,15 @@ instance ToJSON ReadVector where instance FromJSON ReadVector where parseJSON = genericParseJSON tahoeJSONOptions -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 - | Le - | Eq - | Ne - | Ge - | Gt - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise TestOperator -data TestVector = TestVector - { testOffset :: Offset - , testSize :: Size - , operator :: TestOperator - , specimen :: ShareData - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -- XXX This derived instance is surely not compatible with Tahoe-LAFS. instance Serialise TestVector -data WriteVector = WriteVector - { writeOffset :: Offset - , shareData :: ShareData - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - instance Serialise WriteVector api :: Proxy StorageAPI diff --git a/src/TahoeLAFS/Storage/Backend.hs b/src/TahoeLAFS/Storage/Backend.hs index 5d772befe6ff8222a7668ae25212a8a2801f75ba..efbf1878084ba787601e948c778d1db4e84ca221 100644 --- a/src/TahoeLAFS/Storage/Backend.hs +++ b/src/TahoeLAFS/Storage/Backend.hs @@ -5,6 +5,7 @@ module TahoeLAFS.Storage.Backend ( WriteImmutableError (..), writeMutableShare, withUploadSecret, + module Tahoe.Storage.Backend, ) where import Control.Exception ( @@ -12,76 +13,17 @@ import Control.Exception ( throw, throwIO, ) - import Data.Map.Strict ( fromList, ) - import Network.HTTP.Types ( ByteRanges, ) +import Tahoe.Storage.Backend import TahoeLAFS.Storage.API ( - AllocateBuckets, - AllocationResult, - CBORSet (..), - CorruptionDetails, - LeaseSecret (..), - QueryRange, - ReadTestWriteResult (..), - ReadTestWriteVectors (..), - ShareData, - ShareNumber, - StorageIndex, - TestWriteVectors (..), - UploadSecret (..), - Version, - WriteEnablerSecret, - WriteVector (..), isUploadSecret, ) -data WriteImmutableError - = MissingUploadSecret - | ShareSizeMismatch - | ImmutableShareAlreadyWritten - | ShareNotAllocated - | IncorrectUploadSecret - | IncorrectWriteEnablerSecret - deriving (Ord, Eq, Show) -instance Exception WriteImmutableError - -class Backend b where - version :: b -> IO Version - - -- | Update the lease expiration time on the shares associated with the - -- given storage index. - renewLease :: b -> StorageIndex -> [LeaseSecret] -> IO () - - createImmutableStorageIndex :: b -> StorageIndex -> Maybe [LeaseSecret] -> AllocateBuckets -> IO AllocationResult - - -- May throw ImmutableShareAlreadyWritten - 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 - - -- | 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 () - writeMutableShare :: Backend b => b -> diff --git a/src/TahoeLAFS/Storage/Backend/Filesystem.hs b/src/TahoeLAFS/Storage/Backend/Filesystem.hs index 2459c86ceaf8ce3f451163a6421bab43d400203e..039d7ed4d71845ae2aadee84da166d0e7b0d4646 100644 --- a/src/TahoeLAFS/Storage/Backend/Filesystem.hs +++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -30,7 +31,7 @@ import Data.Maybe ( mapMaybe, ) import qualified Data.Set as Set -import Data.Tuple.Extra ((&&&)) +import Network.HTTP.Types (ByteRange (..)) import System.Directory ( createDirectoryIfMissing, doesPathExist, @@ -45,11 +46,17 @@ import System.FilePath ( import System.IO ( Handle, IOMode (ReadMode, ReadWriteMode), - SeekMode (AbsoluteSeek), + SeekMode (..), + hFileSize, hSeek, withBinaryFile, ) import System.IO.Error (isDoesNotExistError) +import Tahoe.Storage.Backend ( + Backend (..), + WriteImmutableError (..), + WriteMutableError (..), + ) import TahoeLAFS.Storage.API ( AllocateBuckets (..), AllocationResult (..), @@ -58,7 +65,6 @@ import TahoeLAFS.Storage.API ( ReadResult, ReadTestWriteResult (ReadTestWriteResult, readData, success), ReadTestWriteVectors (ReadTestWriteVectors), - ReadVector (..), ShareData, ShareNumber, Size, @@ -73,11 +79,8 @@ import TahoeLAFS.Storage.API ( shareNumber, ) import qualified TahoeLAFS.Storage.API as Storage -import TahoeLAFS.Storage.Backend ( - Backend (..), - WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret), - withUploadSecret, - ) +import TahoeLAFS.Storage.Backend (withUploadSecret) +import TahoeLAFS.Storage.Backend.Util (readvToByteRange) import Prelude hiding ( readFile, writeFile, @@ -93,6 +96,12 @@ versionString = "tahoe-lafs (gbs) 0.1.0" maxMutableShareSize :: Storage.Size maxMutableShareSize = 69_105 * 1_000 * 1_000 * 1_000 * 1_000 +-- Perhaps should be based on the underlying filesystem? Currently a single +-- file is used per share so we cannot hold a share larger than the +-- filesystem's largest support file. +maximumShareSize :: Integral i => i +maximumShareSize = fromIntegral (maxBound :: Int) + -- storage/ -- storage/shares/incoming -- incoming/ holds temp dirs named $START/$STORAGEINDEX/$SHARENUM which will @@ -115,7 +124,7 @@ instance Backend FilesystemBackend where { applicationVersion = versionString , parameters = Version1Parameters - { maximumImmutableShareSize = available + { maximumImmutableShareSize = maximumShareSize , maximumMutableShareSize = maxMutableShareSize , -- TODO: Copy the "reserved space" feature of the Python -- implementation. @@ -127,7 +136,7 @@ instance Backend FilesystemBackend where withUploadSecret secrets $ \uploadSecret -> do let exists = haveShare backend storageIndex (alreadyHave, allocated) <- partitionM exists (shareNumbers params) - mapM_ (flip (allocate backend storageIndex) uploadSecret) allocated + mapM_ (flip (allocate backend storageIndex (allocatedSize params)) uploadSecret) allocated return AllocationResult { alreadyHave = alreadyHave @@ -146,18 +155,25 @@ instance Backend FilesystemBackend where 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 + + secretCheck <- try $ checkUploadSecret incomingSharePath uploadSecret + case secretCheck of + Left e + | isDoesNotExistError e -> throwIO ShareNotAllocated + | otherwise -> throwIO e + Right () -> do + writeFile incomingSharePath shareData + let createParents = True + createDirectoryIfMissing createParents $ takeDirectory finalSharePath + removeFileIfExists (secretPath incomingSharePath) + renameFile incomingSharePath finalSharePath abortImmutableUpload (FilesystemBackend root) storageIndex shareNumber' secrets = withUploadSecret secrets $ \uploadSecret -> do let incomingSharePath = incomingPathOf root storageIndex shareNumber' checkUploadSecret incomingSharePath uploadSecret - removeFile incomingSharePath + removeFileIfExists incomingSharePath + removeFileIfExists (secretPath incomingSharePath) getImmutableShareNumbers (FilesystemBackend root) storageIndex = do let storageIndexPath = pathOfStorageIndex root storageIndex @@ -178,6 +194,11 @@ instance Backend FilesystemBackend where getMutableShareNumbers = getImmutableShareNumbers + readMutableShare backend storageIndex shareNum Nothing = + readMutableShare backend storageIndex shareNum (Just [ByteRangeFrom 0]) + readMutableShare (FilesystemBackend root) storageIndex shareNum (Just ranges) = + B.concat <$> mapM (readMutableShare' root storageIndex shareNum) ranges + readvAndTestvAndWritev backend@(FilesystemBackend root) storageIndex @@ -200,21 +221,14 @@ instance Backend FilesystemBackend where Map.fromList . zip allShareNumbers' <$> mapM readvOneShare allShareNumbers' readvOneShare :: ShareNumber -> IO [ShareData] - readvOneShare shareNum = - mapM (uncurry (readShare shareNum) . (offset &&& readSize)) readv + readvOneShare shareNum = mapM (readMutableShare' root storageIndex shareNum) . fmap readvToByteRange $ 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 + checkTestVector shareNum TestVector{..} = + (specimen ==) <$> readMutableShare' root storageIndex shareNum (ByteRangeFromTo testOffset (testOffset + testSize - 1)) applyWriteVectors :: (ShareNumber, TestWriteVectors) -> @@ -276,18 +290,26 @@ storageStartSegment (a : b : _) = [a, b] allocate :: FilesystemBackend -> StorageIndex -> + Size -> ShareNumber -> UploadSecret -> IO () -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 "" - return () +allocate (FilesystemBackend root) storageIndex size shareNum (UploadSecret secret) + | size > maximumShareSize = + throwIO + MaximumShareSizeExceeded + { maximumShareSizeExceededLimit = maximumShareSize + , maximumShareSizeExceededGiven = size + } + | otherwise = + let sharePath = incomingPathOf root storageIndex shareNum + shareDirectory = takeDirectory sharePath + createParents = True + in do + createDirectoryIfMissing createParents shareDirectory + writeFile (secretPath sharePath) secret + writeFile sharePath "" + return () {- | Given the path of an immutable share, construct a path to use to hold the upload secret for that share. @@ -329,3 +351,28 @@ checkWriteEnabler (WriteEnablerSecret given) storageIndexPath = do | otherwise -> throwIO IncorrectWriteEnablerSecret where path = secretPath storageIndexPath + +removeFileIfExists :: FilePath -> IO () +removeFileIfExists p = + try (removeFile p) >>= \case + Left e + | isDoesNotExistError e -> pure () + | otherwise -> throwIO e + Right () -> pure () + +readMutableShare' :: FilePath -> StorageIndex -> ShareNumber -> ByteRange -> IO ShareData +readMutableShare' root storageIndex shareNum range = + withBinaryFile path ReadMode (readTheRange range) + where + path = pathOfShare root storageIndex shareNum + + readTheRange (ByteRangeFrom start) shareFile = do + hSeek shareFile AbsoluteSeek start + B.hGetContents shareFile + readTheRange (ByteRangeFromTo start end) shareFile = do + hSeek shareFile AbsoluteSeek start + B.hGetSome shareFile (fromIntegral $ end - start + 1) + readTheRange (ByteRangeSuffix len) shareFile = do + realSize <- hFileSize shareFile + hSeek shareFile SeekFromEnd (-(min realSize len)) + B.hGetContents shareFile diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs index b10ee5413361df315fe5dece9d5f44247f34ee8d..57e1a45e5bef23969025829467e8aaa5d54baeb9 100644 --- a/src/TahoeLAFS/Storage/Backend/Memory.hs +++ b/src/TahoeLAFS/Storage/Backend/Memory.hs @@ -1,12 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} -module TahoeLAFS.Storage.Backend.Memory ( - MemoryBackend (MemoryBackend), - memoryBackend, - MutableShareSize (..), - shareDataSize, - toMutableShareSize, -) where +module TahoeLAFS.Storage.Backend.Memory where import Control.Exception ( throw, @@ -15,22 +9,22 @@ import Control.Exception ( import Control.Foldl.ByteString (Word8) import Data.ByteArray (constEq) import qualified Data.ByteString as B +import Data.Composition ((.:)) import Data.IORef ( IORef, atomicModifyIORef', - modifyIORef, newIORef, readIORef, ) import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid (Last (Last, getLast)) +import Data.Monoid (All (All, getAll), First (First, getFirst)) import qualified Data.Set as Set -import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix)) -import TahoeLAFS.Storage.API ( +import Tahoe.Storage.Backend ( AllocateBuckets (AllocateBuckets), AllocationResult (..), + Backend (..), CBORSet (..), Offset, QueryRange, @@ -41,18 +35,20 @@ import TahoeLAFS.Storage.API ( ShareNumber, Size, StorageIndex, + TestVector (..), TestWriteVectors (..), UploadSecret (UploadSecret), Version (..), Version1Parameters (..), - WriteEnablerSecret (WriteEnablerSecret), + WriteEnablerSecret, + WriteImmutableError (..), + WriteMutableError (..), WriteVector (..), ) import TahoeLAFS.Storage.Backend ( - Backend (..), - WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret, ShareNotAllocated, ShareSizeMismatch), withUploadSecret, ) +import TahoeLAFS.Storage.Backend.Util (queryRangeToReadVector, readvToQueryRange) import Prelude hiding ( lookup, map, @@ -65,7 +61,10 @@ data Bucket = Bucket , bucketShares :: Map.Map ShareNumber ImmutableShare } -data SecretProtected a = SecretProtected WriteEnablerSecret a +data SecretProtected a = SecretProtected WriteEnablerSecret a deriving (Eq) + +instance Show a => Show (SecretProtected a) where + show (SecretProtected _ a) = "SecretProtected " <> show a readSecret :: SecretProtected a -> WriteEnablerSecret readSecret (SecretProtected s _) = s @@ -139,6 +138,12 @@ allocate :: (MemoryBackend, AllocationResult) allocate storageIndex shareNumbers uploadSecret size backend@MemoryBackend{memoryBackendBuckets} | maybe size bucketSize existing /= size = throw ShareSizeMismatch + | size > maximumShareSize = + throw + MaximumShareSizeExceeded + { maximumShareSizeExceededLimit = maximumShareSize + , maximumShareSizeExceededGiven = size + } | otherwise = ( backend{memoryBackendBuckets = updated} , result @@ -206,18 +211,24 @@ writeImm storageIndex shareNum (UploadSecret uploadSecret) newData b@MemoryBacke instance Show MemoryBackend where show _ = "<MemoryBackend>" +maximumShareSize :: Integral i => i +maximumShareSize = fromIntegral (maxBound :: Int) + +makeVersionParams :: Integer -> Version1Parameters +makeVersionParams totalSize = + Version1Parameters + { maximumImmutableShareSize = maximumShareSize + , maximumMutableShareSize = maximumShareSize + , availableSpace = (1024 * 1024 * 1024) - totalSize + } + instance Backend (IORef MemoryBackend) where version backend = do totalSize <- readIORef backend >>= totalShareSize return Version { applicationVersion = "(memory)" - , parameters = - Version1Parameters - { maximumImmutableShareSize = 1024 * 1024 * 64 - , maximumMutableShareSize = 1024 * 1024 * 64 - , availableSpace = (1024 * 1024 * 1024) - totalSize - } + , parameters = makeVersionParams totalSize } getMutableShareNumbers :: IORef MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber) @@ -230,48 +241,49 @@ instance Backend (IORef MemoryBackend) where $ sharemap readvAndTestvAndWritev :: IORef MemoryBackend -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadTestWriteResult - readvAndTestvAndWritev - backend - storageIndex - secret - (ReadTestWriteVectors testWritev readv) = do - -- TODO implement testv parts. - - (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 + readvAndTestvAndWritev backend storageIndex secret (ReadTestWriteVectors testWritev readv) = do + (CBORSet allShareNums) <- getMutableShareNumbers backend storageIndex + let queryRange = readvToQueryRange readv + + readData <- mapM (\shareNum -> (shareNum,) <$> readMutableShare' backend storageIndex shareNum queryRange) (Set.toList allShareNums) + + outcome <- atomicModifyIORef' backend tryWrite + case outcome of + TestSuccess -> + return + ReadTestWriteResult + { readData = Map.fromList readData + , success = True + } + TestFail -> + return + ReadTestWriteResult + { readData = Map.fromList readData + , success = False + } + SecretMismatch -> + throwIO IncorrectWriteEnablerSecret + where + checkTestVectors :: MutableShareStorage -> Map.Map ShareNumber TestWriteVectors -> Bool + checkTestVectors mutableShares = getAll . Map.foldMapWithKey (foldMap2 $ All .: checkTestVector mutableShares) . Map.map test + + checkTestVector :: MutableShareStorage -> ShareNumber -> TestVector -> Bool + checkTestVector mutableShares shareNum TestVector{..} = + specimen == actual where - readvToQueryRange :: [ReadVector] -> QueryRange - -- readvToQueryRange [] = Nothing - readvToQueryRange rv = Just (go rv) - where - go [] = [] - go (r : rs) = ByteRangeFromTo off end : go rs - where - off = offset r - end = off + readSize r - 1 - - tryWrite m@MemoryBackend{mutableShares} = + actual = + readMutableShare'' + mutableShares + storageIndex + shareNum + ReadVector{offset = testOffset, readSize = fromIntegral $ B.length specimen} + + tryWrite m@MemoryBackend{mutableShares} + | checkTestVectors mutableShares testWritev = case addShares storageIndex secret mutableShares (Map.map write testWritev) of Nothing -> (m, SecretMismatch) Just newShares -> (m{mutableShares = newShares}, TestSuccess) + | otherwise = (m, TestFail) readMutableShare backend storageIndex shareNum queryRange = B.concat <$> readMutableShare' backend storageIndex shareNum queryRange @@ -320,7 +332,7 @@ addShare storageIndex secret shareNum writev = f :: Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector] f = merge preserveMissing preserveMissing (zipWithMatched (const (<>))) - newShare = SecretProtected secret (Map.singleton shareNum writev) + newShare = SecretProtected secret (Map.singleton shareNum (reverse writev)) addShares :: StorageIndex -> WriteEnablerSecret -> MutableShareStorage -> Map.Map ShareNumber [WriteVector] -> Maybe MutableShareStorage addShares storageIndex secret existing updates @@ -339,31 +351,14 @@ memoryBackend = do readMutableShare' :: IORef MemoryBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO [ShareData] readMutableShare' backend storageIndex shareNum queryRange = do storage <- mutableShares <$> readIORef backend - pure $ doOneRead <$> rv storage <*> pure storage - where - rv :: MutableShareStorage -> [ReadVector] - rv storage = queryRangeToReadVector storage queryRange - - getShareData storage = - Map.lookup storageIndex storage >>= Map.lookup shareNum . readProtected - - doOneRead :: ReadVector -> MutableShareStorage -> ShareData - doOneRead readv storage = - maybe "" (readOneVector readv) (getShareData storage) + let shareSize = maybe 0 shareDataSize (getShareData storage storageIndex shareNum) + pure $ readMutableShare'' storage storageIndex shareNum <$> queryRangeToReadVector shareSize queryRange - queryRangeToReadVector :: MutableShareStorage -> QueryRange -> [ReadVector] - queryRangeToReadVector storage Nothing = [ReadVector 0 size] - where - size = maybe 0 shareDataSize (getShareData storage) - queryRangeToReadVector storage (Just ranges) = toReadVector <$> ranges - 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) +readMutableShare'' :: MutableShareStorage -> StorageIndex -> ShareNumber -> ReadVector -> ShareData +readMutableShare'' storage storageIndex shareNum rv = + maybe "" (readOneVector rv) theShareData + where + theShareData = getShareData storage storageIndex shareNum readOneVector :: ReadVector -> [WriteVector] -> ShareData readOneVector ReadVector{offset, readSize} wv = @@ -374,15 +369,19 @@ readMutableShare' backend storageIndex shareNum queryRange = do extractBytes :: Integer -> Word8 extractBytes p = fromMaybe 0 (go wv) where - -- New writes are added to the end of the list so give the Last + -- New writes are added to the front of the list so give the First -- write precedence over others. - go = getLast . foldMap (Last . byteFromShare p) + go = getFirst . foldMap (First . byteFromShare p) byteFromShare :: Integer -> WriteVector -> Maybe Word8 byteFromShare p (WriteVector off bytes) | p >= off && p < off + fromIntegral (B.length bytes) = Just (B.index bytes (fromIntegral $ p - off)) | otherwise = Nothing +getShareData :: MutableShareStorage -> StorageIndex -> ShareNumber -> Maybe [WriteVector] +getShareData storage storageIndex shareNum = + Map.lookup storageIndex storage >>= Map.lookup shareNum . readProtected + -- | Internal type tracking the result of an attempted mutable write. data WriteResult = -- | The test condition succeeded and the write was performed. @@ -391,3 +390,6 @@ data WriteResult TestFail | -- | The supplied secret was incorrect and the write was not performed. SecretMismatch + +foldMap2 :: (Foldable o, Monoid c) => (a -> b -> c) -> (a -> o b -> c) +foldMap2 f a = foldMap (f a) diff --git a/src/TahoeLAFS/Storage/Backend/Util.hs b/src/TahoeLAFS/Storage/Backend/Util.hs new file mode 100644 index 0000000000000000000000000000000000000000..6ec5a8aba3f26a0e0b8d7bd9aadf53dcfde8193e --- /dev/null +++ b/src/TahoeLAFS/Storage/Backend/Util.hs @@ -0,0 +1,27 @@ +module TahoeLAFS.Storage.Backend.Util where + +import Network.HTTP.Types (ByteRange (..)) +import Tahoe.Storage.Backend (QueryRange, ReadVector (..), Size) + +readvToByteRange :: ReadVector -> ByteRange +readvToByteRange ReadVector{..} = ByteRangeFromTo offset (offset + readSize - 1) + +readvToQueryRange :: [ReadVector] -> QueryRange +readvToQueryRange = Just . fmap readvToByteRange + +queryRangeToReadVector :: Size -> QueryRange -> [ReadVector] +queryRangeToReadVector shareSize Nothing = [ReadVector 0 shareSize] +queryRangeToReadVector shareSize (Just ranges) = toReadVector <$> ranges + where + toReadVector (ByteRangeFrom start) = ReadVector offset size + where + offset = max 0 start + size = shareSize - offset + toReadVector (ByteRangeFromTo start end) = ReadVector offset size + where + offset = min shareSize (max 0 start) + size = min (shareSize - offset) (end - start + 1) + toReadVector (ByteRangeSuffix len) = ReadVector offset size + where + offset = max 0 $ shareSize - len + size = min (shareSize - offset) len diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal index 7e23b4feaac5cf1722ee612d7f0872df979fe214..dc7a2d31009f77674c2a841631be6c791853db2f 100644 --- a/tahoe-great-black-swamp.cabal +++ b/tahoe-great-black-swamp.cabal @@ -100,41 +100,44 @@ library TahoeLAFS.Storage.Backend.Filesystem TahoeLAFS.Storage.Backend.Memory TahoeLAFS.Storage.Backend.Null + TahoeLAFS.Storage.Backend.Util TahoeLAFS.Storage.Client TahoeLAFS.Storage.Server default-language: Haskell2010 build-depends: - , asn1-encoding >=0.9.6 && <0.10 - , asn1-types >=0.3.4 && <0.4 - , base >=4.7 && <5 - , base64 >=0.2 && <0.5 - , base64-bytestring >=1.0.0.3 && <1.3 - , cborg >=0.2.4 && <0.3 - , cborg-json >=0.2.2 && <0.3 - , connection >=0.3.1 && <0.4 - , cryptonite >=0.27 && <0.31 - , data-default-class >=0.1 && <0.2 - , http-api-data >=0.4.1.1 && <0.7 - , http-client >=0.6.4.1 && <0.8 - , http-client-tls >=0.3.5.3 && <0.4 - , http-media >=0.8 && <0.9 - , memory >=0.15 && <0.19 - , network >=3.1.2 && <3.2 - , network-uri >=2.6.3 && <2.7 - , scientific >=0.3.6.2 && <0.4 - , serialise >=0.2.3 && <0.3 - , servant-client >=0.16.0.1 && <0.21 - , servant-docs >=0.11.4 && <0.14 - , servant-server >=0.16.2 && <0.21 - , tls >=1.5 && <2 - , utf8-string >=1.0.1.1 && <1.1 - , wai >=3.2.2.1 && <3.3 - , warp >=3.3.13 && <3.4 - , warp-tls >=3.2.12 && <3.5 - , x509 >=1.7 && <1.8 - , x509-store >=1.6 && <1.7 - , x509-validation >=1.6 && <1.7 + , asn1-encoding >=0.9.6 && <0.10 + , asn1-types >=0.3.4 && <0.4 + , base >=4.7 && <5 + , base64 >=0.2 && <0.5 + , base64-bytestring >=1.0.0.3 && <1.3 + , cborg >=0.2.4 && <0.3 + , cborg-json >=0.2.2 && <0.3 + , composition >=1.0 && <1.1 + , connection >=0.3.1 && <0.4 + , cryptonite >=0.27 && <0.31 + , data-default-class >=0.1 && <0.2 + , http-api-data >=0.4.1.1 && <0.7 + , http-client >=0.6.4.1 && <0.8 + , http-client-tls >=0.3.5.3 && <0.4 + , http-media >=0.8 && <0.9 + , memory >=0.15 && <0.19 + , network >=3.1.2 && <3.2 + , network-uri >=2.6.3 && <2.7 + , scientific >=0.3.6.2 && <0.4 + , serialise >=0.2.3 && <0.3 + , servant-client >=0.16.0.1 && <0.21 + , servant-docs >=0.11.4 && <0.14 + , servant-server >=0.16.2 && <0.21 + , tahoe-great-black-swamp-types >=0.4 && <0.5 + , tls >=1.5 && <2 + , utf8-string >=1.0.1.1 && <1.1 + , wai >=3.2.2.1 && <3.3 + , warp >=3.3.13 && <3.4 + , warp-tls >=3.2.12 && <3.5 + , x509 >=1.7 && <1.8 + , x509-store >=1.6 && <1.7 + , x509-validation >=1.6 && <1.7 -- executable gbs-generate-apidocs -- hs-source-dirs: generate-apidocs @@ -212,32 +215,34 @@ test-suite http-tests default-language: Haskell2010 ghc-options: -Wall -threaded build-depends: - , base >=4.7 && <5 - , base32string >=0.9.1 && <0.10 - , base64 >=0.2 && <0.5 - , 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 - , http-client >=0.6.4.1 && <0.8 - , 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 - , servant-client >=0.16.0.1 && <0.21 + , base >=4.7 && <5 + , base32string >=0.9.1 && <0.10 + , base64 >=0.2 && <0.5 + , 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 + , http-client >=0.6.4.1 && <0.8 + , 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 + , servant-client >=0.16.0.1 && <0.21 , tahoe-great-black-swamp - , temporary >=1.3 && <1.4 - , tls >=1.5 && <2 - , vector >=0.12.1.2 && <0.13 - , wai-extra >=3.0.29.2 && <3.2 - , warp >=3.3.13 && <3.4 - , warp-tls >=3.2.12 && <3.5 - , x509 >=1.7 && <1.8 - , x509-store >=1.6 && <1.7 - , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 + , tahoe-great-black-swamp-testing >=0.4 && <0.5 + , tahoe-great-black-swamp-types >=0.4 && <0.5 + , temporary >=1.3 && <1.4 + , tls >=1.5 && <2 + , vector >=0.12.1.2 && <0.13 + , wai-extra >=3.0.29.2 && <3.2 + , warp >=3.3.13 && <3.4 + , warp-tls >=3.2.12 && <3.5 + , x509 >=1.7 && <1.8 + , x509-store >=1.6 && <1.7 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 diff --git a/test/Lib.hs b/test/Lib.hs index 7c9af770bb1a1a8abb20caca6ccda0aff60c05e4..e0aaa0918c68750ee148bbad84b5ee8c15155c62 100644 --- a/test/Lib.hs +++ b/test/Lib.hs @@ -1,13 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Lib ( gen10String, - genStorageIndex, positiveIntegers, b32encode, b32decode, - ShareNumbers (..), ) where import Data.Word ( @@ -56,10 +53,6 @@ gen10ByteString :: Gen ByteString gen10ByteString = suchThatMap (vectorOf 10 (arbitrary :: Gen Word8)) (Just . pack) -genStorageIndex :: Gen StorageIndex -genStorageIndex = - suchThatMap gen10ByteString (Just . b32encode) - positiveIntegers :: Gen Integer positiveIntegers = suchThatMap (arbitrary :: Gen Integer) (Just . abs) @@ -73,37 +66,3 @@ b32encode = Text.unpack . Base32.toText . Base32.fromBytes b32table 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/MiscSpec.hs b/test/MiscSpec.hs index bd3e170c82d70b83e9e8747484b3baa84d045a13..0986284607dea2d9e5e7095be8923b78c184134c 100644 --- a/test/MiscSpec.hs +++ b/test/MiscSpec.hs @@ -35,10 +35,9 @@ import TahoeLAFS.Storage.API ( import Lib ( b32decode, b32encode, - genStorageIndex, positiveIntegers, ) - +import Tahoe.Storage.Testing.Spec (genStorageIndex) import TahoeLAFS.Storage.Backend.Filesystem ( incomingPathOf, partitionM, diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs index 9324c8f5b9cb5338b0c3d569c29ad5be78f73b44..6d85d0958349ba3e7cb3a757a62b6d85bd29f594 100644 --- a/test/SemanticSpec.hs +++ b/test/SemanticSpec.hs @@ -1,70 +1,37 @@ -{-# LANGUAGE FlexibleInstances #-} - module SemanticSpec ( spec, ) where -import Prelude hiding ( - lookup, - toInteger, - ) - import Control.Monad ( void, when, ) - import Data.Bits ( xor, ) - +import qualified Data.ByteString as B +import Data.Data (Proxy (Proxy)) +import Data.IORef (IORef) +import Data.Interval (Boundary (Closed, Open), Extended (Finite), Interval, interval, lowerBound, upperBound) +import qualified Data.IntervalSet as IS +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import GHC.Word ( Word8, ) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - +import Network.HTTP.Types (ByteRange (ByteRangeSuffix)) import System.Directory ( removeDirectoryRecursive, ) - import System.IO.Temp ( createTempDirectory, getCanonicalTemporaryDirectory, ) - -import Test.Hspec ( - Spec, - context, - describe, - it, - shouldBe, - shouldThrow, - ) -import Test.QuickCheck ( - Gen, - NonEmptyList (getNonEmpty), - NonNegative (NonNegative), - Positive (..), - Property, - chooseInteger, - counterexample, - forAll, - ioProperty, - oneof, - property, - vector, - (==>), - ) - -import Test.QuickCheck.Monadic ( - monadicIO, - run, +import Tahoe.Storage.Testing.Spec ( + ShareNumbers (..), + genStorageIndex, + makeStorageSpec, ) - -import qualified Data.ByteString as B - import TahoeLAFS.Storage.API ( AllocateBuckets (AllocateBuckets), AllocationResult (AllocationResult), @@ -88,7 +55,6 @@ import TahoeLAFS.Storage.API ( toInteger, writev, ) - import TahoeLAFS.Storage.Backend ( Backend ( abortImmutableUpload, @@ -102,155 +68,54 @@ import TahoeLAFS.Storage.Backend ( WriteImmutableError (..), writeMutableShare, ) - -import Data.IORef (IORef) - -import Lib ( - ShareNumbers (..), - genStorageIndex, +import TahoeLAFS.Storage.Backend.Filesystem ( + FilesystemBackend (FilesystemBackend), ) - import TahoeLAFS.Storage.Backend.Memory ( MemoryBackend (..), - MutableShareSize (MutableShareSize), + MutableShareSize (..), + SecretProtected (..), + addShares, memoryBackend, shareDataSize, toMutableShareSize, ) - -import Data.Data (Proxy (Proxy)) -import Data.Interval (Boundary (Closed, Open), Extended (Finite), Interval, interval, lowerBound, upperBound) -import qualified Data.IntervalSet as IS -import TahoeLAFS.Storage.Backend.Filesystem ( - FilesystemBackend (FilesystemBackend), +import TahoeLAFS.Storage.Backend.Util ( + queryRangeToReadVector, + readvToQueryRange, + ) +import Test.Hspec ( + Spec, + context, + describe, + it, + shouldBe, + shouldThrow, + ) +import Test.QuickCheck ( + Gen, + NonEmptyList (getNonEmpty), + NonNegative (NonNegative), + Positive (..), + Property, + chooseInteger, + counterexample, + forAll, + ioProperty, + oneof, + property, + vector, + (==>), ) import Test.QuickCheck.Classes (Laws (..), semigroupMonoidLaws) - -permuteShare :: B.ByteString -> ShareNumber -> B.ByteString -permuteShare seed number = - B.map xor' seed - where - xor' :: Word8 -> Word8 - xor' = xor $ fromInteger $ toInteger number - -writeShares :: - (ShareNumber -> ShareData -> Maybe a -> IO ()) -> - [(ShareNumber, ShareData)] -> - IO () -writeShares _write [] = return () -writeShares write ((shareNumber, shareData) : rest) = do - -- TODO For now we'll do single complete writes. Later try breaking up the data. - write shareNumber shareData Nothing - writeShares write rest - -alreadyHavePlusAllocatedImm :: - (Backend b, Mess b) => - IO b -> -- The backend on which to operate - StorageIndex -> -- The storage index to use - ShareNumbers -> -- The share numbers to allocate - Positive Size -> -- The size of each share - Property -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, Mess b) => - IO b -> - StorageIndex -> - ShareNumbers -> - B.ByteString -> - Property -immutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do - let permutedShares = Prelude.map (permuteShare shareSeed) 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, Mess b) => - IO b -> - StorageIndex -> - ShareNumbers -> - B.ByteString -> - Property -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, Mess b) => - IO b -> - StorageIndex -> - ShareNumbers -> - B.ByteString -> - Property -immutableWriteAndReadShare makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do - let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers - 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, Mess b) => - IO b -> - StorageIndex -> - ShareNumbers -> - B.ByteString -> - Property -mutableWriteAndEnumerateShares makeBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do - let permutedShares = Prelude.map (permuteShare shareSeed) 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) +import Test.QuickCheck.Monadic ( + monadicIO, + run, + ) +import Prelude hiding ( + lookup, + toInteger, + ) -- | Create a Spec that checks the given Laws. lawsCheck :: Laws -> Spec @@ -260,154 +125,10 @@ lawsCheck Laws{lawsTypeclass, 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" $ - property $ - forAll genStorageIndex (alreadyHavePlusAllocatedImm makeBackend) - - 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 "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 "disallows aborts without an upload secret" $ - property $ - withBackend makeBackend $ \backend -> do - abortImmutableUpload backend "storageindex" (ShareNumber 0) Nothing `shouldThrow` (== MissingUploadSecret) - - 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" $ - property $ - 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 context "utilities" $ do - describe "MutableShareStorage" $ do + describe "toMutableShareSize" $ do it "finds the larger size for some cases" $ do toMutableShareSize (WriteVector 0 "x") <> toMutableShareSize (WriteVector 1 "x") `shouldBe` MutableShareSize 0 2 @@ -421,6 +142,26 @@ spec = do toMutableShareSize (WriteVector 0 "Hello") <> toMutableShareSize (WriteVector 3 "world") `shouldBe` MutableShareSize 0 8 + describe "addShares" $ do + it "prepends the new write to the share storage" $ do + let si = "storageindex" + enabler = WriteEnablerSecret "enabler" + addShares' = addShares si enabler + shareNum = ShareNumber 0 + Just a = addShares' mempty (Map.fromList [(shareNum, [WriteVector 1 "first"])]) + Just b = addShares' a (Map.fromList [(shareNum, [WriteVector 2 "second"])]) + + b `shouldBe` Map.fromList [(si, SecretProtected enabler (Map.fromList [(shareNum, [WriteVector 2 "second", WriteVector 1 "first"])]))] + + it "puts later elements in a single WriteVector list earlier in the MutableShareStorage list" $ do + let si = "storageindex" + enabler = WriteEnablerSecret "enabler" + addShares' = addShares si enabler + shareNum = ShareNumber 0 + Just a = addShares' mempty (Map.fromList [(shareNum, [WriteVector 1 "first", WriteVector 2 "second"])]) + + a `shouldBe` Map.fromList [(si, SecretProtected enabler (Map.fromList [(shareNum, [WriteVector 2 "second", WriteVector 1 "first"])]))] + describe "shareDataSize" $ do it "converts list of WriteVector to a size" $ do shareDataSize [WriteVector 2 "foo", WriteVector 10 "quux"] @@ -442,11 +183,16 @@ spec = do . semigroupMonoidLaws $ (Proxy :: Proxy ReadTestWriteVectors) - context "memory" $ storageSpec memoryBackend - context "filesystem" $ storageSpec filesystemBackend + describe "ReadVector" $ do + it "it round-trips through queryRangeToReadVector / readvToQueryRange" $ + property $ \rvs -> + (queryRangeToReadVector 1234 . readvToQueryRange) rvs `shouldBe` rvs -anUploadSecret :: LeaseSecret -anUploadSecret = Upload $ UploadSecret "anuploadsecret" + it "imposes a lower bound of zero on offset" $ do + queryRangeToReadVector 1 (Just [ByteRangeSuffix 2]) `shouldBe` [ReadVector 0 1] + + context "memory" $ makeStorageSpec memoryBackend cleanupMemory + context "filesystem" $ makeStorageSpec filesystemBackend cleanupFilesystem filesystemBackend :: IO FilesystemBackend filesystemBackend = do @@ -457,18 +203,5 @@ createTemporaryDirectory = do parent <- getCanonicalTemporaryDirectory createTempDirectory parent "gbs-semanticspec" -class Mess a where - -- Cleanup resources belonging to m - cleanup :: a -> IO () - -instance Mess FilesystemBackend where - cleanup (FilesystemBackend path) = removeDirectoryRecursive path - -instance Mess (IORef MemoryBackend) where - cleanup _ = pure () - -withBackend :: (Mess b, Backend b) => IO b -> ((b -> IO ()) -> IO ()) -withBackend b action = do - backend <- b - action backend - cleanup backend +cleanupFilesystem (FilesystemBackend path) = removeDirectoryRecursive path +cleanupMemory _ = pure ()