-- | Peer routing records (RFC 0003).
--
-- A PeerRecord is a self-certified statement of a peer's dialable
-- addresses, distributed inside a "LibP2P.Crypto.SignedEnvelope"
-- (RFC 0002). Consumers verify the envelope signature and that the
-- signing key derives the peer id named in the record, giving
-- third-party-relayable address information that cannot be forged.
--
-- Wire format (go-libp2p @core/peer/pb/peer_record.proto@):
--
-- > message PeerRecord {
-- >   message AddressInfo { bytes multiaddr = 1; }
-- >   bytes peer_id = 1;
-- >   uint64 seq = 2;
-- >   repeated AddressInfo addresses = 3;
-- > }
--
-- Envelope parameters (go-libp2p @core/peer/record.go@ — note the RFC
-- 0003 draft text uses different strings; the deployed go-libp2p values
-- are authoritative for interop):
--
--   * domain: @libp2p-peer-record@
--   * payload type: the raw multicodec bytes @0x03 0x01@
--     (multicodec table name @libp2p-peer-record@)
module LibP2P.Crypto.PeerRecord
  ( -- * Record type
    PeerRecord (..)
  , timestampSeq
    -- * Protobuf codec
  , encodePeerRecord
  , decodePeerRecord
    -- * Envelope integration
  , peerRecordEnvelopeDomain
  , peerRecordEnvelopePayloadType
  , sealPeerRecord
  , openPeerRecordEnvelope
  ) where

import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word64)
import LibP2P.Crypto.Key (KeyPair (..))
import LibP2P.Crypto.PeerId (fromPublicKey, peerIdBytes)
import LibP2P.Crypto.SignedEnvelope
  ( SignedEnvelope (..)
  , createEnvelope
  , decodeSignedEnvelope
  , verifyEnvelope
  )
import qualified Proto3.Wire.Decode as Decode
import Proto3.Wire.Decode (Parser, RawMessage, at, embedded', one, parse, repeated)
import qualified Proto3.Wire.Encode as Encode
import Proto3.Wire.Types (FieldNumber (..))
import System.IO.Unsafe (unsafePerformIO)

-- | A routing record: which addresses a peer claims to be reachable at.
data PeerRecord = PeerRecord
  { PeerRecord -> ByteString
prPeerId    :: !ByteString   -- ^ Peer id bytes (multihash of the public key)
  , PeerRecord -> Word64
prSeq       :: !Word64       -- ^ Monotonic sequence number (see 'timestampSeq')
  , PeerRecord -> [ByteString]
prAddresses :: ![ByteString] -- ^ Binary multiaddrs (one per wrapped AddressInfo)
  } deriving (Int -> PeerRecord -> ShowS
[PeerRecord] -> ShowS
PeerRecord -> [Char]
(Int -> PeerRecord -> ShowS)
-> (PeerRecord -> [Char])
-> ([PeerRecord] -> ShowS)
-> Show PeerRecord
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerRecord -> ShowS
showsPrec :: Int -> PeerRecord -> ShowS
$cshow :: PeerRecord -> [Char]
show :: PeerRecord -> [Char]
$cshowList :: [PeerRecord] -> ShowS
showList :: [PeerRecord] -> ShowS
Show, PeerRecord -> PeerRecord -> Bool
(PeerRecord -> PeerRecord -> Bool)
-> (PeerRecord -> PeerRecord -> Bool) -> Eq PeerRecord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerRecord -> PeerRecord -> Bool
== :: PeerRecord -> PeerRecord -> Bool
$c/= :: PeerRecord -> PeerRecord -> Bool
/= :: PeerRecord -> PeerRecord -> Bool
Eq)

-- | Domain separation string for peer-record envelopes
-- (go-libp2p @PeerRecordEnvelopeDomain@).
peerRecordEnvelopeDomain :: ByteString
peerRecordEnvelopeDomain :: ByteString
peerRecordEnvelopeDomain = ByteString
"libp2p-peer-record"

-- | Envelope payload type: the @libp2p-peer-record@ multicodec bytes
-- (go-libp2p @PeerRecordEnvelopePayloadType@).
peerRecordEnvelopePayloadType :: ByteString
peerRecordEnvelopePayloadType :: ByteString
peerRecordEnvelopePayloadType = [Word8] -> ByteString
BS.pack [Word8
0x03, Word8
0x01]

{-# NOINLINE lastSeqRef #-}
lastSeqRef :: IORef Word64
lastSeqRef :: IORef Word64
lastSeqRef = IO (IORef Word64) -> IORef Word64
forall a. IO a -> a
unsafePerformIO (Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
newIORef Word64
0)

-- | A timestamp-based, strictly monotonic sequence number: the current
-- Unix time in nanoseconds, bumped past the previous value if the clock
-- has not advanced (mirrors go-libp2p @peer.TimestampSeq@).
timestampSeq :: IO Word64
timestampSeq :: IO Word64
timestampSeq = do
  now <- Rational -> Word64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Word64)
-> (POSIXTime -> Rational) -> POSIXTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1e9) (Rational -> Rational)
-> (POSIXTime -> Rational) -> POSIXTime -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Rational
forall a. Real a => a -> Rational
toRational (POSIXTime -> Word64) -> IO POSIXTime -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
  atomicModifyIORef' lastSeqRef $ \Word64
