{- | 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 (Announcements -> Announcements -> Bool
(Announcements -> Announcements -> Bool)
-> (Announcements -> Announcements -> Bool) -> Eq Announcements
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Announcements -> Announcements -> Bool
$c/= :: Announcements -> Announcements -> Bool
== :: Announcements -> Announcements -> Bool
$c== :: Announcements -> Announcements -> Bool
Eq, Int -> Announcements -> ShowS
[Announcements] -> ShowS
Announcements -> String
(Int -> Announcements -> ShowS)
-> (Announcements -> String)
-> ([Announcements] -> ShowS)
-> Show Announcements
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Announcements] -> ShowS
$cshowList :: [Announcements] -> ShowS
show :: Announcements -> String
$cshow :: Announcements -> String
showsPrec :: Int -> Announcements -> ShowS
$cshowsPrec :: Int -> Announcements -> ShowS
Show)

-- Support serialization to the ``servers.yaml`` format supported by
-- Tahoe-LAFS.
instance FromJSON Announcements where
    parseJSON :: Value -> Parser Announcements
parseJSON = String
-> (Object -> Parser Announcements)
-> Value
-> Parser Announcements
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"servers.yaml" ((Object -> Parser Announcements) -> Value -> Parser Announcements)
-> (Object -> Parser Announcements)
-> Value
-> Parser Announcements
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
        Map StorageServerID StorageServerAnnouncement
storage <- Object
v Object
-> StorageServerID
-> Parser (Map StorageServerID StorageServerAnnouncement)
forall a. FromJSON a => Object -> StorageServerID -> Parser a
.: StorageServerID
"storage"
        Announcements -> Parser Announcements
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Announcements -> Parser Announcements)
-> Announcements -> Parser Announcements
forall a b. (a -> b) -> a -> b
$ Map StorageServerID StorageServerAnnouncement -> Announcements
Announcements Map StorageServerID StorageServerAnnouncement
storage

instance ToJSON Announcements where
    toJSON :: Announcements -> Value
toJSON (Announcements Map StorageServerID StorageServerAnnouncement
announcements) =
        [Pair] -> Value
object
            [ StorageServerID
"storage" StorageServerID
-> Map StorageServerID StorageServerAnnouncement -> Pair
forall kv v. (KeyValue kv, ToJSON v) => StorageServerID -> v -> kv
.= Map StorageServerID StorageServerAnnouncement
announcements
            ]

