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 ()