diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Revision history for gbs-downloader + +## 0.1.0.0 -- 2023-08-17 + +* First version. Released on an unsuspecting world. +* Basic support for loading storage service announcements for server discovery. +* Basic support for downloading the contents associated with a CHK or SDMF read capability. + * CHK and SDMF directories are also supported. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright 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.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# GBS-Downloader + +## What is it? + +GBS-Downloader integrates Tahoe-CHK with Tahoe-Great-Black-Swamp to support downloading and decoding data from Great Black Swamp servers. +It aims for bit-for-bit compatibility with the original Python implementation. + +### What is the current state? + +* It can download immutable and mutable shares from Great Black Swamp storage servers. + * It *does not* cryptographically verify the identity of servers it communicates with. +* It can interpret, decode, and decrypt the data for CHK- and SDMF-encoded shares to recover the plaintext. + +## Why does it exist? + +A Haskell implementation can be used in places the original Python implementation cannot be +(for example, runtime environments where it is difficult to have a Python interpreter). +Additionally, +with the benefit of the experience gained from creating and maintaining the Python implementation, +a number of implementation decisions can be made differently to produce a more efficient, more flexible, simpler implementation and API. +Also, +the Python implementation claims no public library API for users outside of the Tahoe-LAFS project itself. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Data.Yaml (decodeEither') +import System.Environment (getArgs) +import Tahoe.Announcement (Announcements (..)) +import Tahoe.CHK.Capability (CHK (CHKReader), pCapability) +import Tahoe.Download (announcementToImmutableStorageServer, download) +import Text.Megaparsec (parse) + +main :: IO () +main = do + [announcementPath, readCap] <- getArgs + -- Load server announcements + announcementsBytes <- B.readFile announcementPath + let Right (Announcements announcements) = decodeEither' announcementsBytes + + -- Accept & parse read capability + let Right (CHKReader cap) = parse pCapability "" (T.pack readCap) + + -- Download & decode the shares + result <- download announcements cap announcementToImmutableStorageServer + + -- Show the result + putStrLn "Your result:" + either print (C8.putStrLn . BL.toStrict) result diff --git a/download-sdmf/Main.hs b/download-sdmf/Main.hs new file mode 100644 --- /dev/null +++ b/download-sdmf/Main.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Data.Yaml (decodeEither') +import System.Environment (getArgs) +import Tahoe.Announcement (Announcements (..)) +import Tahoe.Download (announcementToMutableStorageServer, download) +import Tahoe.SDMF (SDMF (..), pCapability, writerReader) +import Text.Megaparsec (parse) + +main :: IO () +main = do + [announcementPath, readCap] <- getArgs + -- Load server announcements + announcementsBytes <- B.readFile announcementPath + let Right (Announcements announcements) = decodeEither' announcementsBytes + + -- Accept & parse read capability + case parse pCapability "" (T.pack readCap) of + Left e -> print $ "Failed to parse cap: " <> show e + Right (SDMFVerifier _) -> C8.putStrLn "Nothing currently implemented for verifier caps." + Right (SDMFWriter rwcap) -> go announcements (writerReader rwcap) + Right (SDMFReader rocap) -> go announcements rocap + where + go announcements cap = do + -- Download & decode the shares + result <- download announcements cap announcementToMutableStorageServer + + -- Show the result + putStrLn "Your result:" + either print (C8.putStrLn . BL.toStrict) result diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal new file mode 100644 --- /dev/null +++ b/gbs-downloader.cabal @@ -0,0 +1,259 @@ +cabal-version: 2.4 + +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'gbs-downloader' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: gbs-downloader + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: + A library for downloading data from a Great Black Swamp server + +-- A longer description of the package. +description: + Integrate tahoe-ssk, tahoe-chk, and tahoe-directory to provide a high-level + API for downloading immutable and mutable files and directories. + +-- URL for the project homepage or repository. +homepage: + https://whetstone.private.storage/PrivateStorage/gbs-downloader + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Jean-Paul Calderone and others + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: exarkun@twistedmatrix.com + +-- A copyright notice. +copyright: 2023 The Authors +category: Network +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: + CHANGELOG.md + README.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +source-repository head + type: git + location: + https://whetstone.private.storage/PrivateStorage/gbs-downloader.git + +common warnings + ghc-options: -Wall + +common language + -- LANGUAGE extensions used by modules in all targets. + default-extensions: + DerivingStrategies + GeneralizedNewtypeDeriving + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TupleSections + +library + -- Import common warning flags. + import: + warnings + , language + + -- Modules exported by the library. + exposed-modules: + Tahoe.Announcement + Tahoe.Download + Tahoe.Download.Internal.Capability + Tahoe.Download.Internal.Client + Tahoe.Download.Internal.Immutable + Tahoe.Download.Internal.Mutable + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + , aeson >=1.4.7 && <2.2 + , async >=2.2.2 && <2.3 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , base64-bytestring >=1.0.0.3 && <1.3 + , binary >=0.8.6 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , connection >=0.3.1 && <0.4 + , containers >=0.6.0.1 && <0.7 + , data-default-class >=0.1.2 && <0.2 + , exceptions >=0.10.4 && <0.11 + , http-client >=0.6.4.1 && <0.8 + , http-client-tls >=0.3.5.3 && <0.4 + , http-types >=0.12.3 && <0.13 + , network-uri >=2.6.3 && <2.7 + , servant-client >=0.16.0.1 && <0.21 + , servant-client-core >=0.16 && <0.21 + , tahoe-chk >=0.1 && <0.2 + , tahoe-directory >=0.1 && <0.2 + , tahoe-great-black-swamp >=0.3 && <0.4 + , tahoe-ssk >=0.2 && <0.3 + , text >=1.2.3.1 && <1.3 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + +executable download-chk + -- Import common warning flags. + import: + warnings + , language + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + , aeson >=1.4.7 && <2.2 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.6.0.1 && <0.7 + , gbs-downloader + , megaparsec >=8.0 && <9.3 + , tahoe-chk >=0.1 && <0.2 + , text >=1.2.3.1 && <1.3 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 + + -- Directories containing source files. + hs-source-dirs: app + + -- Base language which the package is written in. + default-language: Haskell2010 + +executable download-sdmf + import: + warnings + , language + + main-is: Main.hs + build-depends: + , aeson >=1.4.7 && <2.2 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.6.0.1 && <0.7 + , gbs-downloader + , megaparsec >=8.0 && <9.3 + , tahoe-ssk >=0.2 && <0.3 + , text >=1.2.3.1 && <1.3 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 + + hs-source-dirs: download-sdmf + default-language: Haskell2010 + +executable list-dircap + import: + warnings + , language + + main-is: Main.hs + build-depends: + , aeson >=1.4.7 && <2.2 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.6.0.1 && <0.7 + , gbs-downloader + , megaparsec >=8.0 && <9.3 + , tahoe-chk >=0.1 && <0.2 + , tahoe-directory >=0.1 && <0.2 + , tahoe-ssk >=0.2 && <0.3 + , text >=1.2.3.1 && <1.3 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 + + hs-source-dirs: list-dircap + default-language: Haskell2010 + +test-suite gbs-downloader-test + -- Import common warning flags. + import: + warnings + , language + + -- Base language which the package is written in. + default-language: Haskell2010 + ghc-options: -threaded + + -- Modules included in this executable, other than Main. + other-modules: Generators + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Spec.hs + + -- Test dependencies. + build-depends: + , asn1-encoding >=0.9.6 && <0.10 + , asn1-types >=0.3.4 && <0.4 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , binary >=0.8.6 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.6.0.1 && <0.7 + , crypto-api >=0.13.3 && <0.14 + , cryptonite >=0.27 && <0.31 + , data-default-class >=0.1.2 && <0.2 + , gbs-downloader + , hedgehog >=1.0.3 && <1.1 + , http-client >=0.6.4.1 && <0.8 + , http-types >=0.12.3 && <0.13 + , memory >=0.15 && <0.17 + , servant-client >=0.16.0.1 && <0.21 + , servant-client-core >=0.16 && <0.21 + , tahoe-chk >=0.1 && <0.2 + , tahoe-ssk >=0.2 && <0.3 + , tasty >=1.2.3 && <1.5 + , tasty-hedgehog >=1.0.0.2 && <1.2 + , tasty-hunit >=0.10.0.2 && <0.11 + , text >=1.2.3.1 && <1.3 + , x509 >=1.7.5 && <1.8 + , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 diff --git a/list-dircap/Main.hs b/list-dircap/Main.hs new file mode 100644 --- /dev/null +++ b/list-dircap/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Yaml (decodeEither') +import System.Environment (getArgs) +import Tahoe.Announcement (Announcements (..)) +import qualified Tahoe.Directory as TD +import Text.Megaparsec (parse) + +import Tahoe.Download (announcementToImmutableStorageServer, announcementToMutableStorageServer, downloadDirectory) + +main :: IO () +main = do + [announcementPath, dirReadCap] <- getArgs + -- Load server announcements + announcementsBytes <- B.readFile announcementPath + let Right (Announcements announcements) = decodeEither' announcementsBytes + + -- Accept & parse read capability + case parse TD.pReadSDMF "" (T.pack dirReadCap) of + Right r -> go announcements r announcementToMutableStorageServer + Left eSDMF -> case parse TD.pReadCHK "" (T.pack dirReadCap) of + Right r -> go announcements r announcementToImmutableStorageServer + Left eCHK -> do + print $ "Failed to parse cap: " <> show eSDMF + print $ "Failed to parse cap: " <> show eCHK + where + go announcements cap lookupServer = do + -- Download & decode the shares + result <- downloadDirectory announcements cap lookupServer + + -- Show the result + putStrLn "Your result:" + either print print result diff --git a/src/Tahoe/Announcement.hs b/src/Tahoe/Announcement.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Announcement.hs @@ -0,0 +1,117 @@ +{- | Represent and work with Tahoe-LAFS storage service announcements. + + A storage service announcement includes information about how to find and + authenticate a storage service. They are often exchanged using a pubsub + system orchestrated by an "introducer". Here, we currently support only + reading them from a yaml or json file. +-} +module Tahoe.Announcement ( + URI (..), + URIAuth (..), + StorageServerID, + StorageServerAnnouncement (..), + Announcements (..), + greatBlackSwampURIs, + parseURI', +) where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.:?), (.=)) +import qualified Data.ByteString as B +import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded) +import Data.Default.Class (Default (def)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.URI (URI (..), URIAuth (..), parseURI) + +{- | The unique identifier for a particular storage server, conventionally the + lowercase base32 encoding of some public key controlled by the server. +-} +type StorageServerID = T.Text + +{- | A map of storage server announcements keyed on the unique server + identifier. +-} +newtype Announcements + = Announcements (Map.Map StorageServerID StorageServerAnnouncement) + deriving newtype (Eq, Show) + +-- Support serialization to the ``servers.yaml`` format supported by +-- Tahoe-LAFS. +instance FromJSON Announcements where + parseJSON = withObject "servers.yaml" $ \v -> do + storage <- v .: "storage" + pure $ Announcements storage + +instance ToJSON Announcements where + toJSON (Announcements announcements) = + object + [ "storage" .= announcements + ] + +-- | An announcement from a storage server about its storage service. +data StorageServerAnnouncement = StorageServerAnnouncement + { storageServerAnnouncementFURL :: Maybe T.Text + , storageServerAnnouncementNick :: Maybe T.Text + , storageServerAnnouncementPermutationSeed :: Maybe B.ByteString + } + deriving (Eq, Ord, Show) + +instance Default StorageServerAnnouncement where + def = + StorageServerAnnouncement + { storageServerAnnouncementFURL = Nothing + , storageServerAnnouncementNick = Nothing + , storageServerAnnouncementPermutationSeed = Nothing + } + +-- Support deserialization of a StorageServerAnnouncement from the +-- ``servers.yaml`` format supported by Tahoe-LAFS. +instance FromJSON StorageServerAnnouncement where + parseJSON = withObject "StorageServerAnnouncement" $ \ann -> do + v <- ann .: "ann" + storageServerAnnouncementFURL <- v .:? "anonymous-storage-FURL" + storageServerAnnouncementNick <- v .:? "nickname" + permutationSeed <- v .:? "permutation-seed-base32" + let storageServerAnnouncementPermutationSeed = + case permutationSeed of + Nothing -> Nothing + Just txt -> case decodeBase32Unpadded . encodeUtf8 $ txt of + Left _ -> Nothing + Right ps -> Just ps + + pure StorageServerAnnouncement{..} + +-- And serialization to that format. +instance ToJSON StorageServerAnnouncement where + toJSON StorageServerAnnouncement{..} = + object + [ "ann" + .= object + [ "anonymous-storage-FURL" .= storageServerAnnouncementFURL + , "nickname" .= storageServerAnnouncementNick + , "permutation-seed-base32" + .= (encodeBase32Unpadded <$> storageServerAnnouncementPermutationSeed) + ] + ] + +{- | If possible, get the URI of a Great Black Swamp server from an + announcement. +-} +greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI +greatBlackSwampURIs = + parseURI' . fromMaybe "" . storageServerAnnouncementFURL + +{- | Parse a Tahoe-LAFS fURL. For example: + + pb://gnuer2axzoq3ggnn7gjoybmfqsjvaow3@tcp:localhost:46185/sxytycucj5eeunlx6modfazq5byp2hpb + + This *does not* parse NURLs which are the expected way that GBS locations + will be communicated. + + See https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/6 +-} +parseURI' :: T.Text -> Maybe URI +parseURI' = Network.URI.parseURI . T.unpack . Data.Text.replace "tcp:" "" diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Download.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | A high-level interface to downloading share data as bytes from storage + servers. +-} +module Tahoe.Download ( + LookupServer, + DownloadError (..), + DirectoryDownloadError (..), + LookupError (..), + DiscoverError (..), + discoverShares, + download, + downloadDirectory, + announcementToImmutableStorageServer, + announcementToMutableStorageServer, + getShareNumbers, +) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Exception (Exception (displayException), SomeException, try) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Bifunctor (Bifunctor (first, second)) +import Data.Binary (Word16) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Either (partitionEithers, rights) +import Data.List (foldl') +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Tahoe.Announcement (StorageServerAnnouncement) +import Tahoe.CHK.Server (StorageServer (..), StorageServerID) +import Tahoe.CHK.Types (ShareNum, StorageIndex) +import Tahoe.Directory (Directory, DirectoryCapability (DirectoryCapability)) +import qualified Tahoe.Directory as Directory +import Tahoe.Download.Internal.Capability +import Tahoe.Download.Internal.Client +import Tahoe.Download.Internal.Immutable +import Tahoe.Download.Internal.Mutable + +-- | Partially describe one share download. +type DownloadTask = (ShareNum, StorageServer) + +-- | A downloaded share +type DownloadedShare = (ShareNum, LB.ByteString) + +{- | Recover the application data associated with a given capability from the + given servers, if possible. +-} +download :: + -- To download, we require a capability for which there is a Readable + -- instance because are also going to decrypt the ciphertext. A different + -- download interface that skips decryption could settle for a capability + -- with a Verifiable instance. We also require that the Verifier type for + -- the read capability has a Verifiable instance because Verifiable is + -- what gives us the ability to locate the shares. If we located + -- separately from decrypting this might be simpler. + (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) => + -- | Information about the servers from which to consider downloading shares + -- representing the application data. + Map.Map StorageServerID StorageServerAnnouncement -> + -- | The read capability for the application data. + readCap -> + -- | Get functions for interacting with a server given its URL. + LookupServer IO -> + -- | Either a description of how the recovery failed or the recovered + -- application data. + m (Either DownloadError LB.ByteString) +download servers cap lookupServer = do + print' ("Downloading: " <> show (getStorageIndex $ getVerifiable cap)) + let verifier = getVerifiable cap + let storageIndex = getStorageIndex verifier + -- TODO: If getRequiredTotal fails on the first storage server, we may + -- need to try more. If it fails for all of them, we need to represent + -- the failure coherently. + someParam <- liftIO $ firstRightM lookupServer (getRequiredTotal verifier) (Map.elems servers) + case someParam of + Left errs -> pure . Left $ if servers == mempty then NoConfiguredServers else NoReachableServers (StorageServerUnreachable <$> errs) + Right (required, _) -> do + locationE <- liftIO $ locateShares servers lookupServer storageIndex (fromIntegral required) + print' "Finished locating shares" + case locationE of + Left err -> do + print' "Got an error locating shares" + pure $ Left err + Right discovered -> do + print' "Found some shares, fetching them" + -- XXX note shares can contain failures + shares <- liftIO $ executeDownloadTasks storageIndex (makeDownloadTasks =<< discovered) + print' "Fetched the shares, decoding them" + s <- liftIO $ decodeShares cap shares required + print' "Decoded them" + pure s + +{- | Apply a monadic operation to each element of a list and another monadic + operation values in the resulting Rights. If all of the results are Lefts or + Nothings, return a list of the values in the Lefts. Otherwise, return the + *first* Right. +-} +firstRightM :: Monad m => (a -> m (Either b c)) -> (c -> m (Maybe d)) -> [a] -> m (Either [b] d) +firstRightM _ _ [] = pure $ Left [] +firstRightM f op (x : xs) = do + s <- f x + case s of + Left bs -> first (bs :) <$> recurse + Right ss -> do + r <- op ss + case r of + Nothing -> recurse + Just d -> pure $ Right d + where + recurse = firstRightM f op xs + +{- | Execute each download task sequentially and return only the successful + results. +-} +executeDownloadTasks :: + -- | The storage index of the shares to download. + StorageIndex -> + -- | The downloads to attempt. + [DownloadTask] -> + -- | The results of all successful downloads. + IO [DownloadedShare] +executeDownloadTasks storageIndex tasks = do + downloadResults <- mapConcurrently (downloadShare storageIndex) tasks + pure . rights $ inject <$> downloadResults + where + inject (a, b) = (a,) <$> b + +-- | Find out which servers claim to have shares related to a given storage index. +locateShares :: + -- | Information about the servers from which to consider downloading shares + -- representing the application data. + Map.Map StorageServerID StorageServerAnnouncement -> + -- | Get functions for interacting with a server given its URL. + LookupServer IO -> + -- | The storage index about which to retrieve information. + B.ByteString -> + -- | The number of shares we need to locate. If we cannot find at least + -- this many shares the result will be an error. + Word16 -> + -- | Either an error or a guide to where shares are placed. + IO (Either DownloadError [(StorageServer, Set.Set ShareNum)]) +locateShares servers lookupServer storageIndex required = + case Map.toList servers of + [] -> pure . Left $ NoConfiguredServers + serverList -> do + print' "Discovering shares" + -- Ask each server for all shares it has. + ( problems :: [DiscoverError] + , discovered :: [(StorageServer, Set.Set ShareNum)] + ) <- + partitionEithers <$> mapConcurrently (discoverShares lookupServer storageIndex) serverList + if null discovered + then pure . Left . NoReachableServers $ problems + else + if (fromIntegral required >) . countDistinctShares $ discovered + then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered} + else pure $ Right discovered + +{- | Given the results of downloading shares related to a given capability, + decode them and decrypt the contents of possible. +-} +decodeShares :: + (Readable readCap, Verifiable v, v ~ Verifier readCap) => + -- | The read capability which allows the contents to be decrypted. + readCap -> + -- | The results of downloading the shares. + [DownloadedShare] -> + Int -> + IO (Either DownloadError LB.ByteString) +decodeShares r shares required = do + -- Filter down to shares we actually got. + let fewerShares = second (deserializeShare (getVerifiable r)) <$> shares + onlyDecoded = rights $ (\(a, b) -> (fromIntegral a,) <$> b) <$> fewerShares + if length onlyDecoded < required + then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded} + else do + decodeShare r onlyDecoded + +{- | Figure the total number of distinct shares reported by all of the servers + we asked. +-} +countDistinctShares :: Ord b => [(a, Set.Set b)] -> Int +countDistinctShares = Set.size . foldl' Set.union mempty . map snd + +{- | Ask one server which shares it has related to the storage index in + question. +-} +discoverShares :: + LookupServer IO -> + StorageIndex -> + (StorageServerID, StorageServerAnnouncement) -> + IO (Either DiscoverError (StorageServer, Set.Set ShareNum)) +discoverShares lookupServer storageIndex (_sid, sann) = do + print' "Looking up server from announcement" + server <- lookupServer sann + print' "Looked it up" + case server of + Left e -> pure . Left . StorageServerUnreachable $ e + Right ss@StorageServer{storageServerGetBuckets} -> do + print' $ "Getting buckets for " <> show storageIndex + buckets <- try (storageServerGetBuckets storageIndex) + let massaged = first (StorageServerCommunicationError . (displayException :: SomeException -> String)) buckets + print' $ "Got them " <> show massaged + pure $ (ss,) <$> massaged + +{- | Expand a one-to-many mapping into a list of pairs with each of the "many" + values as the first element and the corresponding "one" value as the second + element. +-} +makeDownloadTasks :: Ord k => (v, Set.Set k) -> [(k, v)] +makeDownloadTasks (v, ks) = zip (Set.toList ks) (repeat v) + +-- | Download the bytes of a share from one (or more!) of the given servers. +downloadShare :: + -- | The storage index of the share to download. + StorageIndex -> + -- | Addressing information about the share to download. + DownloadTask -> + -- | The bytes of the share or some error that was encountered during + -- download. + IO (ShareNum, Either DownloadError LB.ByteString) +downloadShare storageIndex (shareNum, s) = do + print' $ "Going to download " <> show storageIndex <> " " <> show shareNum + shareBytes <- try (storageServerRead s storageIndex shareNum) + let massaged = first (ShareDownloadError . (displayException :: SomeException -> String)) shareBytes + print' "Downloaded it" + pure (shareNum, LB.fromStrict <$> massaged) + +{- | Download the data associated with a directory capability and interpret it + as a collection of entries. +-} +downloadDirectory :: + (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) => + -- | Information about the servers from which to consider downloading shares + -- representing the application data. + Map.Map StorageServerID StorageServerAnnouncement -> + -- | The read capability for the application data. + DirectoryCapability readCap -> + -- | Get functions for interacting with a server given its URL. + LookupServer IO -> + -- | Either a description of how the recovery failed or the recovered + -- application data. + m (Either DirectoryDownloadError Directory) +downloadDirectory anns (DirectoryCapability cap) lookupServer = do + bs <- download anns cap lookupServer + pure $ do + bs' <- first UnderlyingDownloadError bs + first (const DecodingError) $ Directory.parse (LB.toStrict bs') + +data DirectoryDownloadError + = UnderlyingDownloadError DownloadError + | DecodingError + deriving (Ord, Eq, Show) diff --git a/src/Tahoe/Download/Internal/Capability.hs b/src/Tahoe/Download/Internal/Capability.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Download/Internal/Capability.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TypeFamilies #-} + +module Tahoe.Download.Internal.Capability where + +import Control.Exception (SomeException, throwIO, try) +import Control.Monad.IO.Class +import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (Word8, decodeOrFail) +import Data.Binary.Get (ByteOffset) +import qualified Data.ByteString.Lazy as LB +import Data.Foldable (foldlM) +import qualified Data.Set as Set +import Network.HTTP.Types (Status (statusCode)) +import Servant.Client (ClientError (FailureResponse), ResponseF (..)) +import qualified Tahoe.CHK +import qualified Tahoe.CHK.Capability as CHK +import qualified Tahoe.CHK.Encrypt +import Tahoe.CHK.Server +import qualified Tahoe.CHK.Share +import Tahoe.CHK.Types +import Tahoe.Download.Internal.Client +import qualified Tahoe.SDMF as SDMF +import qualified Tahoe.SDMF.Internal.Keys as SDMF.Keys + +-- | A capability which confers the ability to locate and verify some stored data. +class Verifiable v where + -- | Represent the type of share to operate on. + type ShareT v + + -- | Ask a storage server which share numbers related to this capability it + -- is holding. This is an unverified result and the storage server could + -- present incorrect information. Even if it correctly reports that it + -- holds a share, it could decline to give it out when asked. + getShareNumbers :: MonadIO m => v -> StorageServer -> m (Set.Set ShareNum) + + -- | Get the encoding parameters used for the shares of this capability. + -- The information is presented as a tuple of (required, total). + + -- SDMF can fail to figure this out in lots of ways so consider switching + -- to Either or something? + getRequiredTotal :: MonadIO m => v -> StorageServer -> m (Maybe (Int, Int)) + + -- | Get the location information for shares of this capability. + getStorageIndex :: v -> StorageIndex + + -- | Deserialize some bytes representing some kind of share to the kind of + -- share associated with this capability type, if possible. + deserializeShare :: + -- | A type witness revealing what type of share to decode to. + v -> + -- | The bytes of the serialized share. + LB.ByteString -> + Either (LB.ByteString, ByteOffset, String) (ShareT v) + +{- | A capability which confers the ability to recover plaintext from + ciphertext. +-} +class Readable r where + -- | Represent the type of a Verifiable associated with the Readable. + type Verifier r + + -- | Attentuate the capability. + getVerifiable :: r -> Verifier r + + -- | Interpret the required number of shares to recover the plaintext. + -- + -- Note: might want to split the two functions below out of decodeShare + -- + -- shareToCipherText :: r -> [(Int, ShareT r)] -> LB.ByteString + -- + -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString + decodeShare :: MonadIO m => r -> [(Int, ShareT (Verifier r))] -> m (Either DownloadError LB.ByteString) + +instance Verifiable CHK.Verifier where + type ShareT CHK.Verifier = Tahoe.CHK.Share.Share + + getShareNumbers v s = liftIO $ storageServerGetBuckets s (CHK.storageIndex v) + getStorageIndex CHK.Verifier{storageIndex} = storageIndex + + -- CHK is pure, we don't have to ask the StorageServer + getRequiredTotal CHK.Verifier{required, total} _ = pure $ pure (fromIntegral required, fromIntegral total) + + deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail + +{- | A capability which confers the ability to interpret some stored data to + recover the original plaintext. Additionally, it can be attentuated to a + Verifiable. +-} +instance Readable CHK.Reader where + type Verifier CHK.Reader = CHK.Verifier + + getVerifiable = CHK.verifier + decodeShare r shareList = do + cipherText <- liftIO $ Tahoe.CHK.decode r shareList + case cipherText of + Nothing -> pure $ Left ShareDecodingFailed + Just ct -> + pure . Right $ Tahoe.CHK.Encrypt.decrypt (CHK.readKey r) ct + +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing + where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result + +instance Verifiable SDMF.Verifier where + type ShareT SDMF.Verifier = SDMF.Share + + getShareNumbers v s = liftIO $ storageServerGetBuckets s (SDMF.Keys.unStorageIndex $ SDMF.verifierStorageIndex v) + getStorageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex + getRequiredTotal SDMF.Verifier{..} ss = liftIO $ do + -- Find out what shares it has. Any share will do but we need to tell + -- it which we want. + errorOrShareNums <- try $ storageServerGetBuckets ss storageIndex + case Set.toList <$> errorOrShareNums of + -- Literally anything could go wrong with that... + Left (e :: SomeException) -> throwIO e + -- Or the server may have no shares for this storage index. + Right [] -> pure Nothing + -- Or it might have at least one. Check each in turn, stopping as + -- soon as we get a result. + Right shareNums -> firstJustsM (getParams <$> shareNums) + where + -- Get the Required, Total parameters for one share number, if + -- possible. + getParams :: MonadIO m => Word8 -> m (Maybe (Int, Int)) + getParams shareNum = liftIO $ do + errorOrShareBytes <- try $ storageServerRead ss storageIndex shareNum + case errorOrShareBytes of + Left e@(FailureResponse _ response) -> + -- It should not be very surprising for the requested share to + -- be missing from the server (you can never be sure what a + -- server will have). Other issues should probably be kept + -- visible. + if isStatusCode 404 response + then pure Nothing + else throwIO e + Left e -> throwIO e + Right shareBytes -> + case decodeOrFail (LB.fromStrict shareBytes) of + Left _ -> pure Nothing + Right (_, _, sh) -> pure $ pure (fromIntegral $ SDMF.shareRequiredShares sh, fromIntegral $ SDMF.shareTotalShares sh) + + storageIndex = SDMF.Keys.unStorageIndex verifierStorageIndex + + deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail + +-- | Test the status code of a response for equality against a given value. +isStatusCode :: Int -> ResponseF a -> Bool +isStatusCode expected = (expected ==) . statusCode . responseStatusCode + +instance Readable SDMF.Reader where + type Verifier SDMF.Reader = SDMF.Verifier + getVerifiable = SDMF.readerVerifier + decodeShare r shareList = do + cipherText <- Right <$> liftIO (SDMF.decode r (first fromIntegral <$> shareList)) + case cipherText of + Left _ -> pure $ Left ShareDecodingFailed + Right ct -> do + print' ("Got some ciphertext: " <> show ct) + print' ("Decrypting with iv: " <> show iv) + pure . Right $ SDMF.decrypt readKey iv ct + where + readKey = SDMF.readerReadKey r + iv = SDMF.shareIV (snd . head $ shareList) + +print' :: MonadIO m => String -> m () +-- print' = liftIO . putStrLn +print' = const $ pure () diff --git a/src/Tahoe/Download/Internal/Client.hs b/src/Tahoe/Download/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Download/Internal/Client.hs @@ -0,0 +1,198 @@ +{- | Functionality related to acting as a client for the Great Black Swamp + protocol. +-} +module Tahoe.Download.Internal.Client where + +import Control.Exception +import Control.Monad.IO.Class +import qualified Data.ByteString as B +import Data.ByteString.Base32 +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding +import Network.Connection +import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders)) +import Network.HTTP.Client.TLS +import Network.HTTP.Types (ByteRange) +import Servant.Client +import Tahoe.Announcement +import Tahoe.CHK.Server ( + StorageServer (..), + ) +import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber)) +import Text.Read (readMaybe) + +-- | Make an HTTPS URL. +https :: String -> Int -> BaseUrl +https host port = + BaseUrl + { baseUrlScheme = Https + , baseUrlHost = host + , baseUrlPort = port + , baseUrlPath = "" + } + +{- | Make an HTTPS manager for the given SPKI hash and swissnum. + + The SPKI hash is _not_ used to authenticate the server! See + https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27 +-} +managerSettingsForService :: T.Text -> T.Text -> ManagerSettings +managerSettingsForService _ swissnum = + (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize} + where + tlsSettings = TLSSettingsSimple True True True + sockSettings = Nothing + swissnumBytes = encodeUtf8 swissnum + swissnumBase64 = Base64.encode swissnumBytes + headerCompleteBytes = B.concat ["Tahoe-LAFS ", swissnumBase64] + authorize req = + req + { requestHeaders = + ( "Authorization" + , headerCompleteBytes + ) : + requestHeaders req + } + +-- | Make a manager suitable for use with a Great Black Swamp server. +newGBSManager :: + MonadIO m => + [Char] -> + String -> + m Manager +newGBSManager tubid swissnum = + newTlsManagerWith $ + managerSettingsForService + (T.pack . init $ tubid) + (T.pack swissnum) + +{- | An unrecoverable problem arose while attempting to download and/or read + some application data. +-} +data DownloadError + = -- | The configuration included no candidate servers from which to download. + NoConfiguredServers + | -- | Across all of the configured servers, none were actually connectable. + NoReachableServers [DiscoverError] + | -- | Across all of the configured servers, fewer than the required + -- number of shares were found. XXX Could split this into the different + -- cases - did not locate enough shares, did not download enough shares, + -- did not verify enough shares + NotEnoughShares + { notEnoughSharesNeeded :: Int + , notEnoughSharesFound :: Int + } + | -- | Across all of the shares that we could download, fewer than the + -- required number could actually be decoded. + NotEnoughDecodedShares + { notEnoughDecodedSharesNeeded :: Int + , notEnoughDecodedSharesFound :: Int + } + | -- | Enough syntactically valid shares were recovered but they could not + -- be interpreted. + ShareDecodingFailed + | -- | An attempt was made to download a share but no servers were given for + -- the download. + NoServers + | -- | An error occurred during share download. + ShareDownloadError String + deriving (Eq, Ord, Show) + +{- | A problem arose while attempting to discover the shares held on a + particular server. +-} +data DiscoverError + = -- | An announcement did not include a location for a connection attempt. + StorageServerLocationUnknown + | -- | An announcement included a location we could not interpret. + StorageServerLocationUnsupported + | StorageServerUnreachable LookupError + | StorageServerCommunicationError String + deriving (Eq, Ord, Show) + +{- | The type of a function that can produce a concrete StorageServer from + that server's announcement. +-} +type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer) + +-- | There was a problem while trying to look up a server from its announcement. +data LookupError + = -- | The server's announced URI was unparseable. + URIParseError StorageServerAnnouncement + | -- | The port integer in the server's URI was unparseable. + PortParseError String + | -- | The structure of the server's URI was unparseable. + AnnouncementStructureUnmatched + deriving (Eq, Ord, Show) + +{- | A problem was encountered attempting to deserialize bytes to a structured + representation of some value. +-} +data DeserializeError = UnknownDeserializeError -- add more later? + +type GetShareNumbers = String -> ClientM (CBORSet ShareNumber) +type ReadShare = String -> ShareNumber -> Maybe [ByteRange] -> ClientM B.ByteString + +{- | Create a StorageServer that will speak Great Black Swamp using the given + manager to the server at the given host/port. +-} +mkWrapper :: GetShareNumbers -> ReadShare -> Manager -> [Char] -> Int -> StorageServer +mkWrapper getShareNumbers readShare manager host realPort = + StorageServer{..} + where + baseUrl = https host realPort + env = mkClientEnv manager baseUrl + toBase32 = T.unpack . T.toLower . encodeBase32Unpadded + + storageServerID = undefined + + storageServerWrite = undefined + + storageServerRead storageIndex shareNum = do + let clientm = readShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing + res <- runClientM clientm env + case res of + Left err -> do + throwIO err + Right bs -> pure bs + + storageServerGetBuckets storageIndex = do + let clientm = getShareNumbers (toBase32 storageIndex) + r <- try $ runClientM clientm env + case r of + Left (_ :: SomeException) -> do + pure mempty + Right res -> do + case res of + Left err -> do + throwIO err + Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!! + +{- | If possible, populate a StorageServer with functions for operating on data + on the server at the given URI. +-} +makeServer :: MonadIO m => GetShareNumbers -> ReadShare -> URI -> m (Either LookupError StorageServer) +makeServer + getShareNumbers + readShare + URI + { uriScheme = "pb:" + , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)} + , uriPath = ('/' : swissnum) + , uriFragment = "" -- It's a fURL, not a NURL, so there's no fragment. + } = + case readMaybe port of + Nothing -> pure . Left . PortParseError $ port + Just realPort -> do + manager <- liftIO $ newGBSManager tubid swissnum + + pure . Right $ mkWrapper getShareNumbers readShare manager host realPort +makeServer _ _ _ = pure . Left $ AnnouncementStructureUnmatched + +announcementToStorageServer :: MonadIO m => GetShareNumbers -> ReadShare -> StorageServerAnnouncement -> m (Either LookupError StorageServer) +announcementToStorageServer getShareNumbers readShare ann = + case greatBlackSwampURIs ann of + Nothing -> pure . Left . URIParseError $ ann + Just uri -> makeServer getShareNumbers readShare uri diff --git a/src/Tahoe/Download/Internal/Immutable.hs b/src/Tahoe/Download/Internal/Immutable.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Download/Internal/Immutable.hs @@ -0,0 +1,15 @@ +-- | Functionality related to retrieving "immutable" shares (mainly CHK). +module Tahoe.Download.Internal.Immutable where + +import Control.Monad.IO.Class (MonadIO) +import Tahoe.Announcement (StorageServerAnnouncement) +import Tahoe.CHK.Server (StorageServer) +import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer) +import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare) + +{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a + Great Black Swamp server and construct a StorageServer for interacting with + immutable shares stored on it. +-} +announcementToImmutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer) +announcementToImmutableStorageServer = announcementToStorageServer getImmutableShareNumbers readImmutableShare diff --git a/src/Tahoe/Download/Internal/Mutable.hs b/src/Tahoe/Download/Internal/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Download/Internal/Mutable.hs @@ -0,0 +1,15 @@ +-- | Functionality related to retrieving "mutable" shares (for example, SDMF). +module Tahoe.Download.Internal.Mutable where + +import Control.Monad.IO.Class (MonadIO) +import Tahoe.Announcement (StorageServerAnnouncement) +import Tahoe.CHK.Server (StorageServer) +import Tahoe.Download.Internal.Client (LookupError, announcementToStorageServer) +import TahoeLAFS.Storage.Client (getMutableShareNumbers, readMutableShares) + +{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at a + Great Black Swamp server and construct a StorageServer for interacting with + mutable shares stored on it. +-} +announcementToMutableStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer) +announcementToMutableStorageServer = announcementToStorageServer getMutableShareNumbers readMutableShares diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,74 @@ +module Generators where + +import qualified Crypto.PubKey.RSA as RSA +import Data.ASN1.BinaryEncoding (DER (DER)) +import Data.ASN1.Encoding (ASN1Decoding (decodeASN1)) +import Data.ASN1.Types (ASN1Object (fromASN1)) +import Data.Bifunctor (Bifunctor (first)) +import Data.ByteString.Base32 (encodeBase32Unpadded) +import qualified Data.ByteString.Lazy as LB +import Data.Int (Int64) +import qualified Data.Text as T +import Data.X509 (PrivKey (PrivKeyRSA)) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import System.IO.Unsafe (unsafePerformIO) +import Tahoe.Announcement (Announcements (..), StorageServerAnnouncement (..)) +import Tahoe.CHK.Types (Parameters (..)) + +-- | The maximum value an Int64 can represent. +maxInt64 :: Integer +maxInt64 = fromIntegral (maxBound :: Int64) + +-- | Generate Parameters values for which all field invariants hold. +genParameters :: MonadGen m => m Parameters +genParameters = do + paramSegmentSize <- Gen.integral (Range.exponential 1 maxInt64) + paramTotalShares <- Gen.integral (Range.linear 2 256) + paramRequiredShares <- Gen.integral (Range.linear 1 (paramTotalShares - 1)) + -- XXX We're going to get rid of "Happy" from this type. For now it's + -- easier not to let this value vary and it doesn't hurt anything. + let paramHappyShares = 1 + pure $ Parameters{paramSegmentSize, paramTotalShares, paramHappyShares, paramRequiredShares} + +genAnnouncements :: MonadGen m => Range.Range Int -> m Announcements +genAnnouncements size = + Announcements <$> Gen.map size ((,) <$> genServerIDs <*> genStorageServerAnnouncements) + +genServerIDs :: MonadGen m => m T.Text +genServerIDs = T.toLower . encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32) + +genStorageServerAnnouncements :: MonadGen m => m StorageServerAnnouncement +genStorageServerAnnouncements = + StorageServerAnnouncement + <$> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii) + <*> Gen.maybe (Gen.text (Range.linear 16 32) Gen.ascii) + <*> Gen.maybe (Gen.bytes $ Range.singleton 32) + +{- | Build RSA key pairs. + + Because the specific bits of the key pair shouldn't make any difference to + any application logic, generating new RSA key pairs is expensive, and + generating new RSA key pairs in a way that makes sense in Hedgehog is + challenging, this implementation just knows a few RSA key pairs already and + will give back one of them. +-} +genRSAKeys :: MonadGen m => m RSA.PrivateKey +genRSAKeys = Gen.element (map rsaKeyPair rsaKeyPairBytes) + +-- I'm not sure how to do IO in MonadGen so do the IO up front unsafely (but +-- hopefully not really unsafely). +rsaKeyPairBytes :: [LB.ByteString] +{-# NOINLINE rsaKeyPairBytes #-} +rsaKeyPairBytes = unsafePerformIO $ mapM (\n -> LB.readFile ("test/data/rsa-privkey-" <> show n <> ".der")) [0 .. 4 :: Int] + +rsaKeyPair :: LB.ByteString -> RSA.PrivateKey +rsaKeyPair bs = do + let (Right kp) = do + asn1s <- first show (decodeASN1 DER bs) + (r, _) <- fromASN1 asn1s + case r of + PrivKeyRSA pk -> pure pk + _ -> error "Expected RSA Private Key" + kp diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,525 @@ +module Main where + +import Control.Exception (Exception, throwIO) +import Control.Monad (replicateM, when) +import Control.Monad.IO.Class (liftIO) +import Crypto.Cipher.Types (nullIV) +import Crypto.Classes (buildKey) +import qualified Crypto.Hash +import Data.Bifunctor (bimap) +import qualified Data.Binary as Binary +import qualified Data.ByteString as B +import Data.ByteString.Base32 (encodeBase32Unpadded) +import qualified Data.ByteString.Lazy as BL +import Data.Default.Class (Default (def)) +import qualified Data.Map.Strict as Map +import Data.Sequence (Seq (Empty), fromList) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word16) +import qualified Data.Yaml as Yaml +import Generators (genAnnouncements, genParameters, genRSAKeys) +import Hedgehog (MonadGen, annotateShow, diff, discard, forAll, property, tripping) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Types.Status (Status (..)) +import Network.HTTP.Types.Version (http11) +import Servant.Client.Core (BaseUrl (..), ClientError (..), RequestF (..), ResponseF (..), Scheme (..)) +import System.IO (hSetEncoding, stderr, stdout, utf8) +import Tahoe.Announcement ( + Announcements, + StorageServerAnnouncement (..), + StorageServerID, + URI (..), + URIAuth (..), + parseURI', + ) +import qualified Tahoe.CHK +import Tahoe.CHK.Capability (Reader (..), Verifier (..)) +import qualified Tahoe.CHK.Encrypt +import Tahoe.CHK.Server (StorageServer (..)) +import Tahoe.CHK.Types (Parameters (..)) +import Tahoe.CHK.Upload (getConvergentKey) +import Tahoe.Download ( + DiscoverError (..), + DownloadError (..), + LookupError (..), + LookupServer, + download, + ) +import Tahoe.Download.Internal.Capability (getRequiredTotal) +import qualified Tahoe.SDMF as SDMF +import qualified Tahoe.SDMF.Keys as SDMF.Keys +import Tahoe.Server (memoryStorageServer) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.Hedgehog (testProperty) + +data PlacementError = RanOutOfPlacementInfo | RanOutOfServers deriving (Eq, Show) +instance Exception PlacementError + +{- | Return a new StorageServer like the given one but with a get-buckets + interface that always throws an IO exception. +-} +breakGetBuckets :: Exception e => e -> StorageServer -> StorageServer +breakGetBuckets exc ss = + ss + { storageServerGetBuckets = const $ throwIO exc + } + +{- | Return a new StorageServer like the given one but with a read-share + interface that always throws an IO exception. +-} +breakRead :: Exception e => e -> StorageServer -> StorageServer +breakRead exc ss = + ss + { storageServerRead = \_ _ -> throwIO exc + } + +{- | A completely arbitrary exception that the download implementation can't + know anything specific about. +-} +data BespokeFailure = BespokeFailure deriving (Show) + +instance Exception BespokeFailure + +-- | Make an announcement that's real enough to convince a test. +simpleAnnouncement :: T.Text -> T.Text -> (T.Text, StorageServerAnnouncement) +simpleAnnouncement nick furl = + ( T.concat ["v0-", nick] + , def + { storageServerAnnouncementFURL = Just furl + , storageServerAnnouncementNick = Just nick + } + ) + +{- | Build a lookup function that can look up any server in the given list + from its announcement. +-} +simpleLookup :: Applicative f => [(T.Text, b)] -> StorageServerAnnouncement -> f (Either LookupError b) +simpleLookup [] _ = pure . Left $ AnnouncementStructureUnmatched +simpleLookup ((furl, server) : ss) ann@StorageServerAnnouncement{storageServerAnnouncementFURL} = + if Just furl == storageServerAnnouncementFURL + then pure . pure $ server + else simpleLookup ss ann + +tests :: TestTree +tests = + testGroup + "All tests" + [ testCase "Tahoe-LAFS fURLs can be parsed to a structured representation" $ + let tubid = "gnuer2axzoq3ggnn7gjoybmfqsjvaow3" + swissnum = "sxytycucj5eeunlx6modfazq5byp2hpb" + in assertEqual + "The result is as expected" + ( Just + URI + { uriScheme = "pb:" + , uriAuthority = + Just + URIAuth + { uriUserInfo = tubid <> "@" + , uriRegName = "localhost" + , uriPort = ":46185" + } + , uriPath = "/" <> swissnum + , uriQuery = "" + , uriFragment = "" + } + ) + (parseURI' $ T.pack $ "pb://" <> tubid <> "@tcp:localhost:46185/" <> swissnum) + , testProperty "Announcements round-trip through YAML encoding/decoding" $ + property $ do + announcements <- forAll $ genAnnouncements (Range.linear 0 3) + tripping announcements Yaml.encode (Yaml.decodeThrow :: B.ByteString -> Maybe Announcements) + , testCase + "no configured servers" + $ do + -- If there are no servers then we can't possibly get enough + -- shares to recover the application data. + result <- liftIO $ download mempty (trivialCap 1 1) noServers + assertEqual + "download should fail with no servers" + (Left NoConfiguredServers) + result + , testCase "no reachable servers" $ do + -- If we can't contact any configured server then we can't + -- possibly get enough shares to recover the application data. + let ann = def{storageServerAnnouncementNick = Just "unreachable"} + anns = + Map.fromList + [ ("v0-abc123", ann) + ] + + result <- liftIO $ download anns (trivialCap 1 1) noServers + assertEqual + "download should fail with no reachable servers" + (Left $ NoReachableServers [StorageServerUnreachable (URIParseError ann)]) + result + , testCase "not enough shares" $ do + -- If we can't recover enough shares from the configured servers + -- then we can't possibly get enough shares to recover the + -- application data. + let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"] + cap = trivialCap 3 3 + + -- Two shares exist. + server <- memoryStorageServer + storageServerWrite server (storageIndex . verifier $ cap) 0 0 "Hello world" + storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world" + + -- Make the server reachable. + let openServer = simpleLookup [("somewhere", server)] + + -- Try to download the cap which requires three shares to reconstruct. + result <- liftIO $ download anns cap openServer + assertEqual + "download should fail with not enough shares" + (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2}) + result + , testCase "not enough distinct shares" $ do + -- If we can't recover enough *distinct* shares from the + -- configured servers then we can't possibly get enough shares to + -- recover the application data. Duplicate shares do us no good. + let anns = + Map.fromList + [ simpleAnnouncement "abc123" "somewhere" + , simpleAnnouncement "abc456" "elsewhere" + ] + cap = trivialCap 3 3 + + -- Three shares exist + somewhere <- memoryStorageServer + let idx = storageIndex . verifier $ cap + offset = 0 + storageServerWrite somewhere idx 0 offset "Hello world" + storageServerWrite somewhere idx 1 offset "Hello world" + -- But this one is just a duplicate of share 0 on the other + -- server. + elsewhere <- memoryStorageServer + storageServerWrite elsewhere idx 0 offset "Hello world" + + -- Make the server reachable. + let openServer = simpleLookup [("somewhere", somewhere), ("elsewhere", elsewhere)] + + -- Try to download the cap which requires three shares to reconstruct. + result <- liftIO $ download anns cap openServer + assertEqual + "download should fail with not enough shares" + (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2}) + result + , testCase "IO exceptions from storageServerGetBuckets are handled" $ do + -- An announcement for our server + let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"] + -- A broken interface to the server + server <- breakGetBuckets BespokeFailure <$> memoryStorageServer + + -- Make the server reachable. + let openServer = simpleLookup [("somewhere", server)] + + -- Something to pretend to try to download + let cap = trivialCap 3 13 + + -- Try to download the cap which requires three shares to reconstruct. + result <- liftIO $ download anns cap openServer + assertEqual + "download should fail with details about unreachable server" + (Left (NoReachableServers [StorageServerCommunicationError "BespokeFailure"])) + result + , testProperty "getRequiredTotal handles a share being missing from the server" $ + property $ do + -- If we can recover any single share from the server then we can + -- inspect it for encoding parameters. + + -- Generates configurations where the encoding parameters dicated + -- multiple shares but they may not be all placed on the server. + sequenceNumber <- forAll $ Gen.integral (Range.exponential 1 10000) + plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024) + Parameters{paramTotalShares, paramRequiredShares} <- forAll genParameters + + -- Encrypt and encode the data into shares. + keypair <- SDMF.Keys.KeyPair <$> forAll genRSAKeys + let iv = SDMF.Keys.SDMF_IV nullIV + ciphertext = SDMF.encrypt keypair iv plaintext + (shares, cap) <- liftIO $ SDMF.encode keypair iv sequenceNumber paramRequiredShares paramTotalShares ciphertext + + -- Pick some shares for placement on a single server. + placedShares <- forAll $ Gen.subsequence (zip [0 ..] (Binary.encode <$> shares)) + when (null placedShares) discard + + let verifier = SDMF.readerVerifier . SDMF.writerReader $ cap + storageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex $ verifier + + -- Be sure to create the server last to avoid having Hedgehog + -- re-use it for multiple cases. + server <- liftIO memoryStorageServer + liftIO $ + placeShares + storageIndex + placedShares + [length placedShares] + [server] + + r <- getRequiredTotal verifier server + diff (Just (fromIntegral paramRequiredShares, fromIntegral paramTotalShares)) (==) r + , testCase "IO exceptions from storageServerRead are handled" $ do + -- An announcement for our server + let anns = Map.fromList [simpleAnnouncement "abc123" "somewhere"] + + -- A broken interface to the server + server <- breakRead BespokeFailure <$> memoryStorageServer + + -- Something to pretend to try to download + let cap = trivialCap 3 13 + + -- Three shares exist + let idx = storageIndex . verifier $ cap + offset = 0 + storageServerWrite server idx 0 offset "Hello world" + storageServerWrite server idx 1 offset "Hello world" + storageServerWrite server idx 2 offset "Hello world" + + -- Make the server reachable. + let openServer = simpleLookup [("somewhere", server)] + + -- Try to download the cap which requires three shares to reconstruct. + + result <- liftIO $ download anns cap openServer + assertEqual + "download should fail with details about unreachable server" + (Left (NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = 3, notEnoughDecodedSharesFound = 0})) + result + , testProperty "chk success" $ + property $ do + -- If we can recover enough distinct, decodeable shares from the + -- configured servers then we can recover the application data. + + -- Generates configurations where it should be possible to recover + -- the data (have all the shares, have enough of the shares, + -- spread them across many servers, concentrate them on one or a + -- few, etc) + + secret <- forAll $ Gen.bytes (Range.singleton 32) + plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024) + params@Parameters{paramTotalShares} <- forAll genParameters + + -- Since multiple shares can be placed on a single server, as long + -- as we have one server we have a valid case. Since some shares + -- might be placed non-optimally it is also nice to allow for some + -- empty servers so allow for that as well. + let numServers = Range.linear 1 (fromIntegral paramTotalShares + 1) + serverIDs = Gen.text (Range.singleton 2) Gen.ascii + serverIDs' <- forAll $ Gen.set numServers serverIDs + + -- Choose a share distribution. Each element of the resulting + -- list tells us how many shares to place on the next server, for + -- some arbitrary (stable) server ordering. + perServerShareCount <- + forAll $ + genListWithSum (length serverIDs') (fromIntegral paramTotalShares) + + -- Make the servers. + servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer + + -- Encrypt and encode the data into shares. + let key = getConvergentKey secret params plaintext + ciphertext = Tahoe.CHK.Encrypt.encrypt key plaintext + (shares, cap) <- liftIO $ Tahoe.CHK.encode key params ciphertext + + -- Distribute the shares. + liftIO $ placeShares (storageIndex . verifier $ cap) (zip [0 ..] (Binary.encode <$> shares)) perServerShareCount servers + + let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers + lookupServer = someServers serverMap + serverAnnouncements = Map.fromSet makeAnn serverIDs' + + -- Recover the plaintext from the servers. + result <- liftIO $ download serverAnnouncements cap lookupServer + diff (Right plaintext) (==) result + , testProperty "ssk success" $ + property $ do + -- Like "chk success" above, but for SDMF (a case of SSK). + plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024) + sequenceNumber <- forAll $ Gen.integral (Range.exponential 1 10000) + keypair <- SDMF.Keys.KeyPair <$> forAll genRSAKeys + Parameters{paramRequiredShares = required, paramTotalShares = total} <- forAll genParameters + + -- Since multiple shares can be placed on a single server, as long + -- as we have one server we have a valid case. Since some shares + -- might be placed non-optimally it is also nice to allow for some + -- empty servers so allow for that as well. + let numServers = Range.linear 1 (fromIntegral total + 1) + serverIDs = Gen.text (Range.singleton 2) Gen.ascii + serverIDs' <- forAll $ Gen.set numServers serverIDs + + perServerShareCount <- + forAll $ + genListWithSum (length serverIDs') (fromIntegral total) + + -- Make the servers. + servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer + + -- Derive the keys, encode the data. + let -- Not a very good IV choice in reality but it's okay for + -- this test where confidentiality and key secrecy is not + -- particularly a concern. + iv = SDMF.Keys.SDMF_IV nullIV + ciphertext = SDMF.encrypt keypair iv plaintext + annotateShow ciphertext + annotateShow iv + (shares, writeCap) <- liftIO $ SDMF.encode keypair iv sequenceNumber required total ciphertext + let storageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex . SDMF.readerVerifier . SDMF.writerReader $ writeCap + readCap = SDMF.writerReader writeCap + -- Distribute the shares. + liftIO $ placeShares storageIndex (zip [0 ..] (Binary.encode <$> shares)) perServerShareCount servers + + let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers + lookupServer = someServers serverMap + serverAnnouncements = Map.fromSet makeAnn serverIDs' + + -- Recover the plaintext from the servers. + result <- liftIO $ download serverAnnouncements readCap lookupServer + diff (Right plaintext) (==) result + , testCase "immutable upload/download to using Great Black Swamp" $ do + pure () + -- Consider moving these tests to another module, they're pretty + -- different and there's quite a handful of them. + -- + -- ERROR CASES + -- Server presents incorrect TLS certificate + -- * See https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27 + -- Server returns error response to our request + -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/4 + -- Server returns tampered share data + -- * https://whetstone.private.storage/privatestorage/gbs-downloader/-/issues/5 + ] + where + -- A server lookup function that always fails. + noServers = pure . Left . URIParseError + + -- A server lookup function that finds servers already present in a Map. + someServers :: Applicative m => Map.Map StorageServerID StorageServer -> LookupServer m + someServers servers ann = + pure $ case result of + Nothing -> Left AnnouncementStructureUnmatched + Just ss -> Right ss + where + result = do + furl <- storageServerAnnouncementFURL ann + let serverId = parseURL furl + Map.lookup serverId servers + + -- Exactly match the nonsense makeAnn spits out + parseURL = T.take 2 . T.drop 5 + + --- PHILOSOFY + -- We wish that share numbers were an opaque type instead of a + -- numeric/integral type. This is not the place to argue the point + -- though. + placeShares :: + -- The storage index to place shares at. + B.ByteString -> + -- The number and bytes of the shares themselves. + [(Int, BL.ByteString)] -> + -- The number of shares to place on each server. + [Int] -> + -- The servers to place shares on. + [StorageServer] -> + IO () + -- Out of shares, done. + placeShares _ [] _ _ = pure () + -- Out of placement info but not out of shares is a programming error. + placeShares _ _ [] _ = throwIO RanOutOfPlacementInfo + -- Out of servers but not out of shares is a programming error. + placeShares _ _ _ [] = throwIO RanOutOfServers + -- Having some of all three means we can make progress. + placeShares si shares (n : ns) (s : ss) = do + -- write the right number of shares to this server + mapM_ + (\(shnum, share) -> storageServerWrite s si shnum 0 share) + (bimap fromIntegral BL.toStrict <$> take n shares) + -- recurse to write the rest + placeShares si (drop n shares) ns ss + + -- Make up a distinct (but nonsense) announcement for a given storage + -- server identifier. + makeAnn :: StorageServerID -> StorageServerAnnouncement + makeAnn sid = + def + { storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid + , storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid + } + + -- Generate lists of ints that sum to a given total. + genListWithSum :: MonadGen m => Int -> Int -> m [Int] + -- We hit the target. + genListWithSum _ 0 = pure [] + -- We only have room for one more element. + genListWithSum 1 t = pure [t] + -- Use up some of what's left on one element and recurse. + genListWithSum maxLength t = do + v <- Gen.int (Range.linear 0 t) + (v :) <$> genListWithSum (maxLength - 1) (t - v) + +trivialCap :: Word16 -> Word16 -> Reader +trivialCap required total = Reader{..} + where + Just readKey = buildKey $ B.replicate 32 0x00 + storageIndex = B.replicate 32 0x00 + fingerprint = B.replicate 32 0x00 + size = 1234 + verifier = Verifier{..} + +trivialSDMFVerifier :: SDMF.Verifier +trivialSDMFVerifier = SDMF.Verifier{..} + where + verifierStorageIndex = SDMF.Keys.StorageIndex $ B.pack [0 .. 15] + verifierVerificationKeyHash = Crypto.Hash.hash $ B.pack [0 .. 31] + +-- | A real 404 response from tahoe-great-black-swamp 0.3.0.0. +failure404 :: ClientError +failure404 = + FailureResponse + ( Request + { requestPath = + ( BaseUrl + { baseUrlScheme = Https + , baseUrlHost = "storage002.private.storage" + , baseUrlPort = 8899 + , baseUrlPath = "" + } + , "/storage/v1/mutable/6yo5yo6uxniiiwtyxv46bfvwm4/0" + ) + , requestQueryString = Empty + , requestBody = Nothing + , requestAccept = fromList ["application/octet-stream"] + , requestHeaders = Empty + , requestHttpVersion = http11 + , requestMethod = "GET" + } + ) + ( Response + { responseStatusCode = Status{statusCode = 404, statusMessage = "Not Found"} + , responseHttpVersion = http11 + , responseHeaders = + fromList + [ ("Transfer-Encoding", "chunked") + , ("Server", "TwistedWeb/22.10.0") + , ("Date", "Fri, 23 Jun 2023 11:27:49 GMT") + , ("Content-Type", "application/octet-stream") + ] + , responseBody = "" + } + ) + +main :: IO () +main = do + -- Hedgehog writes some non-ASCII and the whole test process will die if + -- it can't be encoded. Increase the chances that all of the output can + -- be encoded by forcing the use of UTF-8 (overriding the LANG-based + -- choice normally made). + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + defaultMain tests