Announcement.hs

{- | 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:" ""