diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -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 + } + } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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.") diff --git a/client-test/Main.hs b/client-test/Main.hs new file mode 100644 --- /dev/null +++ b/client-test/Main.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | Demonstrate the use of some GBS client APIs. + + Usage: + + client-test +-} +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 diff --git a/generate-clients/Main.hs b/generate-clients/Main.hs new file mode 100644 --- /dev/null +++ b/generate-clients/Main.hs @@ -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") diff --git a/src/TahoeLAFS/Internal/ServantUtil.hs b/src/TahoeLAFS/Internal/ServantUtil.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Internal/ServantUtil.hs @@ -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 + ) diff --git a/src/TahoeLAFS/Storage/API.hs b/src/TahoeLAFS/Storage/API.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/API.hs @@ -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//" +-- 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 diff --git a/src/TahoeLAFS/Storage/APIDocs.hs b/src/TahoeLAFS/Storage/APIDocs.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/APIDocs.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Backend.hs b/src/TahoeLAFS/Storage/Backend.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Backend.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Backend/Filesystem.hs b/src/TahoeLAFS/Storage/Backend/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Backend/Filesystem.hs @@ -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) diff --git a/src/TahoeLAFS/Storage/Backend/Memory.hs b/src/TahoeLAFS/Storage/Backend/Memory.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Backend/Memory.hs @@ -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 _ = "" + +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 diff --git a/src/TahoeLAFS/Storage/Backend/Null.hs b/src/TahoeLAFS/Storage/Backend/Null.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Backend/Null.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Client.hs b/src/TahoeLAFS/Storage/Client.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Client.hs @@ -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 diff --git a/src/TahoeLAFS/Storage/Server.hs b/src/TahoeLAFS/Storage/Server.hs new file mode 100644 --- /dev/null +++ b/src/TahoeLAFS/Storage/Server.hs @@ -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 diff --git a/tahoe-great-black-swamp.cabal b/tahoe-great-black-swamp.cabal new file mode 100644 --- /dev/null +++ b/tahoe-great-black-swamp.cabal @@ -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 diff --git a/test/CBORSpec.hs b/test/CBORSpec.hs new file mode 100644 --- /dev/null +++ b/test/CBORSpec.hs @@ -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" diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTPSpec.hs @@ -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 "" + } diff --git a/test/Lib.hs b/test/Lib.hs new file mode 100644 --- /dev/null +++ b/test/Lib.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.Hspec.Runner ( + hspec, + ) + +import Spec ( + spec, + ) + +main :: IO () +main = do + hspec spec diff --git a/test/MiscSpec.hs b/test/MiscSpec.hs new file mode 100644 --- /dev/null +++ b/test/MiscSpec.hs @@ -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 diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs new file mode 100644 --- /dev/null +++ b/test/SemanticSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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