tahoe-great-black-swamp (empty) → 0.3.0.1
raw patch · 24 files changed
+3022/−0 lines, 24 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, base, base32, base32string, base64-bytestring, binary, bytestring, cborg, cborg-json, connection, containers, deriving-aeson, directory, filepath, foldl, hspec, hspec-expectations, hspec-wai, http-api-data, http-client, http-client-tls, http-media, http-types, megaparsec, network-uri, optparse-applicative, primitive, quickcheck-instances, safe-exceptions, scientific, serialise, servant, servant-client, servant-docs, servant-js, servant-server, tahoe-chk, tahoe-great-black-swamp, temporary, text, unordered-containers, utf8-string, vector, wai, wai-extra, warp, warp-tls
Files
- ChangeLog.md +16/−0
- LICENSE +32/−0
- README.rst +74/−0
- Setup.hs +2/−0
- app/Main.hs +52/−0
- client-test/Main.hs +122/−0
- generate-clients/Main.hs +36/−0
- src/TahoeLAFS/Internal/ServantUtil.hs +63/−0
- src/TahoeLAFS/Storage/API.hs +638/−0
- src/TahoeLAFS/Storage/APIDocs.hs +138/−0
- src/TahoeLAFS/Storage/Backend.hs +107/−0
- src/TahoeLAFS/Storage/Backend/Filesystem.hs +289/−0
- src/TahoeLAFS/Storage/Backend/Memory.hs +198/−0
- src/TahoeLAFS/Storage/Backend/Null.hs +65/−0
- src/TahoeLAFS/Storage/Client.hs +43/−0
- src/TahoeLAFS/Storage/Server.hs +158/−0
- tahoe-great-black-swamp.cabal +200/−0
- test/CBORSpec.hs +65/−0
- test/HTTPSpec.hs +178/−0
- test/Lib.hs +66/−0
- test/Main.hs +13/−0
- test/MiscSpec.hs +115/−0
- test/SemanticSpec.hs +337/−0
- test/Spec.hs +15/−0
+ ChangeLog.md view
@@ -0,0 +1,16 @@+# Changelog for tahoe-great-black-swamp++## 0.3.0.1++* Package metadata improvements.++## 0.3.0.0++* Support for ``GET /storage/v1/mutable/:storage-index/shares`` to list *mutable* shares on a server.+* Support for ``GET /storage/v1/mutable/:storage-index/:share-number`` to read *mutable* share bytes from a server.++## 0.2.0.2++* Initial release.+* Support for ``GET /storage/v1/immutable/:storage-index/shares`` to list shares on a server.+* Support for ``GET /storage/v1/immutable/:storage-index/:share-number`` to read share bytes from a server.
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright 2018-2023+Jean-Paul Calderone+Shae Erisson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Least Authority TFA GmbH nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.rst view
@@ -0,0 +1,74 @@+Great Black Swamp LAFS+======================++This is a preliminary implementation of the ``Great Black Swamp`` storage protocol.++Requirements+------------++tahoe-great-black-swamp uses stack and GHC.+Most dependencies should be handled automatically by stack.+If you have nix installed then you can use ``nix-shell`` to set up a build environment containing the non-Haskell dependencies.+If you don't have nix then you should install these some other way:++ * zlib-dev+ * autoconf++Run Unit Tests+--------------++::++ stack test++Generate GBS Clients+--------------------++Several client libraries can be automatically derived from the GBS interface definition.+These are written as source code to the working directory.++::++ mkdir generated-clients+ cd generated-clients+ stack build+ stack exec -- gbs-generate-clients++Generate GBS API Docs+---------------------++GBS API documentation can be generated from the GBS interface definition.++::++ stack build+ stack exec -- gbs-generate-apidocs++Run+---++::++ mkdir some-storage-dir+ stack build+ stack exec -- tahoe-great-black-swamp --storage-path some-storage-dir++Inspect the version of your new GBS server::++ curl --header 'Content-Type: application/json' --header 'Accept: application/json' http://localhost:8888/v1/version++You should expect a response something like::++ {+ "application-version": "tahoe-lafs (gbs) 0.1.0",+ "parameters": {+ "http-protocol-available": true,+ "fills-holes-with-zero-bytes": true,+ "available-space": 6215475200,+ "tolerates-immutable-read-overrun": true,+ "maximum-immutable-share-size": 6215475200,+ "prevents-read-past-end-of-share-data": true,+ "maximum-mutable-share-size": 69105000000000000,+ "delete-mutable-shares-with-zero-length-writev": true+ }+ }
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,52 @@+module Main where++import qualified TahoeLAFS.Storage.Server as Server++import Options.Applicative+ ( Parser+ , strOption+ , option+ , auto+ , long+ , metavar+ , value+ , help+ , execParser+ , info+ , progDesc+ , fullDesc+ , helper+ , optional+ , (<**>)+ )++import Data.Semigroup+ ( (<>)+ )++import Network.Wai.Handler.Warp+ ( Port+ )++server :: Parser Server.StorageServerConfig+server = Server.StorageServerConfig+ <$> strOption (long "storage-path"+ <> metavar "DIRECTORY"+ <> help "Path to the storage root directory.")+ <*> option auto (long "listen-port"+ <> metavar "PORT-NUMBER"+ <> help "TCP port number on which to listen."+ <> value (8888 :: Port))+ <*> (optional $ strOption (long "certificate-path"+ <> metavar "FILENAME"+ <> help "Path to storage server certificate."))+ <*> (optional $ strOption (long "key-path"+ <> metavar "FILENAME"+ <> help "Path to storage server key."))++main :: IO ()+main = Server.main =<< execParser opts+ where+ opts = info (server <**> helper)+ ( fullDesc+ <> progDesc "Run a Tahoe-LAFS (GBS) storage server.")
+ client-test/Main.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- | Demonstrate the use of some GBS client APIs.++ Usage:++ client-test <storage-furl> <chk-read-cap> <share-num>+-}+module Main where++import Data.ByteString.Base32 (encodeBase32Unpadded)++import qualified Data.ByteString.Base64 as Base64++import Data.Text+import Data.Text.Encoding (encodeUtf8)++import Network.Connection (TLSSettings (TLSSettingsSimple))+import Network.HTTP.Client (+ ManagerSettings (managerModifyRequest),+ Request (requestHeaders),+ )+import Network.HTTP.Client.TLS (+ mkManagerSettings,+ newTlsManagerWith,+ )+import Network.HTTP.Types ()+import Network.URI (+ URI (URI, uriAuthority, uriPath),+ URIAuth (URIAuth, uriPort, uriRegName),+ parseURI,+ )+import Servant.Client (+ BaseUrl (BaseUrl),+ ClientError,+ ClientM,+ Scheme (Https),+ mkClientEnv,+ runClientM,+ )+import System.Environment (getArgs)+import Tahoe.CHK.Capability (+ CHK (CHKReader),+ Reader (Reader, verifier),+ Verifier (+ Verifier,+ fingerprint,+ required,+ size,+ storageIndex,+ total+ ),+ pCapability,+ )+import TahoeLAFS.Storage.Client+import Text.Megaparsec++import TahoeLAFS.Storage.API++main :: IO ()+main = do+ [storageFURLStr, capStr, shareNumStr] <- getArgs+ let Right (CHKReader Reader{verifier = Verifier{..}}) = parse pCapability "argv[2]" (Data.Text.pack capStr)+ Just URI{uriAuthority = Just URIAuth{uriRegName = hostname, uriPort = (':' : port)}, uriPath = ('/' : swissnum)} = parseFURL storageFURLStr++ run (Data.Text.unpack . Data.Text.toLower . encodeBase32Unpadded $ storageIndex) hostname (read port) swissnum (ShareNumber (read shareNumStr))++-- Parse it like a regular URI after removing the confusing "tcp:" prefix on+-- the netloc.+parseFURL :: String -> Maybe URI+parseFURL = parseURI . Data.Text.unpack . Data.Text.replace "tcp:" "" . Data.Text.pack++-- Add the necessary authorization header.+fixAccept :: Applicative f => String -> Request -> f Request+fixAccept swissnum req =+ pure req{requestHeaders = ("Authorization", "Tahoe-LAFS " <> enc swissnum) : requestHeaders req}+ where+ enc = Base64.encode . encodeUtf8 . Data.Text.pack++fixAcceptPrint :: String -> Request -> IO Request+fixAcceptPrint swissnum req = do+ print req+ fixAccept swissnum req++-- Do some API calls and report the results.+run ::+ -- | The base32-encoded storage index for which to request share info.+ String ->+ -- | The hostname or IP address of the storage server to query.+ String ->+ -- | The port number of the storage server to query.+ Int ->+ -- | The swissnum of the storage service+ String ->+ -- | A share number to download from the server.+ ShareNumber ->+ IO ()+run storageIndex hostname port swissnum shareNum = do+ manager' <- newTlsManagerWith managerSettings+ let callIt :: ClientM a -> IO (Either ClientError a)+ callIt = flip runClientM (mkClientEnv manager' (BaseUrl Https hostname port ""))++ putStrLn "getVersion"+ ver <- callIt version+ showIt ver+ putStrLn "getImmutableShareNumbers:"+ sharez <- callIt $ getImmutableShareNumbers storageIndex+ showIt sharez+ putStrLn "readImmutableShare - succeeds!"+ chk <- callIt $ readImmutableShare storageIndex shareNum Nothing+ showIt chk+ where+ tlsSettings = TLSSettingsSimple True True True+ sockSettings = Nothing+ managerSettings = (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = fixAccept swissnum}++showIt :: (Show a1, Show a2) => Either a1 a2 -> IO ()+showIt what = case what of+ Left err -> putStrLn $ "Error: " <> show err+ Right it -> print it
+ generate-clients/Main.hs view
@@ -0,0 +1,36 @@+module Main where++import System.FilePath (+ FilePath,+ (</>),+ )++import Servant.JS (+ angular,+ defAngularOptions,+ jquery,+ vanillaJS,+ writeJSForAPI,+ )++-- import Servant.PY+-- ( writePythonForAPI+-- , requests+-- , treq+-- )++import TahoeLAFS.Storage.API (+ api,+ )++result :: FilePath+result = "./"++main :: IO ()+main = do+ -- writePythonForAPI api requests (result </> "requests_api.py")+ -- writePythonForAPI api treq (result </> "treq_api.py")++ writeJSForAPI api (angular defAngularOptions) (result </> "angular_api.js")+ writeJSForAPI api vanillaJS (result </> "vanilla_api.js")+ writeJSForAPI api jquery (result </> "jquery_api.js")
+ src/TahoeLAFS/Internal/ServantUtil.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TahoeLAFS.Internal.ServantUtil (+ CBOR,+) where++import Network.HTTP.Media (+ (//),+ )++import Data.ByteString (+ ByteString,+ )+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Text as T+import Data.Text.Encoding (+ decodeLatin1,+ encodeUtf8,+ )++import Servant (+ Accept (..),+ MimeRender (..),+ MimeUnrender (..),+ )++import qualified Codec.Serialise as S+import Data.Aeson (+ FromJSON (parseJSON),+ ToJSON (toJSON),+ withText,+ )+import Data.Aeson.Types (+ Value (String),+ )++data CBOR++instance Accept CBOR where+ -- https://tools.ietf.org/html/rfc7049#section-7.3+ contentType _ = "application" // "cbor"++instance S.Serialise a => MimeRender CBOR a where+ mimeRender _ = S.serialise++instance S.Serialise a => MimeUnrender CBOR a where+ mimeUnrender _ bytes = Right $ S.deserialise bytes++instance ToJSON ByteString where+ toJSON = String . decodeLatin1 . Base64.encode++instance FromJSON ByteString where+ parseJSON =+ withText+ "String"+ ( \bs ->+ case Base64.decode $ encodeUtf8 bs of+ Left err -> fail ("Base64 decoding failed: " <> err)+ Right bytes -> return bytes+ )
+ src/TahoeLAFS/Storage/API.hs view
@@ -0,0 +1,638 @@+{-# LANGUAGE DataKinds #-}+-- https://artyom.me/aeson#records-and-json-generics+{-# LANGUAGE DeriveAnyClass #-}+-- https://artyom.me/aeson#records-and-json-generics+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+-- Supports derivations for ShareNumber+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module TahoeLAFS.Storage.API (+ Version (..),+ Size,+ Offset,+ StorageIndex,+ ShareNumber (ShareNumber),+ shareNumber,+ toInteger,+ ShareData,+ ApplicationVersion,+ Version1Parameters (..),+ AllocateBuckets (..),+ AllocationResult (..),+ TestWriteVectors (..),+ WriteVector (..),+ ReadTestWriteVectors (..),+ ReadTestWriteResult (..),+ ReadVectors,+ ReadVector,+ QueryRange,+ TestVector (TestVector),+ ReadResult,+ CorruptionDetails (CorruptionDetails),+ SlotSecrets (..),+ TestOperator (..),+ StorageAPI,+ LeaseSecret (..),+ api,+ renewSecretLength,+ writeEnablerSecretLength,+ leaseRenewSecretLength,+ leaseCancelSecretLength,+ CBOR,+ CBORSet (..),+) where++import Codec.CBOR.Encoding (encodeBytes)+import Codec.Serialise.Class+import Codec.Serialise.Decoding (decodeListLen)+import qualified Codec.Serialise.Decoding as CSD+import qualified Codec.Serialise.Encoding as CSE+import Control.Monad+import Data.Aeson (+ FromJSON (..),+ FromJSONKey (..),+ ToJSON (..),+ ToJSONKey (..),+ camelTo2,+ defaultOptions,+ fieldLabelModifier,+ genericParseJSON,+ genericToJSON,+ )+import Data.Aeson.Types (+ Options,+ toJSONKeyText,+ )+import Data.Bifunctor (Bifunctor (bimap))+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Map as Map+import Data.Map.Strict (+ Map,+ )+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (+ decodeUtf8',+ )+import GHC.Generics (+ Generic,+ )+import Network.HTTP.Types (+ ByteRanges,+ parseByteRanges,+ renderByteRanges,+ )+import Servant (+ Capture,+ Get,+ Header,+ JSON,+ OctetStream,+ Post,+ PostCreated,+ Proxy (Proxy),+ QueryParams,+ ReqBody,+ StdMethod (PUT),+ Verb,+ (:<|>),+ (:>),+ )+import TahoeLAFS.Internal.ServantUtil (+ CBOR,+ )+import Text.Read (+ readMaybe,+ )+import Web.HttpApiData (+ FromHttpApiData (..),+ ToHttpApiData (..),+ )+import Prelude hiding (+ toInteger,+ )++type PutCreated = Verb 'PUT 201++tahoeJSONOptions :: Options+tahoeJSONOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '-'+ }++-- The expected lengths of the secrets represented as opaque byte strings.+-- I haven't checked that these values are correct according to Tahoe-LAFS.+renewSecretLength :: Num a => a+renewSecretLength = 32+writeEnablerSecretLength :: Num a => a+writeEnablerSecretLength = 32+leaseRenewSecretLength :: Num a => a+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 RenewSecret = String+type CancelSecret = String+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) =+ CSE.encodeTag 258+ <> CSE.encodeListLen (fromIntegral $ Set.size theSet) -- XXX don't trust fromIntegral+ <> Set.foldr (\x r -> encode x <> r) mempty theSet++-- | Decode a determinate length list with a CBOR "set" tag.+decodeCBORSet :: (Serialise a, Ord a) => CSD.Decoder s (CBORSet a)+decodeCBORSet = do+ tag <- CSD.decodeTag+ if tag /= 258+ then fail $ "expected set tag (258), found " <> show tag+ else do+ listLength <- decodeListLen+ CBORSet . Set.fromList <$> replicateM listLength decode++-- | Define serialisation for CBORSets in a way that is compatible with GBS.+instance (Serialise a, Ord a) => Serialise (CBORSet a) where+ encode = encodeCBORSet+ decode = decodeCBORSet++instance Serialise ShareNumber where+ decode = decodeShareNumber+ encode = encodeShareNumber++encodeShareNumber :: ShareNumber -> CSE.Encoding+encodeShareNumber (ShareNumber i) = CSE.encodeInteger i++decodeShareNumber :: CSD.Decoder s ShareNumber+decodeShareNumber = ShareNumber <$> CSD.decodeInteger++instance ToHttpApiData ShareNumber where+ toQueryParam = T.pack . show . toInteger++instance FromHttpApiData ShareNumber where+ parseUrlPiece t =+ case readMaybe $ T.unpack t of+ Nothing -> Left "failed to parse"+ Just i -> case shareNumber i of+ Nothing -> Left "number out of bounds"+ Just s -> Right s+ parseQueryParam = parseUrlPiece+ parseHeader bs =+ case parseUrlPiece <$> decodeUtf8' bs of+ Left err ->+ Left $+ T.concat+ [ "FromHttpApiData ShareNumber instance failed to decode number from header: "+ , T.pack . show $ err+ ]+ Right sn -> sn++instance ToJSONKey ShareNumber where+ toJSONKey = toJSONKeyText (T.pack . show)++shareNumber :: Integer -> Maybe ShareNumber+shareNumber n =+ if n < 0+ then Nothing+ else Just $ 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+ <> CSE.encodeBytes "maximum-immutable-share-size"+ <> CSE.encodeInteger maximumImmutableShareSize+ <> CSE.encodeBytes "maximum-mutable-share-size"+ <> CSE.encodeInteger maximumMutableShareSize+ <> CSE.encodeBytes "available-space"+ <> CSE.encodeInteger availableSpace++decodeMap :: (Ord k, Serialise k, Serialise v) => CSD.Decoder s (Map k v)+decodeMap = do+ lenM <- CSD.decodeMapLenOrIndef+ case lenM of+ Nothing -> Map.fromList <$> decodeMapIndef+ Just len -> Map.fromList <$> decodeMapOfLen len+ where+ decodeMapIndef = do+ atTheEnd <- CSD.decodeBreakOr+ if atTheEnd+ then pure []+ else do+ k <- decode+ v <- decode+ ((k, v) :) <$> decodeMapIndef++ decodeMapOfLen 0 = pure []+ decodeMapOfLen n = do+ k <- decode+ v <- decode+ ((k, v) :) <$> decodeMapOfLen (n - 1)++decodeVersion1Parameters :: CSD.Decoder s Version1Parameters+decodeVersion1Parameters = do+ m <- decodeMap+ case (Map.size m, map (`Map.lookup` m) keys) of+ (3, [Just availableSpace, Just maximumImmutableShareSize, Just maximumMutableShareSize]) ->+ pure Version1Parameters{..}+ _ -> fail "invalid encoding of Version1Parameters"+ where+ keys = ["available-space", "maximum-immutable-share-size", "maximum-mutable-share-size"] :: [B.ByteString]++instance Serialise Version1Parameters where+ encode = encodeVersion1Parameters+ decode = decodeVersion1Parameters++instance ToJSON Version1Parameters where+ toJSON = genericToJSON tahoeJSONOptions++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++decodeApplicationVersion :: CSD.Decoder s ApplicationVersion+decodeApplicationVersion = CSD.decodeBytes++encodeVersion :: Version -> CSE.Encoding+encodeVersion Version{..} =+ CSE.encodeMapLen 2+ <> encodeBytes "http://allmydata.org/tahoe/protocols/storage/v1"+ <> encodeVersion1Parameters parameters+ <> encodeBytes "application-version"+ <> encodeApplicationVersion applicationVersion++decodeVersion :: CSD.Decoder s Version+decodeVersion = do+ mapLen <- CSD.decodeMapLen+ case mapLen of+ 2 -> do+ -- Take care to handle either order of fields in the map.+ k1 <- CSD.decodeBytes+ case k1 of+ "http://allmydata.org/tahoe/protocols/storage/v1" -> do+ parameters <- decodeVersion1Parameters+ k2 <- CSD.decodeBytes+ case k2 of+ "application-version" -> do+ applicationVersion <- decodeApplicationVersion+ pure Version{..}+ _ -> fail "decodeVersion got bad input"+ "application-version" -> do+ applicationVersion <- decodeApplicationVersion+ k2 <- CSD.decodeBytes+ case k2 of+ "http://allmydata.org/tahoe/protocols/storage/v1" -> do+ parameters <- decodeVersion1Parameters+ pure Version{..}+ _ -> fail "decodeVersion got bad input"+ _ -> fail "decodeVersion got bad input"+ _ -> fail "decodeVersion got bad input"++instance Serialise Version where+ encode = encodeVersion+ decode = decodeVersion++instance ToJSON Version where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON Version where+ parseJSON = genericParseJSON tahoeJSONOptions++-- XXX Remove the secret fields from this record.+data AllocateBuckets = AllocateBuckets+ { renewSecret :: RenewSecret+ , cancelSecret :: CancelSecret+ , shareNumbers :: [ShareNumber]+ , allocatedSize :: Size+ }+ deriving (Show, Eq, Generic)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise AllocateBuckets++instance ToJSON AllocateBuckets where+ toJSON = genericToJSON tahoeJSONOptions++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++instance ToJSON AllocationResult where+ toJSON = genericToJSON tahoeJSONOptions++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++instance ToJSON CorruptionDetails where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON CorruptionDetails where+ parseJSON = genericParseJSON tahoeJSONOptions++instance FromHttpApiData ByteRanges where+ parseHeader bs =+ case parseByteRanges bs of+ Nothing -> Left "parse failed"+ Just br -> Right br++ parseUrlPiece _ = Left "Cannot parse ByteRanges from URL piece"+ parseQueryParam _ = Left "Cannot parse ByteRanges from query params"++instance ToHttpApiData ByteRanges where+ toHeader = renderByteRanges++ toUrlPiece _ = error "Cannot serialize ByteRanges to URL piece"+ toQueryParam _ = error "Cannot serialize ByteRanges to query params"++data LeaseSecret = Renew B.ByteString | Cancel B.ByteString | Upload B.ByteString | Write B.ByteString++instance FromHttpApiData LeaseSecret where+ parseHeader bs =+ do+ let [key, val] = B.split 32 bs+ case key of+ "lease-renew-secret" -> bimap T.pack Renew $ Base64.decode val+ "lease-cancel-secret" -> bimap T.pack Cancel $ Base64.decode val+ "upload-secret" -> bimap T.pack Upload $ Base64.decode val+ "write-enabler" -> bimap T.pack Write $ Base64.decode val+ _ -> Left $ T.concat ["Cannot interpret secret: ", T.pack . show $ key]++ parseUrlPiece _ = Left "Cannot parse LeaseSecret from URL piece"+ parseQueryParam _ = Left "Cannot parse LeaseSecret from query params"++instance FromHttpApiData [LeaseSecret] where+ -- XXX Consider whitespace?+ parseHeader =+ mapM parseHeader . B.split (fromIntegral $ fromEnum ',')++ parseUrlPiece _ = Left "Cannot parse [LeaseSecret] from URL piece"+ parseQueryParam _ = Left "Cannot parse [LeaseSecret] from query params"++instance ToHttpApiData LeaseSecret where+ toHeader (Renew bs) = "lease-renew-secret " <> Base64.encode bs+ toHeader (Cancel bs) = "lease-cancel-secret " <> Base64.encode bs+ toHeader (Upload bs) = "lease-cancel-secret " <> Base64.encode bs+ toHeader (Write bs) = "write-enabler " <> Base64.encode bs++ toUrlPiece _ = error "Cannot serialize LeaseSecret to URL piece"+ toQueryParam _ = error "Cannot serialize LeaseSecret to query params"++instance ToHttpApiData [LeaseSecret] where+ toHeader = B.intercalate "," . map toHeader+ toUrlPiece _ = error "Cannot serialize [LeaseSecret] to URL piece"+ toQueryParam _ = error "Cannot serialize [LeaseSecret] to query params"++-- GET .../version+-- Retrieve information about the server version and behavior+type GetVersion = "version" :> Get '[CBOR, JSON] Version++-- PUT .../lease/:storage_index+type RenewLease = "lease" :> Capture "storage_index" StorageIndex :> Header "X-Tahoe-Authorization" [LeaseSecret] :> Get '[CBOR, JSON] ()++-- POST .../immutable/:storage_index+-- Initialize a new immutable storage index+type CreateImmutableStorageIndex = "immutable" :> Capture "storage_index" StorageIndex :> ReqBody '[CBOR, JSON] AllocateBuckets :> PostCreated '[CBOR, JSON] AllocationResult++--+-- PUT .../immutable/:storage_index/:share_number+-- Write data for an immutable share to an allocated storage index+--+-- Note this accepts JSON to facilitate code generation by servant-py. This+-- is total nonsense and supplying JSON here will almost certainly break.+-- At some point hopefully we'll fix servant-py to not need this and then+-- fix the signature here.+type WriteImmutableShareData = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> ReqBody '[OctetStream, JSON] ShareData :> Header "Content-Range" ByteRanges :> PutCreated '[CBOR, JSON] ()++-- POST .../immutable/:storage_index/:share_number/corrupt+-- Advise the server of a corrupt share data+type AdviseCorrupt = Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> "corrupt" :> ReqBody '[CBOR, JSON] CorruptionDetails :> Post '[CBOR, JSON] ()++-- GET .../{mutable,immutable}/storage_index/shares+-- Retrieve the share numbers available for a storage index+type GetShareNumbers = Capture "storage_index" StorageIndex :> "shares" :> Get '[CBOR, JSON] (CBORSet ShareNumber)++--+-- GET .../v1/immutable/<storage_index:storage_index>/<int(signed=False):share_number>"+-- Read from an immutable storage index, possibly from multiple shares, possibly limited to certain ranges+type ReadImmutableShareData = "immutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> Header "Content-Range" ByteRanges :> Get '[OctetStream, JSON] ShareData++-- POST /v1/mutable/:storage_index/read-test-write+-- General purpose read-test-and-write operation.+type ReadTestWrite = "mutable" :> Capture "storage_index" StorageIndex :> "read-test-write" :> ReqBody '[CBOR, JSON] ReadTestWriteVectors :> Post '[CBOR, JSON] ReadTestWriteResult++-- GET /v1/mutable/:storage_index/:share_number+-- Read from a mutable storage index+type ReadMutableShareData = "mutable" :> Capture "storage_index" StorageIndex :> Capture "share_number" ShareNumber :> Header "Content-Range" ByteRanges :> Get '[OctetStream, JSON] ShareData++type StorageAPI =+ "storage"+ :> "v1"+ :> ( GetVersion+ :<|> RenewLease+ -- Immutables+ :<|> CreateImmutableStorageIndex+ :<|> WriteImmutableShareData+ :<|> ReadImmutableShareData+ :<|> "immutable" :> GetShareNumbers+ :<|> "immutable" :> AdviseCorrupt+ -- Mutables+ :<|> ReadTestWrite+ :<|> ReadMutableShareData+ :<|> "mutable" :> GetShareNumbers+ :<|> "mutable" :> AdviseCorrupt+ )++type ReadResult = Map ShareNumber [ShareData]++data ReadVectors = ReadVectors+ { shares :: [ShareNumber]+ , readVectors :: [ReadVector]+ }+ deriving (Show, Eq, Generic)++instance ToJSON ReadVectors where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON ReadVectors where+ parseJSON = genericParseJSON tahoeJSONOptions++data ReadTestWriteResult = ReadTestWriteResult+ { success :: Bool+ , readData :: ReadResult+ }+ deriving (Show, Eq, Generic)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise ReadTestWriteResult++instance ToJSON ReadTestWriteResult where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON ReadTestWriteResult where+ parseJSON = genericParseJSON tahoeJSONOptions++data ReadTestWriteVectors = ReadTestWriteVectors+ { secrets :: SlotSecrets+ , testWriteVectors :: Map ShareNumber TestWriteVectors+ , readVector :: [ReadVector]+ }+ deriving (Show, Eq, Generic)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise ReadTestWriteVectors++instance ToJSON ReadTestWriteVectors where+ toJSON = genericToJSON tahoeJSONOptions++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++instance ToJSON ReadVector where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON ReadVector where+ parseJSON = genericParseJSON tahoeJSONOptions++data TestWriteVectors = TestWriteVectors+ { test :: [TestVector]+ , write :: [WriteVector]+ }+ deriving (Show, Eq, Generic, ToJSON, FromJSON)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise TestWriteVectors++-- 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)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise WriteVector++-- XXX These fields moved to an HTTP Header, this type is probably not useful+-- anymore?+data SlotSecrets = SlotSecrets+ { writeEnabler :: WriteEnablerSecret+ , leaseRenew :: LeaseRenewSecret+ , leaseCancel :: LeaseCancelSecret+ }+ deriving (Show, Eq, Generic)++-- XXX This derived instance is surely not compatible with Tahoe-LAFS.+instance Serialise SlotSecrets++instance ToJSON SlotSecrets where+ toJSON = genericToJSON tahoeJSONOptions++instance FromJSON SlotSecrets where+ parseJSON = genericParseJSON tahoeJSONOptions++type WriteEnablerSecret = String+type LeaseRenewSecret = String+type LeaseCancelSecret = String++api :: Proxy StorageAPI+api = Proxy
+ src/TahoeLAFS/Storage/APIDocs.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module TahoeLAFS.Storage.APIDocs where++import Prelude hiding (+ Eq,+ )++import Data.Bits (+ shiftL,+ )++import Data.Map (+ Map,+ fromList,+ )++import Servant (+ Capture (..),+ Optional,+ QueryParams,+ )++import Servant.Docs (+ DocCapture (DocCapture),+ DocQueryParam (DocQueryParam),+ ParamKind (List, Normal),+ ToCapture (toCapture),+ ToParam (toParam),+ ToSample (toSamples),+ samples,+ singleSample,+ )++import TahoeLAFS.Storage.API (+ AllocateBuckets (AllocateBuckets),+ AllocationResult (AllocationResult),+ ApplicationVersion,+ CorruptionDetails (CorruptionDetails),+ Offset,+ ReadResult,+ ReadTestWriteResult (ReadTestWriteResult),+ ReadTestWriteVectors (ReadTestWriteVectors),+ ReadVector,+ ShareData,+ ShareNumber (ShareNumber),+ SlotSecrets (SlotSecrets),+ StorageIndex,+ TestOperator (Eq),+ TestVector (TestVector),+ TestWriteVectors (TestWriteVectors),+ Version (Version),+ Version1Parameters (Version1Parameters),+ WriteVector (WriteVector),+ leaseCancelSecretLength,+ leaseRenewSecretLength,+ renewSecretLength,+ writeEnablerSecretLength,+ )++instance ToCapture (Capture "storage_index" StorageIndex) where+ toCapture _ = DocCapture "storage index" "(hex string) a storage index to use to address the data"++instance ToCapture (Capture "share_number" ShareNumber) where+ toCapture _ = DocCapture "share number" "(integer) a share number to use to address a particular share"++instance ToParam (QueryParams "share_number" ShareNumber) where+ toParam _ = DocQueryParam "share_number" [] "(integer) a share number to use to address a particular share" List++instance ToParam (QueryParams "offset" Integer) where+ toParam _ = DocQueryParam "offset" [] "(integer) offset into a share to read or write" List++instance ToParam (QueryParams "size" Integer) where+ toParam _ = DocQueryParam "size" [] "(integer) number of bytes of a share to read" List++instance ToSample ReadResult where+ toSamples _ = singleSample mempty++instance ToSample Version where+ toSamples _ =+ singleSample $+ Version (Version1Parameters (1 `shiftL` 16) (2 `shiftL` 32) (2 `shiftL` 64)) "blub version??"++instance ToSample AllocateBuckets where+ toSamples _ =+ singleSample+ ( AllocateBuckets+ (example renewSecretLength "a")+ (example renewSecretLength "b")+ [ShareNumber 1, ShareNumber 3]+ 1024+ )++instance ToSample AllocationResult where+ toSamples _ =+ singleSample $ AllocationResult [ShareNumber 1] [ShareNumber 3]++instance ToSample ShareData where+ toSamples _ =+ singleSample "abcdefgh"++instance ToSample () where+ toSamples _ = singleSample ()++instance ToSample CorruptionDetails where+ toSamples _ = singleSample $ CorruptionDetails "sha256 mismatch maybe?"++instance ToSample ShareNumber where+ toSamples _ = samples [ShareNumber 0, ShareNumber 3]++instance ToSample ReadTestWriteVectors where+ toSamples _ =+ singleSample $+ ReadTestWriteVectors+ (SlotSecrets (example writeEnablerSecretLength "c") (example leaseRenewSecretLength "d") (example leaseCancelSecretLength "e"))+ sampleTestWriteVectors+ sampleReadVector++instance ToSample ReadTestWriteResult where+ toSamples _ =+ singleSample $+ ReadTestWriteResult True sampleReadResult++sampleTestWriteVectors :: Map ShareNumber TestWriteVectors+sampleTestWriteVectors =+ fromList+ [(ShareNumber 0, TestWriteVectors [TestVector 32 33 Eq "x"] [WriteVector 32 "y"])]++sampleReadVector :: [ReadVector]+sampleReadVector = mempty++sampleReadResult :: ReadResult+sampleReadResult = mempty++example :: Int -> [a] -> [a]+example n s = concat $ replicate n s
+ src/TahoeLAFS/Storage/Backend.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds #-}++module TahoeLAFS.Storage.Backend (+ Backend (..),+ ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+ writeMutableShare,+) where++import Control.Exception (+ Exception,+ throw,+ )++import Data.Map.Strict (+ fromList,+ )++import qualified Data.Set as Set+import Network.HTTP.Types (+ ByteRanges,+ )+import TahoeLAFS.Storage.API (+ AllocateBuckets,+ AllocationResult,+ CBOR,+ CBORSet (..),+ CorruptionDetails,+ LeaseSecret,+ Offset,+ QueryRange,+ ReadResult,+ ReadTestWriteResult (..),+ ReadTestWriteVectors (..),+ ShareData,+ ShareNumber,+ Size,+ SlotSecrets,+ StorageIndex,+ TestWriteVectors (..),+ Version,+ WriteVector (..),+ )++data ImmutableShareAlreadyWritten = ImmutableShareAlreadyWritten+ deriving (Show)+instance Exception ImmutableShareAlreadyWritten++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 -> AllocateBuckets -> IO AllocationResult++ -- May throw ImmutableShareAlreadyWritten+ writeImmutableShare :: b -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()+ adviseCorruptImmutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()+ getImmutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)+ readImmutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData++ createMutableStorageIndex :: b -> StorageIndex -> AllocateBuckets -> IO AllocationResult+ readvAndTestvAndWritev :: b -> StorageIndex -> ReadTestWriteVectors -> IO ReadTestWriteResult+ readMutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData+ getMutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)+ adviseCorruptMutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()++writeMutableShare ::+ Backend b =>+ b ->+ SlotSecrets ->+ StorageIndex ->+ ShareNumber ->+ ShareData ->+ Maybe ByteRanges ->+ IO ()+writeMutableShare b secrets storageIndex shareNumber shareData Nothing = do+ let testWriteVectors =+ fromList+ [+ ( shareNumber+ , TestWriteVectors+ { test = []+ , write =+ [ WriteVector+ { writeOffset = 0+ , shareData = shareData+ }+ ]+ }+ )+ ]+ let vectors =+ ReadTestWriteVectors+ { secrets = secrets+ , testWriteVectors = testWriteVectors+ , readVector = mempty+ }+ result <- readvAndTestvAndWritev b storageIndex vectors+ if success result+ then return ()+ else throw WriteRefused+writeMutableShare _ _ _ _ _ _ = error "writeMutableShare got bad input"++data WriteRefused = WriteRefused deriving (Show, Eq)+instance Exception WriteRefused
+ src/TahoeLAFS/Storage/Backend/Filesystem.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module TahoeLAFS.Storage.Backend.Filesystem (+ FilesystemBackend (FilesystemBackend),+ storageStartSegment,+ partitionM,+ pathOfShare,+ incomingPathOf,+) where++import Prelude hiding (+ readFile,+ writeFile,+ )++import Data.ByteString (+ hPut,+ readFile,+ writeFile,+ )+import qualified Data.Set as Set+import Network.HTTP.Types (+ ByteRanges,+ )++import Control.Exception (+ throwIO,+ tryJust,+ )++import Data.Maybe (+ mapMaybe,+ )++import Data.Map.Strict (+ fromList,+ toList,+ )++import System.IO (+ Handle,+ IOMode (ReadWriteMode),+ SeekMode (AbsoluteSeek),+ hSeek,+ withBinaryFile,+ )+import System.IO.Error (+ isDoesNotExistError,+ )++import System.FilePath (+ takeDirectory,+ (</>),+ )++import System.Directory (+ createDirectoryIfMissing,+ doesPathExist,+ listDirectory,+ renameFile,+ )++import TahoeLAFS.Storage.API (+ AllocateBuckets (..),+ AllocationResult (..),+ CBORSet (..),+ Offset,+ QueryRange,+ ReadTestWriteResult (ReadTestWriteResult, readData, success),+ ReadTestWriteVectors (ReadTestWriteVectors),+ ShareData,+ ShareNumber,+ StorageIndex,+ TestWriteVectors (write),+ Version (..),+ Version1Parameters (..),+ WriteVector (WriteVector),+ shareNumber,+ )++import qualified TahoeLAFS.Storage.API as Storage++import TahoeLAFS.Storage.Backend (+ Backend (..),+ ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+ )++data FilesystemBackend = FilesystemBackend FilePath+ deriving (Show)++versionString :: Storage.ApplicationVersion+versionString = "tahoe-lafs (gbs) 0.1.0"++-- Copied from the Python implementation. Kind of arbitrary.+maxMutableShareSize :: Storage.Size+maxMutableShareSize = 69105 * 1000 * 1000 * 1000 * 1000++-- storage/+-- storage/shares/incoming+-- incoming/ holds temp dirs named $START/$STORAGEINDEX/$SHARENUM which will+-- be moved to storage/shares/$START/$STORAGEINDEX/$SHARENUM upon success+-- storage/shares/$START/$STORAGEINDEX+-- storage/shares/$START/$STORAGEINDEX/$SHARENUM++-- Where "$START" denotes the first 10 bits worth of $STORAGEINDEX (that's 2+-- base-32 chars).++instance Backend FilesystemBackend where+ version (FilesystemBackend path) = do+ -- Hard-code some arbitrary amount of space. There is a statvfs+ -- package that can inspect the system and tell us a more correct+ -- answer but it is somewhat unmaintained and fails to build in some+ -- important environments.+ let available = 1_000_000_000+ return+ Version+ { applicationVersion = versionString+ , parameters =+ Version1Parameters+ { maximumImmutableShareSize = available+ , maximumMutableShareSize = maxMutableShareSize+ , -- TODO: Copy the "reserved space" feature of the Python+ -- implementation.+ availableSpace = available+ }+ }++ createImmutableStorageIndex :: FilesystemBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult+ createImmutableStorageIndex backend storageIndex params = do+ let exists = haveShare backend storageIndex+ (alreadyHave, allocated) <- partitionM exists (shareNumbers params)+ allocatev backend storageIndex allocated+ return+ AllocationResult+ { alreadyHave = alreadyHave+ , allocated = allocated+ }++ -- TODO Handle ranges.+ -- TODO Make sure the share storage was allocated.+ -- TODO Don't allow target of rename to exist.+ -- TODO Concurrency+ writeImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()+ writeImmutableShare (FilesystemBackend root) storageIndex shareNumber' shareData Nothing = do+ alreadyHave <- haveShare (FilesystemBackend root) storageIndex shareNumber'+ if alreadyHave+ then throwIO ImmutableShareAlreadyWritten+ else do+ let finalSharePath = pathOfShare root storageIndex shareNumber'+ let incomingSharePath = incomingPathOf root storageIndex shareNumber'+ writeFile incomingSharePath shareData+ let createParents = True+ createDirectoryIfMissing createParents $ takeDirectory finalSharePath+ renameFile incomingSharePath finalSharePath++ getImmutableShareNumbers :: FilesystemBackend -> StorageIndex -> IO (CBORSet ShareNumber)+ getImmutableShareNumbers (FilesystemBackend root) storageIndex = do+ let storageIndexPath = pathOfStorageIndex root storageIndex+ storageIndexChildren <-+ tryJust (Just . isDoesNotExistError) $ listDirectory storageIndexPath+ let sharePaths =+ case storageIndexChildren of+ Left _ -> []+ Right children -> children+ return $ CBORSet . Set.fromList $ mapMaybe (shareNumber . read) sharePaths++ -- TODO Handle ranges.+ -- TODO Make sure the share storage was allocated.+ readImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO Storage.ShareData+ readImmutableShare (FilesystemBackend root) storageIndex shareNum _qr =+ let _storageIndexPath = pathOfStorageIndex root storageIndex+ readShare = readFile . pathOfShare root storageIndex+ in readShare shareNum++ createMutableStorageIndex = createImmutableStorageIndex++ getMutableShareNumbers = getImmutableShareNumbers++ readvAndTestvAndWritev+ (FilesystemBackend root)+ storageIndex+ (ReadTestWriteVectors _secrets testWritev _readv) = do+ -- TODO implement readv and testv parts. implement secrets part.+ mapM_ (applyWriteVectors root storageIndex) $ toList testWritev+ return+ ReadTestWriteResult+ { success = True+ , readData = mempty+ }+ where+ applyWriteVectors ::+ FilePath ->+ StorageIndex ->+ (ShareNumber, TestWriteVectors) ->+ IO ()+ applyWriteVectors _root _storageIndex (shareNumber', testWriteVectors) =+ mapM_ (applyShareWrite root storageIndex shareNumber') (write testWriteVectors)++ applyShareWrite ::+ FilePath ->+ StorageIndex ->+ ShareNumber ->+ WriteVector ->+ IO ()+ applyShareWrite _root _storageIndex shareNumber' (WriteVector offset shareData) =+ let sharePath = pathOfShare root storageIndex shareNumber'+ createParents = True+ in do+ createDirectoryIfMissing createParents $ takeDirectory sharePath+ withBinaryFile sharePath ReadWriteMode (writeAtPosition offset shareData)+ where+ writeAtPosition ::+ Offset ->+ ShareData ->+ Handle ->+ IO ()+ writeAtPosition _offset shareData' handle = do+ hSeek handle AbsoluteSeek offset+ hPut handle shareData'++-- Does the given backend have the complete share indicated?+haveShare ::+ FilesystemBackend -> -- The backend to check+ StorageIndex -> -- The storage index the share belongs to+ ShareNumber -> -- The number of the share+ IO Bool -- True if it has the share, False otherwise.+haveShare (FilesystemBackend path) storageIndex shareNumber' =+ doesPathExist $ pathOfShare path storageIndex shareNumber'++pathOfStorageIndex ::+ FilePath -> -- The storage backend root path+ StorageIndex -> -- The storage index to consider+ FilePath -- The path to the directory containing shares for the+ -- storage index.+pathOfStorageIndex root storageIndex =+ root </> "shares" </> storageStartSegment storageIndex </> storageIndex++pathOfShare :: FilePath -> StorageIndex -> ShareNumber -> FilePath+pathOfShare root storageIndex shareNumber' =+ pathOfStorageIndex root storageIndex </> show (Storage.toInteger shareNumber')++incomingPathOf :: FilePath -> StorageIndex -> ShareNumber -> FilePath+incomingPathOf root storageIndex shareNumber' =+ root </> "shares" </> "incoming" </> storageStartSegment storageIndex </> storageIndex </> show (Storage.toInteger shareNumber')++storageStartSegment :: StorageIndex -> FilePath+storageStartSegment [] = fail "illegal short storage index"+storageStartSegment [_] = storageStartSegment []+storageStartSegment (a : b : _) = [a, b]++-- Create a space to write data for an incoming share.+allocate ::+ FilesystemBackend ->+ StorageIndex ->+ ShareNumber ->+ IO ()+allocate backend storageIndex shareNumber' =+ allocatev backend storageIndex [shareNumber']++-- Create spaces to write data for several incoming shares.+allocatev ::+ FilesystemBackend ->+ StorageIndex ->+ [ShareNumber] ->+ IO ()+allocatev _backend _storageIndex [] = return ()+allocatev (FilesystemBackend root) storageIndex (shareNumber : rest) =+ let sharePath = incomingPathOf root storageIndex shareNumber+ shareDirectory = takeDirectory sharePath+ createParents = True+ in do+ createDirectoryIfMissing createParents shareDirectory+ writeFile sharePath ""+ allocatev (FilesystemBackend root) storageIndex rest+ return ()++partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM pred' items = do+ (yes, no) <- partitionM' pred' items [] []+ -- re-reverse them to maintain input order+ return (reverse yes, reverse no)+ where+ partitionM' _ [] yes no = return (yes, no)+ partitionM' pred'' (item : rest) yes no = do+ result <- pred'' item+ if result+ then partitionM' pred'' rest (item : yes) no+ else partitionM' pred'' rest yes (item : no)
+ src/TahoeLAFS/Storage/Backend/Memory.hs view
@@ -0,0 +1,198 @@+module TahoeLAFS.Storage.Backend.Memory (+ MemoryBackend (MemoryBackend),+ memoryBackend,+) where++import Prelude hiding (+ lookup,+ map,+ )++import Network.HTTP.Types (+ ByteRanges,+ )++import Control.Exception (+ throwIO,+ )+import Data.Maybe (fromMaybe)++import Data.IORef (+ IORef,+ atomicModifyIORef',+ modifyIORef,+ newIORef,+ readIORef,+ )+import Data.Map.Strict (+ Map,+ adjust,+ filterWithKey,+ fromList,+ insert,+ keys,+ lookup,+ map,+ toList,+ )+import qualified Data.Set as Set++import TahoeLAFS.Storage.API (+ AllocateBuckets,+ AllocationResult (..),+ CBORSet (..),+ CorruptionDetails,+ Offset,+ QueryRange,+ ReadResult,+ ReadTestWriteResult (..),+ ReadTestWriteVectors (..),+ ShareData,+ ShareNumber,+ Size,+ StorageIndex,+ TestWriteVectors (..),+ Version (..),+ Version1Parameters (..),+ WriteVector (..),+ shareNumbers,+ )++import TahoeLAFS.Storage.Backend (+ Backend (..),+ ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),+ )++type ShareStorage = Map StorageIndex (Map ShareNumber ShareData)+type BucketStorage = Map StorageIndex (Map ShareNumber (Size, ShareData))++data MemoryBackend = MemoryBackend+ { immutableShares :: IORef ShareStorage -- Completely written immutable shares+ , mutableShares :: IORef ShareStorage -- Completely written mutable shares+ , buckets :: IORef BucketStorage -- In-progress immutable share uploads+ }++instance Show MemoryBackend where+ show _ = "<MemoryBackend>"++instance Backend MemoryBackend where+ version backend = do+ totalSize <- totalShareSize backend+ return+ Version+ { applicationVersion = "(memory)"+ , parameters =+ Version1Parameters+ { maximumImmutableShareSize = 1024 * 1024 * 64+ , maximumMutableShareSize = 1024 * 1024 * 64+ , availableSpace = (1024 * 1024 * 1024) - totalSize+ }+ }++ createMutableStorageIndex :: MemoryBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult+ createMutableStorageIndex _backend _storageIndex params =+ return+ AllocationResult+ { alreadyHave = mempty+ , allocated = shareNumbers params+ }++ getMutableShareNumbers :: MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)+ getMutableShareNumbers backend storageIndex = do+ shares' <- readIORef $ mutableShares backend+ return $+ CBORSet . Set.fromList $+ maybe [] keys $+ lookup storageIndex shares'++ readvAndTestvAndWritev :: MemoryBackend -> StorageIndex -> ReadTestWriteVectors -> IO ReadTestWriteResult+ readvAndTestvAndWritev+ backend+ storageIndex+ (ReadTestWriteVectors _secrets testWritev _readv) = do+ -- TODO implement readv and testv parts. implement secrets part.+ let shares = mutableShares backend+ modifyIORef shares $ addShares storageIndex (shares' testWritev)+ return+ ReadTestWriteResult+ { success = True+ , readData = mempty+ }+ where+ shares' ::+ Map ShareNumber TestWriteVectors ->+ [(ShareNumber, ShareData)]+ shares' testWritevs =+ [ (shareNumber, shareData writev)+ | (shareNumber, testWritev') <- toList testWritevs+ , writev <- write testWritev'+ ]++ createImmutableStorageIndex :: MemoryBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult+ createImmutableStorageIndex _backend _idx params =+ return+ AllocationResult+ { alreadyHave = mempty+ , allocated = shareNumbers params+ }++ writeImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()+ writeImmutableShare backend storageIndex shareNumber shareData Nothing = do+ -- shares <- readIORef (immutableShares backend) -- XXX uh, is this right?!+ changed <- atomicModifyIORef' (immutableShares backend) $+ \shares ->+ case lookup storageIndex shares >>= lookup shareNumber of+ Just _ ->+ -- It is not allowed to write new data for an immutable share that+ -- has already been written.+ (shares, False)+ Nothing ->+ (addShares storageIndex [(shareNumber, shareData)] shares, True)+ if changed+ then return ()+ else throwIO ImmutableShareAlreadyWritten+ writeImmutableShare _ _ _ _ _ = error "writeImmutableShare got bad input"++ adviseCorruptImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()+ adviseCorruptImmutableShare _backend _ _ _ =+ return mempty++ getImmutableShareNumbers :: MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)+ getImmutableShareNumbers backend storageIndex = do+ shares' <- readIORef $ immutableShares backend+ return $ CBORSet . Set.fromList $ maybe [] keys $ lookup storageIndex shares'++ readImmutableShare :: MemoryBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData+ readImmutableShare backend storageIndex shareNum _qr = do+ shares' <- readIORef $ immutableShares backend+ let result = case lookup storageIndex shares' of+ Nothing -> mempty+ Just shares'' -> lookup shareNum shares''+ pure $ fromMaybe mempty result++totalShareSize :: MemoryBackend -> IO Size+totalShareSize backend = do+ imm <- readIORef $ immutableShares backend+ mut <- readIORef $ mutableShares backend+ let immSize = sum $ map length imm+ let mutSize = sum $ map length mut+ return $ toInteger $ immSize + mutSize++addShares :: StorageIndex -> [(ShareNumber, ShareData)] -> ShareStorage -> ShareStorage+addShares _storageIndex [] shareStorage = shareStorage+addShares storageIndex ((shareNumber, shareData) : rest) shareStorage =+ let added = case lookup storageIndex shareStorage of+ Nothing ->+ insert storageIndex (fromList [(shareNumber, shareData)]) shareStorage+ Just _shares ->+ adjust addShare' storageIndex shareStorage+ where+ addShare' = insert shareNumber shareData+ in addShares storageIndex rest added++memoryBackend :: IO MemoryBackend+memoryBackend = do+ immutableShares <- newIORef mempty+ mutableShares <- newIORef mempty+ buckets <- newIORef mempty+ return $ MemoryBackend immutableShares mutableShares buckets
+ src/TahoeLAFS/Storage/Backend/Null.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module TahoeLAFS.Storage.Backend.Null (+ NullBackend (NullBackend),+) where++import TahoeLAFS.Storage.API (+ AllocateBuckets,+ AllocationResult (..),+ ApplicationVersion,+ CBORSet (..),+ CorruptionDetails,+ Offset,+ QueryRange,+ ReadResult,+ ShareData,+ ShareNumber,+ Size,+ StorageIndex,+ Version (..),+ Version1Parameters (..),+ )++import qualified Data.Set as Set+import TahoeLAFS.Storage.Backend (+ Backend (..),+ )++data NullBackend = NullBackend+ deriving (Show)++instance Backend NullBackend where+ version NullBackend =+ return+ Version+ { applicationVersion = "(null)"+ , parameters =+ Version1Parameters+ { maximumImmutableShareSize = 0+ , maximumMutableShareSize = 0+ , availableSpace = 0+ }+ }++ createImmutableStorageIndex :: NullBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult+ createImmutableStorageIndex NullBackend _ _ =+ return+ AllocationResult+ { alreadyHave = mempty+ , allocated = mempty+ }++ writeImmutableShare NullBackend _ _ _ _ =+ return mempty++ adviseCorruptImmutableShare :: NullBackend -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()+ adviseCorruptImmutableShare NullBackend _ _ _ =+ return mempty++ getImmutableShareNumbers :: NullBackend -> StorageIndex -> IO (CBORSet ShareNumber)+ getImmutableShareNumbers NullBackend _ =+ return (CBORSet $ Set.fromList [])++ readImmutableShare :: NullBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData+ readImmutableShare NullBackend _ _ _ = mempty
+ src/TahoeLAFS/Storage/Client.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}++module TahoeLAFS.Storage.Client (+ -- General server info+ version,+ -- Mutable or immutable+ renewLease,+ -- Immutable operations+ createImmutableStorageIndex,+ writeImmutableShare,+ readImmutableShare,+ getImmutableShareNumbers,+ adviseCorruptImmutableShare,+ -- Mutable operations+ readTestWrite,+ readMutableShares,+ getMutableShareNumbers,+ adviseCorruptMutableShare,+) where++import Data.Proxy+import Servant+import Servant.Client (+ client,+ )+import TahoeLAFS.Storage.API (+ StorageAPI,+ )++newApi :: Proxy StorageAPI+newApi = Proxy+( version+ :<|> renewLease+ :<|> createImmutableStorageIndex+ :<|> writeImmutableShare+ :<|> readImmutableShare+ :<|> getImmutableShareNumbers+ :<|> adviseCorruptImmutableShare+ :<|> readTestWrite+ :<|> readMutableShares+ :<|> getMutableShareNumbers+ :<|> adviseCorruptMutableShare+ ) = client newApi
+ src/TahoeLAFS/Storage/Server.hs view
@@ -0,0 +1,158 @@+module TahoeLAFS.Storage.Server (+ StorageServerConfig (StorageServerConfig),+ app,+ main,+) where++import Control.Exception (+ Exception,+ throw,+ )+import Control.Monad.IO.Class (+ MonadIO,+ liftIO,+ )+import Data.Maybe (fromMaybe)++import TahoeLAFS.Storage.API (+ AllocateBuckets,+ AllocationResult (..),+ CBORSet (..),+ CorruptionDetails,+ LeaseSecret,+ Offset,+ QueryRange,+ ReadResult,+ ReadTestWriteResult (..),+ ReadTestWriteVectors,+ ShareData,+ ShareNumber,+ Size,+ StorageAPI,+ StorageIndex,+ Version (..),+ api,+ )++import qualified TahoeLAFS.Storage.Backend as Backend+import TahoeLAFS.Storage.Backend.Filesystem (+ FilesystemBackend (FilesystemBackend),+ )++import Servant (+ Handler,+ Server,+ serve,+ (:<|>) (..),+ )++import Network.HTTP.Types (+ ByteRange,+ ByteRanges,+ )++import Network.Wai (+ Application,+ )++import Network.Wai.Handler.Warp (+ Port,+ defaultSettings,+ runSettings,+ setPort,+ )++import Network.Wai.Handler.WarpTLS (+ runTLS,+ tlsSettings,+ )++version :: Backend.Backend b => b -> Handler Version+version backend =+ liftIO (Backend.version backend)++renewLease :: (MonadIO m, Backend.Backend b) => b -> StorageIndex -> Maybe [LeaseSecret] -> m ()+renewLease backend storageIndex secrets = liftIO (Backend.renewLease backend storageIndex (fromMaybe [] secrets))++createImmutableStorageIndex :: Backend.Backend b => b -> StorageIndex -> AllocateBuckets -> Handler AllocationResult+createImmutableStorageIndex backend storage_index params =+ liftIO (Backend.createImmutableStorageIndex backend storage_index params)++writeImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> Handler ()+writeImmutableShare backend storage_index share_number share_data content_ranges =+ liftIO (Backend.writeImmutableShare backend storage_index share_number share_data content_ranges)++adviseCorruptImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> CorruptionDetails -> Handler ()+adviseCorruptImmutableShare backend storage_index share_number details =+ liftIO (Backend.adviseCorruptImmutableShare backend storage_index share_number details)++getImmutableShareNumbers :: Backend.Backend b => b -> StorageIndex -> Handler (CBORSet ShareNumber)+getImmutableShareNumbers backend storage_index =+ liftIO (Backend.getImmutableShareNumbers backend storage_index)++readImmutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> QueryRange -> Handler ShareData+readImmutableShare backend storage_index share_number qr =+ -- TODO Need to return NO CONTENT if the result is empty.+ -- TODO Need to make sure content-range is set in the header otherwise+ liftIO (Backend.readImmutableShare backend storage_index share_number qr)++createMutableStorageIndex :: Backend.Backend b => b -> StorageIndex -> AllocateBuckets -> Handler AllocationResult+createMutableStorageIndex backend storage_index params =+ liftIO (Backend.createMutableStorageIndex backend storage_index params)++readvAndTestvAndWritev :: Backend.Backend b => b -> StorageIndex -> ReadTestWriteVectors -> Handler ReadTestWriteResult+readvAndTestvAndWritev backend storage_index vectors =+ liftIO (Backend.readvAndTestvAndWritev backend storage_index vectors)++readMutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> QueryRange -> Handler ShareData+readMutableShare backend storage_index share_numbers params =+ liftIO (Backend.readMutableShare backend storage_index share_numbers params)++getMutableShareNumbers :: Backend.Backend b => b -> StorageIndex -> Handler (CBORSet ShareNumber)+getMutableShareNumbers backend storage_index =+ liftIO (Backend.getMutableShareNumbers backend storage_index)++adviseCorruptMutableShare :: Backend.Backend b => b -> StorageIndex -> ShareNumber -> CorruptionDetails -> Handler ()+adviseCorruptMutableShare backend storage_index share_number details =+ liftIO (Backend.adviseCorruptMutableShare backend storage_index share_number details)++data MisconfiguredTLS = MisconfiguredTLS+ deriving (Show)+instance Exception MisconfiguredTLS++data StorageServerConfig = StorageServerConfig+ { storagePath :: FilePath+ , listenPort :: Port+ , certificate :: Maybe FilePath+ , key :: Maybe FilePath+ }+ deriving (Show, Eq)++app :: Backend.Backend b => b -> Application+app backend =+ serve api storageServer+ where+ storageServer :: Server StorageAPI+ storageServer =+ version backend+ :<|> renewLease backend+ :<|> createImmutableStorageIndex backend+ :<|> writeImmutableShare backend+ :<|> readImmutableShare backend+ :<|> getImmutableShareNumbers backend+ :<|> adviseCorruptImmutableShare backend+ :<|> readvAndTestvAndWritev backend+ :<|> readMutableShare backend+ :<|> getMutableShareNumbers backend+ :<|> adviseCorruptMutableShare backend++main :: StorageServerConfig -> IO ()+main config =+ run $ app (FilesystemBackend $ storagePath config)+ where+ settings = setPort (listenPort config) defaultSettings+ run a =+ case (certificate config, key config) of+ (Nothing, Nothing) -> runSettings settings a+ (Just c, Just k) -> runTLS (tlsSettings c k) settings a+ _ -> throw MisconfiguredTLS
+ tahoe-great-black-swamp.cabal view
@@ -0,0 +1,200 @@+cabal-version: 2.4+name: tahoe-great-black-swamp+version: 0.3.0.1+build-type: Simple+synopsis: An implementation of the "Great Black Swamp" LAFS protocol.+description:+ This package implements the recently proposed "Great Black Swamp" Least+ Authority File Store protocol from the Tahoe-LAFS project. It also includes+ pieces of a storage server and client implementation based on that protocol.++license: BSD-3-Clause+license-file: LICENSE+author: Jean-Paul Calderone and others+maintainer: exarkun@twistedmatrix.com+copyright: 2018-2023 The Authors+category:+ Cryptography+ , Distributed Computing+ , Filesystem+ , Network+ , Network APIs+ , Security+ , Service+ , Storage+ , Web++extra-source-files:+ ChangeLog.md+ README.rst++homepage:+ https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp++bug-reports:+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues++source-repository head+ type: git+ location:+ gitlab@whetstone.private.storage:privatestorage/tahoe-great-black-swamp.git++common executable-opts+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++common common-opts+ default-extensions:+ GADTs+ InstanceSigs+ LambdaCase+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StrictData+ TupleSections+ TypeApplications++ ghc-options: -Wall+ build-depends:+ , aeson >=1.4.7 && <2.2+ , async >=2.2.2 && <2.3+ , base >=4.7 && <5+ , binary >=0.8.6 && <0.9+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.6.0.1 && <0.7+ , deriving-aeson >=0.2.6 && <0.3+ , directory >=1.3.3 && <1.4+ , filepath >=1.4.2 && <1.5+ , foldl >=1.4.6 && <1.5+ , http-types >=0.12.3 && <0.13+ , primitive >=0.7.0.1 && <0.8+ , safe-exceptions >=0.1.7.1 && <0.2+ , text >=1.2.3.1 && <1.3+ , unordered-containers >=0.2.10 && <0.3+ , vector >=0.12.1.2 && <0.13++ default-language: Haskell2010++library+ import: common-opts+ hs-source-dirs: src+ exposed-modules:+ TahoeLAFS.Storage.API+ TahoeLAFS.Storage.APIDocs+ TahoeLAFS.Storage.Backend+ TahoeLAFS.Storage.Backend.Filesystem+ TahoeLAFS.Storage.Backend.Memory+ TahoeLAFS.Storage.Backend.Null+ TahoeLAFS.Storage.Client+ TahoeLAFS.Storage.Server++ other-modules: TahoeLAFS.Internal.ServantUtil+ default-language: Haskell2010+ build-depends:+ , base >=4.7 && <5+ , base64-bytestring >=1.0.0.3 && <1.3+ , cborg >=0.2.4 && <0.3+ , cborg-json >=0.2.2 && <0.3+ , http-api-data >=0.4.1.1 && <0.7+ , http-media >=0.8 && <0.9+ , 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+ , 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++-- executable gbs-generate-apidocs+-- hs-source-dirs: generate-apidocs+-- main-is: Main.hs+-- default-language: Haskell2010+-- build-depends: base+-- , servant-docs+-- , pandoc+-- , data-default+-- , blaze-html+-- , tahoe-great-black-swamp+-- , text++executable client-test+ import: common-opts+ hs-source-dirs: client-test+ main-is: Main.hs+ default-language: Haskell2010+ build-depends:+ , aeson >=1.4.7 && <2.2+ , base >=4.7 && <5+ , base32 >=0.2.1 && <0.3+ , base64-bytestring >=1.0.0.3 && <1.3+ , bytestring >=0.10.8.2 && <0.11+ , cborg >=0.2.4 && <0.3+ , connection >=0.3.1 && <0.4+ , containers >=0.6.0.1 && <0.7+ , http-client >=0.6.4.1 && <0.8+ , http-client-tls >=0.3.5.3 && <0.4+ , http-types >=0.12.3 && <0.13+ , megaparsec >=8.0 && <9.3+ , network-uri >=2.6.3 && <2.7+ , serialise >=0.2.3 && <0.3+ , servant >=0.16.2 && <0.21+ , servant-client >=0.16.0.1 && <0.21+ , tahoe-chk >=0.1 && <0.2+ , tahoe-great-black-swamp+ , text >=1.2.3.1 && <1.3++executable gbs-lafs-storage-server+ hs-source-dirs: app+ main-is: Main.hs+ default-language: Haskell2010+ build-depends:+ , base >=4.7 && <5+ , optparse-applicative >=0.15.1.0 && <0.19+ , tahoe-great-black-swamp+ , warp >=3.3.13 && <3.4++executable gbs-generate-clients+ hs-source-dirs: generate-clients+ main-is: Main.hs+ default-language: Haskell2010+ build-depends:+ , base >=4.7 && <5+ , filepath >=1.4.2 && <1.5+ , servant-js >=0.9.4.2 && <0.10+ , tahoe-great-black-swamp++test-suite http-tests+ import: common-opts+ import: executable-opts+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ CBORSpec+ HTTPSpec+ Lib+ MiscSpec+ SemanticSpec+ Spec++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ , base >=4.7 && <5+ , base32string >=0.9.1 && <0.10+ , cborg >=0.2.4 && <0.3+ , hspec <2.12+ , hspec-expectations <0.9+ , hspec-wai <0.12+ , QuickCheck <2.15+ , quickcheck-instances <0.4+ , serialise >=0.2.3 && <0.3+ , servant >=0.16.2 && <0.21+ , tahoe-great-black-swamp+ , temporary >=1.3 && <1.4+ , vector >=0.12.1.2 && <0.13+ , wai-extra >=3.0.29.2 && <3.2
+ test/CBORSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module CBORSpec (+ spec,+) where++import Codec.Serialise+import Data.Proxy++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Set as Set+import Servant.API+import TahoeLAFS.Storage.API+import Test.Hspec (+ Spec,+ describe,+ it,+ shouldBe,+ )+import Prelude hiding (+ toInteger,+ )++spec :: Spec+spec = do+ describe "encode decode" $ do+ it "round trips Version1Parameters" $+ deserialise (serialise testAV)+ `shouldBe` testAV+ it "round trips ApplicationVersion" $+ deserialise (serialise v1params) `shouldBe` v1params+ it "round trips Version" $+ deserialise (serialise aVersion) `shouldBe` aVersion+ describe "deserialise CBOR" $+ it "works with Tahoe CBOR" $+ deserialise tahoeVersion `shouldBe` aVersion+ describe "mimeUnrender CBOR Version" $+ it "gives the correct result" $ do+ (mimeUnrender (Proxy :: Proxy CBOR) tahoeVersion :: Either String Version) `shouldBe` (Right $ Version{parameters = Version1Parameters{maximumImmutableShareSize = 232660657664, maximumMutableShareSize = 69105000000000000, availableSpace = 232660657664}, applicationVersion = "tahoe-lafs/1.18.0.post908"})+ describe "CBOR round trip" $ do+ it "works for StorageIndex" $+ deserialise (serialise ("5" :: StorageIndex)) `shouldBe` ("5" :: StorageIndex)+ it "works for ShareNumber" $+ deserialise (serialise (ShareNumber 5)) `shouldBe` ShareNumber 5+ it "works for ReadResult" $+ deserialise (serialise readRes) `shouldBe` readRes+ it "works for CBORSet" $+ deserialise (serialise cborSet) `shouldBe` cborSet++readRes = "strict bytestring" :: BS.ByteString++cborSet = CBORSet (Set.fromList $ ShareNumber <$> [1, 2, 3])++testAV :: ApplicationVersion+testAV = "tahoe-lafs/1.18.0.post908"++v1params :: Version1Parameters+v1params = Version1Parameters 232660657664 69105000000000000 232660657664++aVersion :: Version+aVersion = Version v1params testAV++tahoeVersion :: BSL.ByteString+tahoeVersion = "\162X/http://allmydata.org/tahoe/protocols/storage/v1\163X\FSmaximum-immutable-share-size\ESC\NUL\NUL\NUL6+\167\230\NULX\SUBmaximum-mutable-share-size\ESC\NUL\245\130\161\161\&4\DLE\NULOavailable-space\ESC\NUL\NUL\NUL6+\167\230\NULSapplication-versionX\EMtahoe-lafs/1.18.0.post908"
+ test/HTTPSpec.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTPSpec (+ spec,+) where++import Prelude hiding (+ replicate,+ )++import qualified Data.Map.Strict as Map+import qualified Data.Vector as Vector+import GHC.Int (+ Int64,+ )++import Data.Aeson.Types (+ Value (Array, Number, String),+ )++import Data.Aeson (+ encode,+ )++import Data.ByteString (+ ByteString,+ )++import qualified Data.ByteString.Lazy as L++import Network.HTTP.Types.Method (+ methodGet,+ methodPost,+ methodPut,+ )++import Test.Hspec (+ Spec,+ describe,+ it,+ )++import Test.Hspec.Wai (+ WaiSession,+ matchBody,+ matchHeaders,+ request,+ shouldRespondWith,+ with,+ (<:>),+ )++import Test.Hspec.Wai.Matcher (+ bodyEquals,+ )++import Network.Wai.Test (+ SResponse,+ )++import TahoeLAFS.Storage.Backend.Null (+ NullBackend (NullBackend),+ )++import TahoeLAFS.Storage.Server (+ app,+ )++-- WaiSession changed incompatibly between hspec-wai 0.9.2 and 0.11.1. We+-- would like to work with both so just skip the explicit type signature here+-- (and below). ghc can figure it out.+--+-- getJSON :: ByteString -> WaiSession st SResponse+getJSON path =+ request+ methodGet+ path+ [("Accept", "application/json")]+ ""++-- postJSON :: ByteString -> L.ByteString -> WaiSession st SResponse+postJSON path body =+ request+ methodPost+ path+ [("Content-Type", "application/json"), ("Accept", "application/json")]+ body++-- putShare :: ByteString -> Int64 -> WaiSession st SResponse+putShare path size =+ request+ methodPut+ path+ [("Content-Type", "application/octet-stream"), ("Accept", "application/json")]+ (L.replicate size 0xdd)++allocateBucketsJSON :: L.ByteString+allocateBucketsJSON =+ encode $+ Map.fromList+ [ ("renew-secret" :: String, String "abcdefgh")+ , ("cancel-secret" :: String, String "ijklmnop")+ , ("share-numbers" :: String, Array (Vector.fromList [Number 1, Number 3, Number 5]))+ , ("allocated-size" :: String, Number 512)+ ]++allocateResultJSON :: L.ByteString+allocateResultJSON =+ encode $+ Map.fromList+ [ ("already-have" :: String, Array Vector.empty)+ , ("allocated" :: String, Array Vector.empty)+ ]++corruptionJSON :: L.ByteString+corruptionJSON =+ encode $+ Map.fromList+ [ ("reason" :: String, "foo and bar" :: String)+ ]++sharesResultJSON :: L.ByteString+-- Simple enough I won't go through Aeson here+sharesResultJSON = "[]"++readResultJSON :: L.ByteString+-- Simple, again.+readResultJSON = "{}"++spec :: Spec+spec = with (return $ app NullBackend) $+ describe "v1" $ do+ describe "GET /storage/v1/version" $ do+ it "responds with OK" $+ getJSON "/storage/v1/version" `shouldRespondWith` 200++ describe "POST /storage/v1/immutable/abcdefgh" $ do+ it "responds with CREATED" $+ postJSON+ "/storage/v1/immutable/abcdefgh"+ allocateBucketsJSON+ `shouldRespondWith` 201+ { -- TODO: ;charset=utf-8 is just an artifact of Servant, would be+ -- nice to turn it off and not assert it here.+ matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]+ , matchBody = bodyEquals allocateResultJSON+ }++ describe "PUT /storage/v1/immutable/abcdefgh/1" $ do+ it "responds with CREATED" $+ putShare "/storage/v1/immutable/abcdefgh/1" 512 `shouldRespondWith` 201++ describe "POST /storage/v1/immutable/abcdefgh/1/corrupt" $ do+ it "responds with OK" $+ postJSON+ "/storage/v1/immutable/abcdefgh/1/corrupt"+ corruptionJSON+ `shouldRespondWith` 200++ describe "GET /storage/v1/immutable/abcdefgh/shares" $ do+ it "responds with OK and a JSON list" $+ getJSON "/storage/v1/immutable/abcdefgh/shares"+ `shouldRespondWith` 200+ { matchBody = bodyEquals sharesResultJSON+ }++ describe "GET /storage/v1/immutable/abcdefgh/1" $ do+ it "responds with OK and an application/octet-stream of the share" $ do+ let req =+ request+ methodGet+ "/storage/v1/immutable/abcdefgh/1"+ [("Accept", "application/octet-stream")]+ ""+ req+ `shouldRespondWith` 200+ { matchBody = bodyEquals ""+ }
+ test/Lib.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Lib (+ gen10String,+ genStorageIndex,+ positiveIntegers,+ b32encode,+ b32decode,+) where++import Data.Word (+ Word8,+ )++import qualified Data.Base32String as Base32++import Data.ByteString (+ ByteString,+ pack,+ )++import qualified Data.Text as Text++import Test.QuickCheck (+ Arbitrary (arbitrary),+ Gen,+ suchThatMap,+ vectorOf,+ )++-- Get the Arbitrary ByteString instance.+import Test.QuickCheck.Instances.ByteString ()++import TahoeLAFS.Storage.API (+ ShareNumber,+ StorageIndex,+ shareNumber,+ )++gen10String :: Gen String+gen10String = vectorOf 10 arbitrary++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)++instance Arbitrary ShareNumber where+ arbitrary = suchThatMap positiveIntegers shareNumber++b32table :: ByteString+b32table = "abcdefghijklmnopqrstuvwxyz234567"++b32encode :: ByteString -> String+b32encode = Text.unpack . Base32.toText . Base32.fromBytes b32table++b32decode :: String -> ByteString+b32decode base32 =+ Base32.toBytes b32table $ Base32.fromText b32table $ Text.pack base32
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Test.Hspec.Runner (+ hspec,+ )++import Spec (+ spec,+ )++main :: IO ()+main = do+ hspec spec
+ test/MiscSpec.hs view
@@ -0,0 +1,115 @@+module MiscSpec (+ spec,+) where++import Prelude hiding (+ toInteger,+ )++import Text.Printf (+ printf,+ )++import Test.Hspec (+ Spec,+ describe,+ it,+ shouldBe,+ shouldNotBe,+ shouldSatisfy,+ )++import qualified Data.ByteString as BS++import Test.QuickCheck (+ Arbitrary (arbitrary),+ Gen,+ forAll,+ property,+ vectorOf,+ )++import TahoeLAFS.Storage.API (+ toInteger,+ )++-- We also get the Arbitrary ShareNumber instance from here.+import Lib (+ b32decode,+ b32encode,+ genStorageIndex,+ )++import TahoeLAFS.Storage.Backend.Filesystem (+ incomingPathOf,+ partitionM,+ pathOfShare,+ storageStartSegment,+ )++spec :: Spec+spec = do+ describe "partitionM" $+ it "handles empty lists" $+ partitionM (\e -> return True) ([] :: [(Integer, Integer)]) `shouldBe` (Just ([], []))++ describe "partitionM" $+ it "puts matching elements in the first list and non-matching in the second" $+ partitionM (\e -> return $ (e `mod` 2) == 0) [5, 5, 6, 7, 8, 8]+ `shouldBe` (Just ([6, 8, 8], [5, 5, 7]))++ describe "storageStartSegment" $+ it "returns a string of length 2" $+ property $+ forAll genStorageIndex (\storageIndex -> length (storageStartSegment storageIndex) `shouldBe` 2)++ describe "pathOfShare" $+ it "returns a path reflecting the storage index and share number" $+ property $+ forAll+ genStorageIndex+ ( \storageIndex shareNumber ->+ pathOfShare "/foo" storageIndex shareNumber+ `shouldBe` (printf "/foo/shares/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber))+ )++ describe "incomingPathOf" $+ it "returns a path reflecting the storage index and share number" $+ property $+ forAll+ genStorageIndex+ ( \storageIndex shareNumber ->+ incomingPathOf "/foo" storageIndex shareNumber+ `shouldBe` (printf "/foo/shares/incoming/%s/%s/%d" (take 2 storageIndex) storageIndex (toInteger shareNumber))+ )++ describe "incomingPathOf vs pathOfShare" $+ it "returns different paths" $+ property $+ forAll+ genStorageIndex+ ( \storageIndex shareNumber ->+ let path = pathOfShare "/foo" storageIndex shareNumber+ incoming = incomingPathOf "/foo" storageIndex shareNumber+ in path `shouldNotBe` incoming+ )++ describe "base32 round-trip" $+ it "b32encode and b32decode are inverses" $+ property $+ \bs -> (b32decode . b32encode) bs `shouldBe` bs++ describe "base32 alphabet" $+ it "encodes using only the base32 alphabet" $+ property $+ \bs -> b32encode bs `shouldSatisfy` (onlyContains "abcdefghijklmnopqrstuvwxyz234567")++ describe "size ratio" $+ it "encodes to a string no more than twice the length" $+ property $+ \bs -> b32encode bs `shouldSatisfy` (\base32 -> length base32 <= 2 * BS.length bs)++-- Does the second list contain only elements of the first list?+onlyContains :: (Eq a) => [a] -> [a] -> Bool+onlyContains xs [] = True+onlyContains xs (y : ys) = y `elem` xs && onlyContains xs ys
+ test/SemanticSpec.hs view
@@ -0,0 +1,337 @@+module SemanticSpec (+ spec,+) where++import Prelude hiding (+ lookup,+ toInteger,+ )++import Control.Monad (+ when,+ )++import Data.Bits (+ xor,+ )++import GHC.Word (+ Word8,+ )++import qualified Data.Set as Set++import System.Directory (+ removeDirectoryRecursive,+ )++import System.IO.Temp (+ createTempDirectory,+ getCanonicalTemporaryDirectory,+ )++import Test.Hspec (+ Spec,+ SpecWith,+ around,+ before,+ context,+ describe,+ it,+ shouldThrow,+ )+import Test.Hspec.Expectations (+ Selector,+ )++import Test.QuickCheck (+ Property,+ forAll,+ property,+ )++import Test.QuickCheck.Monadic (+ assert,+ monadicIO,+ pre,+ run,+ )++import Data.ByteString (+ ByteString,+ concat,+ length,+ map,+ )++import Data.List (+ sort,+ )++import TahoeLAFS.Storage.API (+ AllocateBuckets (AllocateBuckets),+ CBORSet (..),+ ShareData,+ ShareNumber,+ Size,+ SlotSecrets (..),+ StorageIndex,+ allocated,+ alreadyHave,+ toInteger,+ )++import TahoeLAFS.Storage.Backend (+ Backend (+ createImmutableStorageIndex,+ createMutableStorageIndex,+ getImmutableShareNumbers,+ getMutableShareNumbers,+ readImmutableShare,+ writeImmutableShare+ ),+ ImmutableShareAlreadyWritten,+ writeMutableShare,+ )++-- We also get the Arbitrary ShareNumber instance from here.+import Lib (+ genStorageIndex,+ )++import TahoeLAFS.Storage.Backend.Memory (+ MemoryBackend,+ memoryBackend,+ )++import TahoeLAFS.Storage.Backend.Filesystem (+ FilesystemBackend (FilesystemBackend),+ )++isUnique :: Ord a => [a] -> Bool+isUnique xs = Prelude.length xs == Prelude.length (Set.toList $ Set.fromList xs)++-- XXX null ?+hasElements :: [a] -> Bool+hasElements = not . null++permuteShare :: ByteString -> ShareNumber -> ByteString+permuteShare seed number =+ Data.ByteString.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++-- In the result of creating an immutable storage index, the sum of+-- ``alreadyHave`` and ``allocated`` equals ``shareNumbers`` from the input.+alreadyHavePlusAllocatedImm ::+ Backend b =>+ b -> -- The backend on which to operate+ StorageIndex -> -- The storage index to use+ [ShareNumber] -> -- The share numbers to allocate+ Size -> -- The size of each share+ Property+alreadyHavePlusAllocatedImm backend storageIndex shareNumbers size = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ result <- run $ createImmutableStorageIndex backend storageIndex $ AllocateBuckets "renew" "cancel" shareNumbers size+ when (alreadyHave result ++ allocated result /= shareNumbers) $+ fail+ ( show (alreadyHave result)+ ++ " ++ "+ ++ show (allocated result)+ ++ " /= "+ ++ show shareNumbers+ )++-- In the result of creating a mutable storage index, the sum of+-- ``alreadyHave`` and ``allocated`` equals ``shareNumbers`` from the input.+alreadyHavePlusAllocatedMut ::+ Backend b =>+ b -> -- The backend on which to operate+ StorageIndex -> -- The storage index to use+ [ShareNumber] -> -- The share numbers to allocate+ Size -> -- The size of each share+ Property+alreadyHavePlusAllocatedMut backend storageIndex shareNumbers size = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ result <- run $ createMutableStorageIndex backend storageIndex $ AllocateBuckets "renew" "cancel" shareNumbers size+ when (alreadyHave result ++ allocated result /= shareNumbers) $+ fail+ ( show (alreadyHave result)+ ++ " ++ "+ ++ show (allocated result)+ ++ " /= "+ ++ show shareNumbers+ )++-- The share numbers of immutable share data written to the shares of a given+-- storage index can be retrieved.+immutableWriteAndEnumerateShares ::+ Backend b =>+ b ->+ StorageIndex ->+ [ShareNumber] ->+ ByteString ->+ Property+immutableWriteAndEnumerateShares backend storageIndex shareNumbers shareSeed = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers+ let size = fromIntegral (Data.ByteString.length shareSeed)+ let allocate = AllocateBuckets "renew" "cancel" shareNumbers size+ _result <- run $ createImmutableStorageIndex backend storageIndex allocate+ run $ writeShares (writeImmutableShare backend storageIndex) (zip shareNumbers permutedShares)+ readShareNumbers <- run $ getImmutableShareNumbers backend storageIndex+ when (readShareNumbers /= (CBORSet . Set.fromList $ shareNumbers)) $+ fail (show readShareNumbers ++ " /= " ++ show shareNumbers)++-- Immutable share data written to the shares of a given storage index cannot+-- be rewritten by a subsequent writeImmutableShare operation.+immutableWriteAndRewriteShare ::+ Backend b =>+ b ->+ StorageIndex ->+ [ShareNumber] ->+ ByteString ->+ Property+immutableWriteAndRewriteShare backend storageIndex shareNumbers shareSeed = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ let size = fromIntegral (Data.ByteString.length shareSeed)+ let allocate = AllocateBuckets "renew" "cancel" shareNumbers size+ let aShareNumber = head shareNumbers+ let aShare = permuteShare shareSeed aShareNumber+ let write =+ writeImmutableShare backend storageIndex aShareNumber aShare Nothing+ run $ do+ _ <- createImmutableStorageIndex backend storageIndex allocate+ write+ write `shouldThrow` (const True :: Selector ImmutableShareAlreadyWritten)++-- Immutable share data written to the shares of a given storage index can be+-- retrieved verbatim and associated with the same share numbers as were+-- specified during writing.+immutableWriteAndReadShare ::+ Backend b =>+ b ->+ StorageIndex ->+ [ShareNumber] ->+ ByteString ->+ Property+immutableWriteAndReadShare backend storageIndex shareNumbers shareSeed = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers+ let size = fromIntegral (Data.ByteString.length shareSeed)+ let allocate = AllocateBuckets "renew" "cancel" shareNumbers size+ _result <- run $ createImmutableStorageIndex backend storageIndex allocate+ run $ writeShares (writeImmutableShare backend storageIndex) (zip shareNumbers permutedShares)+ readShares' <- run $ mapM (\sn -> readImmutableShare backend storageIndex sn Nothing) shareNumbers+ when (permutedShares /= readShares') $+ fail (show permutedShares ++ " /= " ++ show readShares')++-- The share numbers of mutable share data written to the shares of a given+-- storage index can be retrieved.+mutableWriteAndEnumerateShares ::+ Backend b =>+ b ->+ StorageIndex ->+ [ShareNumber] ->+ ByteString ->+ Property+mutableWriteAndEnumerateShares backend storageIndex shareNumbers shareSeed = monadicIO $ do+ pre (isUnique shareNumbers)+ pre (hasElements shareNumbers)+ let permutedShares = Prelude.map (permuteShare shareSeed) shareNumbers+ let size = fromIntegral (Data.ByteString.length shareSeed)+ let allocate = AllocateBuckets "renew" "cancel" shareNumbers size+ let nullSecrets =+ SlotSecrets+ { writeEnabler = ""+ , leaseRenew = ""+ , leaseCancel = ""+ }+ _result <- run $ createMutableStorageIndex backend storageIndex allocate+ run $ writeShares (writeMutableShare backend nullSecrets storageIndex) (zip shareNumbers permutedShares)+ (CBORSet readShareNumbers) <- run $ getMutableShareNumbers backend storageIndex+ when (readShareNumbers /= Set.fromList shareNumbers) $+ fail (show readShareNumbers ++ " /= " ++ show shareNumbers)++-- The specification for a storage backend.+storageSpec :: Backend b => SpecWith b+storageSpec =+ context "v1" $ do+ context "immutable" $ do+ describe "allocate a storage index" $+ it "accounts for all allocated share numbers" $ \backend ->+ property $+ forAll genStorageIndex (alreadyHavePlusAllocatedImm backend)++ context "write a share" $ do+ it "returns the share numbers that were written" $ \backend ->+ property $+ forAll genStorageIndex (immutableWriteAndEnumerateShares backend)++ it "returns the written data when requested" $ \backend ->+ property $+ forAll genStorageIndex (immutableWriteAndReadShare backend)++ it "cannot be written more than once" $ \backend ->+ property $+ forAll genStorageIndex (immutableWriteAndRewriteShare backend)++ context "mutable" $ do+ describe "allocate a storage index" $ do+ it "accounts for all allocated share numbers" $ \backend ->+ property $+ forAll genStorageIndex (alreadyHavePlusAllocatedMut backend)++ describe "write a share" $ do+ it "returns the share numbers that were written" $ \backend ->+ property $+ forAll genStorageIndex (mutableWriteAndEnumerateShares backend)++spec :: Spec+spec = do+ Test.Hspec.context "memory" $+ Test.Hspec.before memoryBackend storageSpec++ Test.Hspec.context "filesystem" $+ Test.Hspec.around (withBackend filesystemBackend) storageSpec++filesystemBackend :: IO FilesystemBackend+filesystemBackend = do+ FilesystemBackend <$> createTemporaryDirectory++createTemporaryDirectory :: IO FilePath+createTemporaryDirectory = do+ parent <- getCanonicalTemporaryDirectory+ createTempDirectory parent "gbs-semanticspec"++class Mess m where+ -- Cleanup resources belonging to m+ cleanup :: m -> IO ()++instance Mess FilesystemBackend where+ cleanup (FilesystemBackend path) = removeDirectoryRecursive path++instance Mess MemoryBackend where+ cleanup _ = return ()++withBackend :: (Mess b, Backend b) => IO b -> ((b -> IO ()) -> IO ())+withBackend b action = do+ backend <- b+ action backend+ cleanup backend
+ test/Spec.hs view
@@ -0,0 +1,15 @@+module Spec where++import Test.Hspec++import qualified CBORSpec as C+import qualified HTTPSpec as H+import qualified MiscSpec as M+import qualified SemanticSpec as S++spec :: Spec+spec = do+ parallel $ describe "HTTP" H.spec+ parallel $ describe "Misc" M.spec+ parallel $ describe "Semantic" S.spec+ parallel $ describe "CBOR" C.spec