diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal index f320b64710049e5ad6fb10640f9664c4c1799911..a88d1bc818651d97ba7e9eb875c25e32462afab0 100644 --- a/gbs-downloader.cabal +++ b/gbs-downloader.cabal @@ -63,6 +63,8 @@ common warnings common language -- LANGUAGE extensions used by modules in all targets. default-extensions: + DerivingStrategies + GeneralizedNewtypeDeriving NamedFieldPuns OverloadedStrings RecordWildCards @@ -183,3 +185,4 @@ test-suite gbs-downloader-test , tasty-hedgehog , tasty-hunit , text + , yaml diff --git a/src/Tahoe/Announcement.hs b/src/Tahoe/Announcement.hs index 7fbf4f7af5c0ea1dca49041def8c19cba0fa0c9a..6fb69a187f3e708ce2c5155c52125d871a69d6d5 100644 --- a/src/Tahoe/Announcement.hs +++ b/src/Tahoe/Announcement.hs @@ -1,3 +1,10 @@ +{- | 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 (..), @@ -29,6 +36,7 @@ type StorageServerID = T.Text -} newtype Announcements = Announcements (Map.Map StorageServerID StorageServerAnnouncement) + deriving newtype (Eq, Show) -- Support serialization to the ``servers.yaml`` format supported by -- Tahoe-LAFS. @@ -37,6 +45,12 @@ instance FromJSON Announcements where 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 diff --git a/test/Generators.hs b/test/Generators.hs index 08ba46e3fcbefd45e977c8d35e240821439aab1b..3adc7c662bbccce84fecc99c0cb6251bac5eb1fa 100644 --- a/test/Generators.hs +++ b/test/Generators.hs @@ -1,9 +1,12 @@ module Generators where +import Data.ByteString.Base32 (encodeBase32Unpadded) import Data.Int (Int64) +import qualified Data.Text as T import Hedgehog (MonadGen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import Tahoe.Announcement (Announcements (..), StorageServerAnnouncement (..)) import Tahoe.CHK.Types (Parameters (..)) -- | The maximum value an Int64 can represent. @@ -20,3 +23,17 @@ genParameters = do -- 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) diff --git a/test/Spec.hs b/test/Spec.hs index 49145837dc7cfa772a3a12fbdf9efc7ea82a0e59..91a9191fd9cb0223b4fb905c9838bf9d612c93df 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,12 +14,14 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Word (Word16) -import Generators (genParameters) -import Hedgehog (MonadGen, diff, forAll, property) +import qualified Data.Yaml as Yaml +import Generators (genAnnouncements, genParameters) +import Hedgehog (MonadGen, diff, forAll, property, tripping) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import System.IO (hSetEncoding, stderr, stdout, utf8) import Tahoe.Announcement ( + Announcements, StorageServerAnnouncement (..), StorageServerID, URI (..), @@ -117,6 +119,10 @@ tests = } ) (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