diff --git a/flake.lock b/flake.lock
index 722a7ec905dc3e4d9d58f515ca459283a3e88231..3d3fde90a81658ec2b1c03d0bc518da83528fa10 100644
--- a/flake.lock
+++ b/flake.lock
@@ -32,6 +32,38 @@
"type": "github"
}
},
+ "flake-compat_3": {
+ "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-compat_4": {
+ "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,
@@ -92,6 +124,72 @@
"type": "github"
}
},
+ "flake-utils_5": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1694529238,
+ "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_6": {
+ "locked": {
+ "lastModified": 1676283394,
+ "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_7": {
+ "inputs": {
+ "systems": "systems_2"
+ },
+ "locked": {
+ "lastModified": 1694529238,
+ "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_8": {
+ "locked": {
+ "lastModified": 1676283394,
+ "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
"gitignore": {
"inputs": {
"nixpkgs": [
@@ -137,6 +235,52 @@
"type": "github"
}
},
+ "gitignore_3": {
+ "inputs": {
+ "nixpkgs": [
+ "tahoe-great-black-swamp-testing",
+ "hs-flake-utils",
+ "pre-commit-hooks",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1660459072,
+ "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "type": "github"
+ }
+ },
+ "gitignore_4": {
+ "inputs": {
+ "nixpkgs": [
+ "tahoe-great-black-swamp-types",
+ "hs-flake-utils",
+ "pre-commit-hooks",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1660459072,
+ "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "type": "github"
+ }
+ },
"hs-flake-utils": {
"inputs": {
"flake-utils": "flake-utils_2",
@@ -179,6 +323,48 @@
"url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
}
},
+ "hs-flake-utils_3": {
+ "inputs": {
+ "flake-utils": "flake-utils_6",
+ "nixpkgs": "nixpkgs_3",
+ "pre-commit-hooks": "pre-commit-hooks_3"
+ },
+ "locked": {
+ "lastModified": 1696872058,
+ "narHash": "sha256-QCfoTnGtUABi5KbWXrTh4fhvLGP5B0gAG6KU1ACd96s=",
+ "ref": "main",
+ "rev": "683abab784ee38ea61863b3594d3777345f420d6",
+ "revCount": 20,
+ "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"
+ }
+ },
+ "hs-flake-utils_4": {
+ "inputs": {
+ "flake-utils": "flake-utils_8",
+ "nixpkgs": "nixpkgs_4",
+ "pre-commit-hooks": "pre-commit-hooks_4"
+ },
+ "locked": {
+ "lastModified": 1696872058,
+ "narHash": "sha256-QCfoTnGtUABi5KbWXrTh4fhvLGP5B0gAG6KU1ACd96s=",
+ "ref": "main",
+ "rev": "683abab784ee38ea61863b3594d3777345f420d6",
+ "revCount": 20,
+ "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,
@@ -227,6 +413,38 @@
"type": "github"
}
},
+ "nixpkgs-stable_3": {
+ "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-stable_4": {
+ "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,
@@ -243,6 +461,38 @@
"type": "github"
}
},
+ "nixpkgs_3": {
+ "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"
+ }
+ },
+ "nixpkgs_4": {
+ "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",
@@ -301,6 +551,66 @@
"type": "github"
}
},
+ "pre-commit-hooks_3": {
+ "inputs": {
+ "flake-compat": "flake-compat_3",
+ "flake-utils": [
+ "tahoe-great-black-swamp-testing",
+ "hs-flake-utils",
+ "flake-utils"
+ ],
+ "gitignore": "gitignore_3",
+ "nixpkgs": [
+ "tahoe-great-black-swamp-testing",
+ "hs-flake-utils",
+ "nixpkgs"
+ ],
+ "nixpkgs-stable": "nixpkgs-stable_3"
+ },
+ "locked": {
+ "lastModified": 1677722096,
+ "narHash": "sha256-7mjVMvCs9InnrRybBfr5ohqcOz+pyEX8m22C1XsDilg=",
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "rev": "61a3511668891c68ebd19d40122150b98dc2fe3b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "type": "github"
+ }
+ },
+ "pre-commit-hooks_4": {
+ "inputs": {
+ "flake-compat": "flake-compat_4",
+ "flake-utils": [
+ "tahoe-great-black-swamp-types",
+ "hs-flake-utils",
+ "flake-utils"
+ ],
+ "gitignore": "gitignore_4",
+ "nixpkgs": [
+ "tahoe-great-black-swamp-types",
+ "hs-flake-utils",
+ "nixpkgs"
+ ],
+ "nixpkgs-stable": "nixpkgs-stable_4"
+ },
+ "locked": {
+ "lastModified": 1677722096,
+ "narHash": "sha256-7mjVMvCs9InnrRybBfr5ohqcOz+pyEX8m22C1XsDilg=",
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "rev": "61a3511668891c68ebd19d40122150b98dc2fe3b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "type": "github"
+ }
+ },
"root": {
"inputs": {
"flake-utils": "flake-utils",
@@ -309,7 +619,39 @@
"hs-flake-utils",
"nixpkgs"
],
- "tahoe-chk": "tahoe-chk"
+ "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": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
}
},
"tahoe-chk": {
@@ -322,18 +664,69 @@
]
},
"locked": {
- "lastModified": 1696262854,
+ "lastModified": 1696270283,
"narHash": "sha256-0/6VEsjXe7EvYY2BnkWkmHCVzdp1WcFLjx5mvHDMLnM=",
- "ref": "refs/tags/0.2.0.0",
- "rev": "42ae52257ec6e6d8eaa9a56662ca5edfbce8074b",
- "revCount": 487,
+ "ref": "main",
+ "rev": "57f02ab7d73b831afb0d2c8196bd3b02764bf29c",
+ "revCount": 488,
"type": "git",
- "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk"
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk.git"
},
"original": {
- "ref": "refs/tags/0.2.0.0",
+ "ref": "main",
+ "type": "git",
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk.git"
+ }
+ },
+ "tahoe-great-black-swamp-testing": {
+ "inputs": {
+ "flake-utils": "flake-utils_5",
+ "hs-flake-utils": "hs-flake-utils_3",
+ "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-great-black-swamp-types": {
+ "inputs": {
+ "flake-utils": "flake-utils_7",
+ "hs-flake-utils": "hs-flake-utils_4",
+ "nixpkgs": [
+ "hs-flake-utils",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1699453849,
+ "narHash": "sha256-7qqW8WwJ3yDrEsO9EfL9GxJo8piV5QeR7/GI9yYngaU=",
+ "ref": "main",
+ "rev": "bb60f23c8660db38a2ff89ec731aaa3a08c9d7ba",
+ "revCount": 10,
+ "type": "git",
+ "url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-types"
+ },
+ "original": {
+ "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..02e16938341bf74b89da15328f0feaae6f0f95d5 100644
--- a/flake.nix
+++ b/flake.nix
@@ -8,9 +8,18 @@
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";
};
+ 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";
+ };
+ 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.tahoe-great-black-swamp-types.follows = "tahoe-great-black-swamp-types";
+ };
};
outputs = {
@@ -19,6 +28,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 +54,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 {
@@ -59,26 +72,25 @@
};
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;
+ };
};
+ # 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
+ # '';
cabal-test = hslib.apps.cabal-test {
preBuild = ''
# Refresh the cabal.project.local file to point to the correct
diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs
index b4b5bd0b35ac40816fd5e4cb117b972eb5fdc3c3..8493e073221861633a41633e18acd9ab6e997095 100644
--- a/src/TahoeLAFS/Storage/API.hs
+++ b/src/TahoeLAFS/Storage/API.hs
@@ -73,7 +73,6 @@ 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
@@ -110,6 +109,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 +169,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 +234,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 +286,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 +337,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 +346,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 +355,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 +379,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 +487,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 +496,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 +505,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 +514,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..487bc90c623abfeb438199766ae6d8d780c147c1 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,6 +13,7 @@ import Control.Exception (
throw,
throwIO,
)
+import Tahoe.Storage.Backend
import Data.Map.Strict (
fromList,
@@ -40,48 +42,6 @@ import TahoeLAFS.Storage.API (
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..82de301f71865546e52b848fb07134d565b4abf7 100644
--- a/src/TahoeLAFS/Storage/Backend/Filesystem.hs
+++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs
@@ -50,6 +50,11 @@ import System.IO (
withBinaryFile,
)
import System.IO.Error (isDoesNotExistError)
+import Tahoe.Storage.Backend (
+ Backend (..),
+ WriteImmutableError (..),
+ WriteMutableError (..),
+ )
import TahoeLAFS.Storage.API (
AllocateBuckets (..),
AllocationResult (..),
@@ -73,11 +78,7 @@ 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 Prelude hiding (
readFile,
writeFile,
diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs
index b10ee5413361df315fe5dece9d5f44247f34ee8d..6ea4e0460cdc6afb558feb2fc21752949c32d20b 100644
--- a/src/TahoeLAFS/Storage/Backend/Memory.hs
+++ b/src/TahoeLAFS/Storage/Backend/Memory.hs
@@ -50,7 +50,8 @@ import TahoeLAFS.Storage.API (
)
import TahoeLAFS.Storage.Backend (
Backend (..),
- WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret, ShareNotAllocated, ShareSizeMismatch),
+ WriteImmutableError (..),
+ WriteMutableError (..),
withUploadSecret,
)
import Prelude hiding (
diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal
index 7e23b4feaac5cf1722ee612d7f0872df979fe214..2d8cec2a1c28cc4b80c26c272adab0e85a36e5a5 100644
--- a/tahoe-great-black-swamp.cabal
+++ b/tahoe-great-black-swamp.cabal
@@ -105,36 +105,37 @@ library
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
+ , 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 +213,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..687b302e090d80e3306ea804e9a7cd633c75f564 100644
--- a/test/SemanticSpec.hs
+++ b/test/SemanticSpec.hs
@@ -105,11 +105,6 @@ import TahoeLAFS.Storage.Backend (
import Data.IORef (IORef)
-import Lib (
- ShareNumbers (..),
- genStorageIndex,
- )
-
import TahoeLAFS.Storage.Backend.Memory (
MemoryBackend (..),
MutableShareSize (MutableShareSize),
@@ -121,137 +116,16 @@ import TahoeLAFS.Storage.Backend.Memory (
import Data.Data (Proxy (Proxy))
import Data.Interval (Boundary (Closed, Open), Extended (Finite), Interval, interval, lowerBound, upperBound)
import qualified Data.IntervalSet as IS
+import Tahoe.Storage.Testing.Spec (
+ ShareNumbers (..),
+ genStorageIndex,
+ makeStorageSpec,
+ )
import TahoeLAFS.Storage.Backend.Filesystem (
FilesystemBackend (FilesystemBackend),
)
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)
-
-- | Create a Spec that checks the given Laws.
lawsCheck :: Laws -> Spec
lawsCheck Laws{lawsTypeclass, lawsProperties} =
@@ -260,150 +134,6 @@ 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
@@ -442,11 +172,8 @@ spec = do
. semigroupMonoidLaws
$ (Proxy :: Proxy ReadTestWriteVectors)
- context "memory" $ storageSpec memoryBackend
- context "filesystem" $ storageSpec filesystemBackend
-
-anUploadSecret :: LeaseSecret
-anUploadSecret = Upload $ UploadSecret "anuploadsecret"
+ context "memory" $ makeStorageSpec memoryBackend cleanupMemory
+ context "filesystem" $ makeStorageSpec filesystemBackend cleanupFilesystem
filesystemBackend :: IO FilesystemBackend
filesystemBackend = do
@@ -457,18 +184,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 ()