prev ->
    let next :: Word64
next = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
now (Word64
prev Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) in (Word64
next, Word64
next)

-- | Encode a PeerRecord to protobuf wire format. Proto3 default values
-- (empty peer_id, zero seq) are omitted, matching go-libp2p's encoder.
encodePeerRecord :: PeerRecord -> ByteString
encodePeerRecord :: PeerRecord -> ByteString
encodePeerRecord PeerRecord
pr = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MessageBuilder -> LazyByteString
Encode.toLazyByteString (MessageBuilder -> LazyByteString)
-> MessageBuilder -> LazyByteString
forall a b. (a -> b) -> a -> b
$
     (if ByteString -> Bool
BS.null (PeerRecord -> ByteString
prPeerId PeerRecord
pr)
        then MessageBuilder
forall a. Monoid a => a
mempty
        else FieldNumber -> ByteString -> MessageBuilder
Encode.byteString (Word64 -> FieldNumber
FieldNumber Word64
1) (PeerRecord -> ByteString
prPeerId PeerRecord
pr))
  MessageBuilder -> MessageBuilder -> MessageBuilder
forall a. Semigroup a => a -> a -> a
<> (if PeerRecord -> Word64
prSeq PeerRecord
pr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
        then MessageBuilder
forall a. Monoid a => a
mempty
        else FieldNumber -> Word64 -> MessageBuilder
Encode.uint64 (Word64 -> FieldNumber
FieldNumber Word64
2) (PeerRecord -> Word64
prSeq PeerRecord
pr))
  MessageBuilder -> MessageBuilder -> MessageBuilder
forall a. Semigroup a => a -> a -> a
<> (ByteString -> MessageBuilder) -> [ByteString] -> MessageBuilder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
       (FieldNumber -> MessageBuilder -> MessageBuilder
Encode.embedded (Word64 -> FieldNumber
FieldNumber Word64
3) (MessageBuilder -> MessageBuilder)
-> (ByteString -> MessageBuilder) -> ByteString -> MessageBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> ByteString -> MessageBuilder
Encode.byteString (Word64 -> FieldNumber
FieldNumber Word64
1))
       (PeerRecord -> [ByteString]
prAddresses PeerRecord
pr)

-- | Decode a PeerRecord from protobuf wire format.
decodePeerRecord :: ByteString -> Either String PeerRecord
decodePeerRecord :: ByteString -> Either [Char] PeerRecord
decodePeerRecord ByteString
bs = case Parser RawMessage PeerRecord
-> ByteString -> Either ParseError PeerRecord
forall a. Parser RawMessage a -> ByteString -> Either ParseError a
parse Parser RawMessage PeerRecord
peerRecordParser ByteString
bs of
  Left ParseError
err     -> [Char] -> Either [Char] PeerRecord
forall a b. a -> Either a b
Left ([Char] -> Either [Char] PeerRecord)
-> [Char] -> Either [Char] PeerRecord
forall a b. (a -> b) -> a -> b
$ [Char]
"PeerRecord decode error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
err
  Right PeerRecord
record -> PeerRecord -> Either [Char] PeerRecord
forall a b. b -> Either a b
Right PeerRecord
record

peerRecordParser :: Parser RawMessage PeerRecord
peerRecordParser :: Parser RawMessage PeerRecord
peerRecordParser = ByteString -> Word64 -> [ByteString] -> PeerRecord
PeerRecord
  (ByteString -> Word64 -> [ByteString] -> PeerRecord)
