diff --git a/src/Tahoe/Announcement.hs b/src/Tahoe/Announcement.hs new file mode 100644 index 0000000000000000000000000000000000000000..3a8f3e758f4ad1b9dd8148efab90afec61d061ed --- /dev/null +++ b/src/Tahoe/Announcement.hs @@ -0,0 +1,67 @@ +module Tahoe.Announcement ( + URI (..), + URIAuth (..), + StorageServerID, + StorageServerAnnouncement (..), + 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.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 + +-- | 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 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{..} + +instance ToJSON StorageServerAnnouncement where + toJSON StorageServerAnnouncement{..} = + object + [ "ann" + .= object + [ "anonymous-storage-FURL" .= storageServerAnnouncementFURL + , "nickname" .= storageServerAnnouncementNick + , "permutation-seed-base32" + .= (encodeBase32Unpadded <$> storageServerAnnouncementPermutationSeed) + ] + ] + +greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI +greatBlackSwampURIs = + parseURI' . fromMaybe "" . storageServerAnnouncementFURL + +{- | Parse a Tahoe-LAFS fURL. For example: + + pb://gnuer2axzoq3ggnn7gjoybmfqsjvaow3@tcp:localhost:46185/sxytycucj5eeunlx6modfazq5byp2hpb +-} +parseURI' :: T.Text -> Maybe URI +parseURI' = Network.URI.parseURI . T.unpack . Data.Text.replace "tcp:" ""