-- | An announcement from a storage server about its storage service.
data StorageServerAnnouncement = StorageServerAnnouncement
    { StorageServerAnnouncement -> Maybe StorageServerID
storageServerAnnouncementFURL :: Maybe T.Text
    , StorageServerAnnouncement -> Maybe StorageServerID
storageServerAnnouncementNick :: Maybe T.Text
    , StorageServerAnnouncement -> Maybe ByteString
storageServerAnnouncementPermutationSeed :: Maybe B.ByteString
    }
    deriving (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
(StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> Eq StorageServerAnnouncement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c/= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
== :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c== :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
Eq, Eq StorageServerAnnouncement
Eq StorageServerAnnouncement
-> (StorageServerAnnouncement
    -> StorageServerAnnouncement -> Ordering)
-> (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> (StorageServerAnnouncement -> StorageServerAnnouncement -> Bool)
-> (StorageServerAnnouncement
    -> StorageServerAnnouncement -> StorageServerAnnouncement)
-> (StorageServerAnnouncement
    -> StorageServerAnnouncement -> StorageServerAnnouncement)
-> Ord StorageServerAnnouncement
StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
StorageServerAnnouncement -> StorageServerAnnouncement -> Ordering
StorageServerAnnouncement
-> StorageServerAnnouncement -> StorageServerAnnouncement
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StorageServerAnnouncement
-> StorageServerAnnouncement -> StorageServerAnnouncement
$cmin :: StorageServerAnnouncement
-> StorageServerAnnouncement -> StorageServerAnnouncement
max :: StorageServerAnnouncement
-> StorageServerAnnouncement -> StorageServerAnnouncement
$cmax :: StorageServerAnnouncement
-> StorageServerAnnouncement -> StorageServerAnnouncement
>= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c>= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
> :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c> :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
<= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c<= :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
< :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
$c< :: StorageServerAnnouncement -> StorageServerAnnouncement -> Bool
compare :: StorageServerAnnouncement -> StorageServerAnnouncement -> Ordering
$ccompare :: StorageServerAnnouncement -> StorageServerAnnouncement -> Ordering
$cp1Ord :: Eq StorageServerAnnouncement
Ord, Int -> StorageServerAnnouncement -> ShowS
[StorageServerAnnouncement] -> ShowS
StorageServerAnnouncement -> String
(Int -> StorageServerAnnouncement -> ShowS)
-> (StorageServerAnnouncement -> String)
-> ([StorageServerAnnouncement] -> ShowS)
-> Show StorageServerAnnouncement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorageServerAnnouncement] -> ShowS
$cshowList :: [StorageServerAnnouncement] -> ShowS
show :: StorageServerAnnouncement -> String
$cshow :: StorageServerAnnouncement -> String
showsPrec :: Int -> StorageServerAnnouncement -> ShowS
$cshowsPrec :: Int -> StorageServerAnnouncement -> ShowS
Show)

instance Default StorageServerAnnouncement where
    def :: StorageServerAnnouncement
def =
        StorageServerAnnouncement :: Maybe StorageServerID
-> Maybe StorageServerID
-> Maybe ByteString
-> StorageServerAnnouncement
StorageServerAnnouncement
            { storageServerAnnouncementFURL :: Maybe StorageServerID
storageServerAnnouncementFURL = Maybe StorageServerID
forall a. Maybe a
Nothing
            , storageServerAnnouncementNick :: Maybe StorageServerID
storageServerAnnouncementNick = Maybe StorageServerID
forall a. Maybe a
Nothing
            , storageServerAnnouncementPermutationSeed :: Maybe ByteString
storageServerAnnouncementPermutationSeed = Maybe ByteString
forall a. Maybe a
Nothing
            }

-- Support deserialization of a StorageServerAnnouncement from the
-- ``servers.yaml`` format supported by Tahoe-LAFS.
instance FromJSON StorageServerAnnouncement where
    parseJSON :: Value -> Parser StorageServerAnnouncement
parseJSON = String
-> (Object -> Parser StorageServerAnnouncement)
-> Value
-> Parser StorageServerAnnouncement
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"StorageServerAnnouncement" ((Object -> Parser StorageServerAnnouncement)
 -> Value -> Parser StorageServerAnnouncement)
-> (Object -> Parser StorageServerAnnouncement)
-> Value
-> Parser StorageServerAnnouncement
forall a b. (a -> b) -> a -> b
$ \Object
ann -> do
        Object
v <- Object
ann Object -> StorageServerID -> Parser Object
forall a. FromJSON a => Object -> StorageServerID -> Parser a
.: StorageServerID
"ann"
        Maybe StorageServerID
storageServerAnnouncementFURL <- Object
v Object -> StorageServerID -> Parser (Maybe StorageServerID)
forall a.
FromJSON a =>
Object -> StorageServerID -> Parser (Maybe a)
.:? StorageServerID
"anonymous-storage-FURL"
        Maybe StorageServerID
storageServerAnnouncementNick <- Object
v Object -> StorageServerID -> Parser (Maybe StorageServerID)
forall a.
FromJSON a =>
Object -> StorageServerID -> Parser (Maybe a)
.:? StorageServerID
"nickname"
        Maybe StorageServerID
permutationSeed <- Object
v Object -> StorageServerID -> Parser (Maybe StorageServerID)
forall a.
FromJSON a =>
Object -> StorageServerID -> Parser (Maybe a)
.:? StorageServerID
"permutation-seed-base32"
        let storageServerAnnouncementPermutationSeed :: Maybe ByteString
storageServerAnnouncementPermutationSeed =
                case Maybe StorageServerID
permutationSeed of
                    Maybe StorageServerID
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
                    Just StorageServerID
txt -> case ByteString -> Either StorageServerID ByteString
decodeBase32Unpadded (ByteString -> Either StorageServerID ByteString)
-> (StorageServerID -> ByteString)
-> StorageServerID
-> Either StorageServerID ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerID -> ByteString
encodeUtf8 (StorageServerID -> Either StorageServerID ByteString)
-> StorageServerID -> Either StorageServerID ByteString
forall a b. (a -> b) -> a -> b
$ StorageServerID
txt of
                        Left StorageServerID
_ -> Maybe ByteString
forall a. Maybe a
Nothing
                        Right ByteString
ps -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
ps

        StorageServerAnnouncement -> Parser StorageServerAnnouncement
forall (f :: * -> *) a. Applicative f => a -> f a
pure StorageServerAnnouncement :: Maybe StorageServerID
-> Maybe StorageServerID
-> Maybe ByteString
-> StorageServerAnnouncement
StorageServerAnnouncement{Maybe ByteString
Maybe StorageServerID
storageServerAnnouncementPermutationSeed :: Maybe ByteString
storageServerAnnouncementNick :: Maybe StorageServerID
storageServerAnnouncementFURL :: Maybe StorageServerID
storageServerAnnouncementPermutationSeed :: Maybe ByteString
storageServerAnnouncementNick :: Maybe StorageServerID
storageServerAnnouncementFURL :: Maybe StorageServerID
..}

-- And serialization to that format.
instance ToJSON StorageServerAnnouncement where
    toJSON :: StorageServerAnnouncement -> Value
toJSON StorageServerAnnouncement{Maybe ByteString
Maybe StorageServerID
storageServerAnnouncementPermutationSeed :: Maybe ByteString
storageServerAnnouncementNick :: Maybe StorageServerID
storageServerAnnouncementFURL :: Maybe StorageServerID
storageServerAnnouncementPermutationSeed :: StorageServerAnnouncement -> Maybe ByteString
storageServerAnnouncementNick :: StorageServerAnnouncement -> Maybe StorageServerID
storageServerAnnouncementFURL :: StorageServerAnnouncement -> Maybe StorageServerID
..} =
        [Pair] -> Value
object
            [ StorageServerID
"ann"
                StorageServerID -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => StorageServerID -> v -> kv
.= [Pair] -> Value
object
                    [ StorageServerID
"anonymous-storage-FURL" StorageServerID -> Maybe StorageServerID -> Pair
forall kv v. (KeyValue kv, ToJSON v) => StorageServerID -> v -> kv
.= Maybe StorageServerID
storageServerAnnouncementFURL
                    , StorageServerID
"nickname" StorageServerID -> Maybe StorageServerID -> Pair
forall kv v. (KeyValue kv, ToJSON v) => StorageServerID -> v -> kv
.= Maybe StorageServerID
storageServerAnnouncementNick
                    , StorageServerID
"permutation-seed-base32"
                        StorageServerID -> Maybe StorageServerID -> Pair
forall kv v. (KeyValue kv, ToJSON v) => StorageServerID -> v -> kv
.= (ByteString -> StorageServerID
encodeBase32Unpadded (ByteString -> StorageServerID)
-> Maybe ByteString -> Maybe StorageServerID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
storageServerAnnouncementPermutationSeed)
                    ]
            ]

{- | If possible, get the URI of a Great Black Swamp server from an
 announcement.
-}
greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI
greatBlackSwampURIs :: StorageServerAnnouncement -> Maybe URI
greatBlackSwampURIs =
    StorageServerID -> Maybe URI
parseURI' (StorageServerID -> Maybe URI)
-> (StorageServerAnnouncement -> StorageServerID)
-> StorageServerAnnouncement
-> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerID -> Maybe StorageServerID -> StorageServerID
forall a. a -> Maybe a -> a
fromMaybe StorageServerID
"" (Maybe StorageServerID -> StorageServerID)
-> (StorageServerAnnouncement -> Maybe StorageServerID)
-> StorageServerAnnouncement
-> StorageServerID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerAnnouncement -> Maybe StorageServerID
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' :: StorageServerID -> Maybe URI
parseURI' = String -> Maybe URI
Network.URI.parseURI (String -> Maybe URI)
-> (StorageServerID -> String) -> StorageServerID -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerID -> String
T.unpack (StorageServerID -> String)
-> (StorageServerID -> StorageServerID)
-> StorageServerID
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerID
-> StorageServerID -> StorageServerID -> StorageServerID
Data.Text.replace StorageServerID
"tcp:" StorageServerID
""