-> Parser RawMessage ByteString
-> Parser RawMessage (Word64 -> [ByteString] -> PeerRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RawField ByteString
-> FieldNumber -> Parser RawMessage ByteString
forall a. Parser RawField a -> FieldNumber -> Parser RawMessage a
at (Parser RawPrimitive ByteString
-> ByteString -> Parser RawField ByteString
forall a. Parser RawPrimitive a -> a -> Parser RawField a
one Parser RawPrimitive ByteString
Decode.byteString ByteString
BS.empty) (Word64 -> FieldNumber
FieldNumber Word64
1)
  Parser RawMessage (Word64 -> [ByteString] -> PeerRecord)
-> Parser RawMessage Word64
-> Parser RawMessage ([ByteString] -> PeerRecord)
forall a b.
Parser RawMessage (a -> b)
-> Parser RawMessage a -> Parser RawMessage b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RawField Word64 -> FieldNumber -> Parser RawMessage Word64
forall a. Parser RawField a -> FieldNumber -> Parser RawMessage a
at (Parser RawPrimitive Word64 -> Word64 -> Parser RawField Word64
forall a. Parser RawPrimitive a -> a -> Parser RawField a
one Parser RawPrimitive Word64
Decode.uint64 Word64
0) (Word64 -> FieldNumber
FieldNumber Word64
2)
  Parser RawMessage ([ByteString] -> PeerRecord)
-> Parser RawMessage [ByteString] -> Parser RawMessage PeerRecord
forall a b.
Parser RawMessage (a -> b)
-> Parser RawMessage a -> Parser RawMessage b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RawField [ByteString]
-> FieldNumber -> Parser RawMessage [ByteString]
forall a. Parser RawField a -> FieldNumber -> Parser RawMessage a
at (Parser RawPrimitive ByteString -> Parser RawField [ByteString]
forall a. Parser RawPrimitive a -> Parser RawField [a]
repeated (Parser RawMessage ByteString -> Parser RawPrimitive ByteString
forall a. Parser RawMessage a -> Parser RawPrimitive a
embedded' Parser RawMessage ByteString
addressInfoParser)) (Word64 -> FieldNumber
FieldNumber Word64
3)

addressInfoParser :: Parser RawMessage ByteString
addressInfoParser :: Parser RawMessage ByteString
addressInfoParser = Parser RawField ByteString
-> FieldNumber -> Parser RawMessage ByteString
forall a. Parser RawField a -> FieldNumber -> Parser RawMessage a
at (Parser RawPrimitive ByteString
-> ByteString -> Parser RawField ByteString
forall a. Parser RawPrimitive a -> a -> Parser RawField a
one Parser RawPrimitive ByteString
Decode.byteString ByteString
BS.empty) (Word64 -> FieldNumber
FieldNumber Word64
1)

-- | Seal a PeerRecord into a SignedEnvelope with the given identity key.
-- The caller is responsible for the record's peer id matching the key
-- (a mismatched record still seals, but no verifier will accept it).
sealPeerRecord :: KeyPair -> PeerRecord -> Either String SignedEnvelope
sealPeerRecord :: KeyPair -> PeerRecord -> Either [Char] SignedEnvelope
sealPeerRecord KeyPair
kp PeerRecord
record =
  PrivateKey
-> PublicKey
-> ByteString
-> ByteString
-> ByteString
-> Either [Char] SignedEnvelope
createEnvelope (KeyPair -> PrivateKey
kpPrivate KeyPair
kp) (KeyPair -> PublicKey
kpPublic KeyPair
kp)
    ByteString
peerRecordEnvelopeDomain ByteString
peerRecordEnvelopePayloadType
    (PeerRecord -> ByteString
encodePeerRecord PeerRecord
record)

-- | Open an encoded peer-record envelope: decode it, check the payload
-- type, verify the signature under the peer-record domain, decode the
-- record, and require that the envelope's key derives the peer id the
-- record claims. Any failure rejects the envelope.
openPeerRecordEnvelope :: ByteString -> Either String (SignedEnvelope, PeerRecord)
openPeerRecordEnvelope :: ByteString -> Either [Char] (SignedEnvelope, PeerRecord)
openPeerRecordEnvelope ByteString
bs = do
  env <- ByteString -> Either [Char] SignedEnvelope
decodeSignedEnvelope ByteString
bs
  unless (sePayloadType env == peerRecordEnvelopePayloadType) $
    Left "peer record envelope: unexpected payload type"
  unless (verifyEnvelope env peerRecordEnvelopeDomain) $
    Left "peer record envelope: invalid signature"
  record <- decodePeerRecord (sePayload env)
  unless (peerIdBytes (fromPublicKey (sePublicKey env)) == prPeerId record) $
    Left "peer record envelope: key does not derive the record's peer id"
  Right (env, record)