diff --git a/app/Main.hs b/app/Main.hs index 7566395756a8cb30c3bc988210d27736a457d84a..a6ea789d0bc937a2520c843b6306ebc601338b17 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,11 +3,10 @@ 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.Map.Strict as Map import qualified Data.Text as T -import Data.Yaml (FromJSON (parseJSON), Value (Object), decodeEither', (.:)) +import Data.Yaml (decodeEither') import System.Environment (getArgs) -import Tahoe.Announcement (StorageServerAnnouncement, StorageServerID) +import Tahoe.Announcement (Announcements (..)) import Tahoe.CHK.Capability import Tahoe.Download (announcementToStorageServer, download) import Text.Megaparsec (parse) @@ -18,8 +17,6 @@ main = do -- Load server announcements announcementsBytes <- B.readFile announcementPath let Right (Announcements announcements) = decodeEither' announcementsBytes - -- print ("Your announcements:" :: Data.Text.Text) - -- print announcements -- Accept & parse read capability let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap) @@ -30,11 +27,3 @@ main = do -- Show the result putStrLn "Your result:" either print (C8.putStrLn . BL.toStrict) result - -newtype Announcements = Announcements (Map.Map StorageServerID StorageServerAnnouncement) - -instance FromJSON Announcements where - parseJSON (Object v) = do - storage <- v .: "storage" - pure $ Announcements storage - parseJSON _ = error "unsupported announcements format" diff --git a/src/Tahoe/Announcement.hs b/src/Tahoe/Announcement.hs index 3a8f3e758f4ad1b9dd8148efab90afec61d061ed..1729bbabf179856f81f47ae343dbcbd812441c0f 100644 --- a/src/Tahoe/Announcement.hs +++ b/src/Tahoe/Announcement.hs @@ -3,6 +3,7 @@ module Tahoe.Announcement ( URIAuth (..), StorageServerID, StorageServerAnnouncement (..), + Announcements (..), greatBlackSwampURIs, parseURI', ) where @@ -10,16 +11,31 @@ module Tahoe.Announcement ( import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.:?), (.=)) import qualified Data.ByteString as B import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded) +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. +{- | 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) + +-- 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 + -- | An announcement from a storage server about its storage service. data StorageServerAnnouncement = StorageServerAnnouncement { storageServerAnnouncementFURL :: Maybe T.Text @@ -28,6 +44,8 @@ data StorageServerAnnouncement = StorageServerAnnouncement } deriving (Eq, Ord, Show) +-- 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" @@ -43,6 +61,7 @@ instance FromJSON StorageServerAnnouncement where pure StorageServerAnnouncement{..} +-- And serialization to that format. instance ToJSON StorageServerAnnouncement where toJSON StorageServerAnnouncement{..} = object @@ -55,6 +74,9 @@ instance ToJSON StorageServerAnnouncement where ] ] +{- | If possible, get the URI of a Great Black Swamp server from an + announcement. +-} greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI greatBlackSwampURIs = parseURI' . fromMaybe "" . storageServerAnnouncementFURL