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