-- | QUIC v1 transport with libp2p mutual TLS authentication.
module LibP2P.Transport.QUIC
  ( newQUICTransport
  , canDialQUIC
  ) where

import Control.Concurrent.Async (Async, async, cancel, race, waitCatch)
import Control.Concurrent.STM
  ( TMVar
  , TQueue
  , atomically
  , newEmptyTMVarIO
  , newTQueueIO
  , putTMVar
  , readTQueue
  , readTMVar
  , tryPutTMVar
  , writeTQueue
  )
import Control.Exception (SomeException, displayException, onException, try)
import Control.Monad (void)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteString as BS
import Data.IP (IPv6, fromHostAddress6, toHostAddress6)
import Data.Word (Word32, Word8)
import Data.X509 (CertificateChain)
import Data.X509.Validation (FailedReason (..), SignatureFailure (..))
import LibP2P.Crypto.Key (KeyPair)
import LibP2P.Crypto.PeerId (PeerId)
import LibP2P.Multiaddr (Multiaddr (..))
import LibP2P.Multiaddr.Protocol (Protocol (..))
import LibP2P.MultistreamSelect.Negotiation (StreamIO (..))
import LibP2P.Transport
  ( ConnectionEndpoint (..)
  , Listener (..)
  , NativeMuxer (..)
  , RawConnection (..)
  , Transport (..)
  )
import LibP2P.Transport.QUIC.Certificate
  ( newQUICCredential
  , verifyQUICCertificate
  )
import qualified Network.QUIC as QUIC
import qualified Network.QUIC.Client as Client
import Network.QUIC.Internal
  ( ClientConfig (..)
  , Hooks (..)
  , ServerConfig (..)
  , Version (..)
  , defaultClientConfig
  , defaultHooks
  , defaultServerConfig
  )
import qualified Network.QUIC.Server as Server
import qualified Network.Socket as NS
import Network.TLS
  ( CertificateRejectReason (..)
  , CertificateUsage (..)
  , Credential
  , ClientHooks (..)
  , Credentials (..)
  , ServerHooks (..)
  )

libp2pALPN :: BS.ByteString
libp2pALPN :: ByteString
libp2pALPN = ByteString
"libp2p"

-- | Construct a QUIC transport using the node's long-term identity key.
newQUICTransport :: KeyPair -> IO Transport
newQUICTransport :: KeyPair -> IO Transport
newQUICTransport KeyPair
identity = do
  credential <- KeyPair -> IO Credential
newQUICCredential KeyPair
identity
  pure Transport
    { transportDial = dialQUIC credential
    , transportDialFrom = \Maybe Multiaddr
local Multiaddr
remote -> case Maybe Multiaddr
local of
        Maybe Multiaddr
Nothing -> Credential -> Multiaddr -> IO RawConnection
dialQUIC Credential
credential Multiaddr
remote
        Just Multiaddr
_ -> String -> IO RawConnection
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"QUIC transport does not support binding an existing listen address"
    , transportListen = listenQUIC credential
    , transportCanDial = canDialQUIC
    }

-- | Match RFC 9000 QUIC multiaddrs, with an optional trailing peer ID.
canDialQUIC :: Multiaddr -> Bool
canDialQUIC :: Multiaddr -> Bool
canDialQUIC Multiaddr
address = case Multiaddr -> Multiaddr
stripP2P Multiaddr
address of
  Multiaddr [IP4 Word32
_, UDP Word16
_, Protocol
QuicV1] -> Bool
True
  Multiaddr [IP6 ByteString
bytes, UDP Word16
_, Protocol
QuicV1] -> ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16
  Multiaddr
_ -> Bool
False

stripP2P :: Multiaddr -> Multiaddr
stripP2P :: Multiaddr -> Multiaddr
stripP2P (Multiaddr [Protocol]
protocols) = case [Protocol] -> [Protocol]
forall a. [a] -> [a]
reverse [Protocol]
protocols of
  P2P ByteString
_ : [Protocol]
rest -> [Protocol] -> Multiaddr
Multiaddr ([Protocol] -> [Protocol]
forall a. [a] -> [a]
reverse [Protocol]
rest)
  [Protocol]
_ -> [Protocol] -> Multiaddr
Multiaddr [Protocol]
protocols

dialQUIC :: Credential -> Multiaddr -> IO RawConnection
dialQUIC :: Credential -> Multiaddr -> IO RawConnection
dialQUIC Credential
credential Multiaddr
remoteAddress = do
  (host, port) <- (String -> IO (String, String))
-> ((String, String) -> IO (String, String))
-> Either String (String, String)
-> IO (String, String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (String, String)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String, String) -> IO (String, String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Multiaddr -> Either String (String, String)
multiaddrToHostPort Multiaddr
remoteAddress)
  authenticated <- newEmptyTMVarIO
  established <- newEmptyTMVarIO
  closed <- newEmptyTMVarIO
  let config = Credential
-> String -> String -> TMVar (Either String PeerId) -> ClientConfig
clientConfig Credential
credential String
host String
port TMVar (Either String PeerId)
authenticated
  worker <- async $ runClient config remoteAddress authenticated established closed
  result <- atomically $ readTMVar established
  case result of
    Left String
message -> Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker IO (Either SomeException ())
-> IO RawConnection -> IO RawConnection
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO RawConnection
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
message
    Right RawConnection
connection -> RawConnection -> IO RawConnection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawConnection
connection

runClient
  :: ClientConfig
  -> Multiaddr
  -> TMVar (Either String PeerId)
  -> TMVar (Either String RawConnection)
  -> TMVar ()
  -> IO ()
runClient :: ClientConfig
-> Multiaddr
-> TMVar (Either String PeerId)
-> TMVar (Either String RawConnection)
-> TMVar ()
-> IO ()
runClient ClientConfig
config Multiaddr
remoteAddress TMVar (Either String PeerId)
authenticated TMVar (Either String RawConnection)
established TMVar ()
closed = do
  outcome <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ClientConfig -> (Connection -> IO ()) -> IO ()
forall a. ClientConfig -> (Connection -> IO a) -> IO a
Client.run ClientConfig
config ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
connection -> do
    peerResult <- STM (Either String PeerId) -> IO (Either String PeerId)
forall a. STM a -> IO a
atomically (STM (Either String PeerId) -> IO (Either String PeerId))
-> STM (Either String PeerId) -> IO (Either String PeerId)
forall a b. (a -> b) -> a -> b
$ TMVar (Either String PeerId) -> STM (Either String PeerId)
forall a. TMVar a -> STM a
readTMVar TMVar (Either String PeerId)
authenticated
    peerId <- either fail pure peerResult
    info <- QUIC.getConnectionInfo connection
    localAddress <- sockAddrToMultiaddr (QUIC.localSockAddr info)
    raw <- makeQUICConnection connection peerId localAddress remoteAddress closed
    atomically $ putTMVar established (Right raw)
    atomically $ readTMVar closed
  case outcome of
    Left (SomeException
err :: SomeException) -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$
      TMVar (Either String RawConnection)
-> Either String RawConnection -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either String RawConnection)
established (String -> Either String RawConnection
forall a b. a -> Either a b
Left (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err))
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

clientConfig
  :: Credential
  -> String
  -> String
  -> TMVar (Either String PeerId)
  -> ClientConfig
clientConfig :: Credential
-> String -> String -> TMVar (Either String PeerId) -> ClientConfig
clientConfig Credential
credential String
host String
port TMVar (Either String PeerId)
authenticated =
  ClientConfig
defaultClientConfig
    { ccVersion = Version 1
    , ccVersions = [Version 1]
    , ccServerName = host
    , ccPortName = port
    , ccALPN = const (pure (Just [libp2pALPN]))
    , ccValidate = False
    , ccUseServerNameIndication = False
    , ccOnServerCertificate = validateServerCertificate authenticated
    , ccTlsHooks =
        (ccTlsHooks defaultClientConfig)
          { onCertificateRequest = const (pure (Just credential))
          }
    }

validateServerCertificate
  :: TMVar (Either String PeerId)
  -> certificateStore
  -> validationCache
  -> serviceId
  -> CertificateChain
  -> IO [FailedReason]
validateServerCertificate :: forall certificateStore validationCache serviceId.
TMVar (Either String PeerId)
-> certificateStore
-> validationCache
-> serviceId
-> CertificateChain
-> IO [FailedReason]
validateServerCertificate TMVar (Either String PeerId)
authenticated certificateStore
_ validationCache
_ serviceId
_ CertificateChain
chain = do
  result <- CertificateChain -> IO (Either String PeerId)
verifyQUICCertificate CertificateChain
chain
  atomically $ void (tryPutTMVar authenticated result)
  pure $ case result of
    Right PeerId
_ -> []
    Left String
_ -> [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
SignatureInvalid]

listenQUIC :: Credential -> Multiaddr -> IO Listener
listenQUIC :: Credential -> Multiaddr -> IO Listener
listenQUIC Credential
credential Multiaddr
requestedAddress = do
  socketAddress <- (String -> IO SockAddr)
-> (SockAddr -> IO SockAddr)
-> Either String SockAddr
-> IO SockAddr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO SockAddr
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Multiaddr -> Either String SockAddr
multiaddrToSockAddr Multiaddr
requestedAddress)
  socket <- openServerSocket socketAddress
  boundAddress <- NS.getSocketName socket >>= sockAddrToMultiaddr
  accepted <- newTQueueIO
  ready <- newEmptyTMVarIO
  let config = Credential -> TMVar () -> ServerConfig
serverConfig Credential
credential TMVar ()
ready
  worker <- async (Server.runWithSockets [socket] config (acceptQUIC accepted))
  waitForServer worker ready `onException` closeServer worker socket
  pure Listener
    { listenerAccept = atomically (readTQueue accepted)
    , listenerClose = closeServer worker socket
    , listenerAddr = boundAddress
    }

serverConfig :: Credential -> TMVar () -> ServerConfig
serverConfig :: Credential -> TMVar () -> ServerConfig
serverConfig Credential
credential TMVar ()
ready = ServerConfig
defaultServerConfig
  { scVersions = [Version 1]
  , scCredentials = Credentials [credential]
  , scRequireClientCert = True
  , scALPN = Just selectALPN
  , scHooks = defaultHooks {onServerReady = atomically (putTMVar ready ())}
  , scTlsHooks =
      (scTlsHooks defaultServerConfig)
        { onClientCertificate = authenticateClientCertificate
        , onUnverifiedClientCert = pure True
        }
  }

selectALPN :: Version -> [BS.ByteString] -> IO BS.ByteString
selectALPN :: Version -> [ByteString] -> IO ByteString
selectALPN Version
_ [ByteString]
protocols
  | ByteString
libp2pALPN ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
protocols = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
libp2pALPN
  | Bool
otherwise = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty

authenticateClientCertificate :: CertificateChain -> IO CertificateUsage
authenticateClientCertificate :: CertificateChain -> IO CertificateUsage
authenticateClientCertificate CertificateChain
chain = do
  result <- CertificateChain -> IO (Either String PeerId)
verifyQUICCertificate CertificateChain
chain
  pure $ case result of
    Right PeerId
_ -> CertificateUsage
CertificateUsageAccept
    Left String
_ -> CertificateRejectReason -> CertificateUsage
CertificateUsageReject
      (String -> CertificateRejectReason
CertificateRejectOther String
"libp2p identity certificate rejected")

acceptQUIC :: TQueue RawConnection -> QUIC.Connection -> IO ()
acceptQUIC :: TQueue RawConnection -> Connection -> IO ()
acceptQUIC TQueue RawConnection
accepted Connection
connection = do
  maybeChain <- Connection -> IO (Maybe CertificateChain)
Server.clientCertificateChain Connection
connection
  chain <- maybe (fail "QUIC client did not provide a certificate") pure maybeChain
  peerId <- verifyQUICCertificate chain >>= either fail pure
  info <- QUIC.getConnectionInfo connection
  localAddress <- sockAddrToMultiaddr (QUIC.localSockAddr info)
  remoteAddress <- sockAddrToMultiaddr (QUIC.remoteSockAddr info)
  closed <- newEmptyTMVarIO
  raw <- makeQUICConnection connection peerId localAddress remoteAddress closed
  atomically $ writeTQueue accepted raw
  atomically $ readTMVar closed

makeQUICConnection
  :: QUIC.Connection
  -> PeerId
  -> Multiaddr
  -> Multiaddr
  -> TMVar ()
  -> IO RawConnection
makeQUICConnection :: Connection
-> PeerId -> Multiaddr -> Multiaddr -> TMVar () -> IO RawConnection
makeQUICConnection Connection
connection PeerId
peerId Multiaddr
localAddress Multiaddr
remoteAddress TMVar ()
closed = do
  let close :: IO ()
close = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
closed ())
      native :: NativeMuxer
native = NativeMuxer
        { nativePeerId :: PeerId
nativePeerId = PeerId
peerId
        , nativeSecurity :: ProtocolId
nativeSecurity = ProtocolId
"/tls/1.0.0"
        , nativeMuxerProtocol :: ProtocolId
nativeMuxerProtocol = ProtocolId
"/quic-v1"
        , nativeOpenStream :: IO StreamIO
nativeOpenStream = Connection -> IO Stream
QUIC.stream Connection
connection IO Stream -> (Stream -> IO StreamIO) -> IO StreamIO
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream -> IO StreamIO
streamToStreamIO
        , nativeAcceptStream :: IO StreamIO
nativeAcceptStream = Connection -> IO Stream
QUIC.acceptStream Connection
connection IO Stream -> (Stream -> IO StreamIO) -> IO StreamIO
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream -> IO StreamIO
streamToStreamIO
        , nativeClose :: IO ()
nativeClose = IO ()
close
        }
  RawConnection -> IO RawConnection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawConnection
    { rcEndpoint :: ConnectionEndpoint
rcEndpoint = NativeMuxer -> ConnectionEndpoint
NativeMuxerEndpoint NativeMuxer
native
    , rcLocalAddr :: Multiaddr
rcLocalAddr = Multiaddr
localAddress
    , rcRemoteAddr :: Multiaddr
rcRemoteAddr = Multiaddr
remoteAddress
    , rcClose :: IO ()
rcClose = IO ()
close
    }

streamToStreamIO :: QUIC.Stream -> IO StreamIO
streamToStreamIO :: Stream -> IO StreamIO
streamToStreamIO Stream
stream = StreamIO -> IO StreamIO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StreamIO
  { streamWrite :: ByteString -> IO ()
streamWrite = Stream -> ByteString -> IO ()
QUIC.sendStream Stream
stream
  , streamReadByte :: IO Word8
streamReadByte = HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head (ByteString -> Word8) -> IO ByteString -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
receive Int
1
  , streamReadChunk :: Int -> IO ByteString
streamReadChunk = Int -> IO ByteString
receive
  , streamClose :: IO ()
streamClose = Stream -> IO ()
QUIC.closeStream Stream
stream
  }
  where
    receive :: Int -> IO ByteString
receive Int
size = do
      bytes <- Stream -> Int -> IO ByteString
QUIC.recvStream Stream
stream Int
size
      if BS.null bytes
        then fail "QUIC stream closed"
        else pure bytes

waitForServer :: Async () -> TMVar () -> IO ()
waitForServer :: Async () -> TMVar () -> IO ()
waitForServer Async ()
worker TMVar ()
ready = do
  result <- IO (Either SomeException ())
-> IO () -> IO (Either (Either SomeException ()) ())
forall a b. IO a -> IO b -> IO (Either a b)
race (Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker) (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar TMVar ()
ready)
  case result of
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Left (Left SomeException
err) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"QUIC listener failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err
    Left (Right ()) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"QUIC listener stopped before becoming ready"

closeServer :: Async () -> NS.Socket -> IO ()
closeServer :: Async () -> Socket -> IO ()
closeServer Async ()
worker Socket
socket = do
  Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
worker
  Socket -> IO ()
NS.close Socket
socket

openServerSocket :: NS.SockAddr -> IO NS.Socket
openServerSocket :: SockAddr -> IO Socket
openServerSocket SockAddr
address = do
  socket <- Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (SockAddr -> Family
socketFamily SockAddr
address) SocketType
NS.Datagram ProtocolNumber
NS.defaultProtocol
  (do
      NS.setSocketOption socket NS.ReuseAddr 1
      NS.withFdSocket socket NS.setCloseOnExecIfNeeded
      NS.bind socket address
      pure socket
    ) `onException` NS.close socket

multiaddrToHostPort :: Multiaddr -> Either String (String, String)
multiaddrToHostPort :: Multiaddr -> Either String (String, String)
multiaddrToHostPort Multiaddr
address = case Multiaddr -> Multiaddr
stripP2P Multiaddr
address of
  Multiaddr [IP4 Word32
word, UDP Word16
port, Protocol
QuicV1] -> (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right (Word32 -> String
renderIPv4 Word32
word, Word16 -> String
forall a. Show a => a -> String
show Word16
port)
  Multiaddr [IP6 ByteString
bytes, UDP Word16
port, Protocol
QuicV1]
    | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right (IPv6 -> String
forall a. Show a => a -> String
show (ByteString -> IPv6
bytesToIPv6 ByteString
bytes), Word16 -> String
forall a. Show a => a -> String
show Word16
port)
  Multiaddr
_ -> String -> Either String (String, String)
forall a b. a -> Either a b
Left String
"expected /ip4|ip6/.../udp/.../quic-v1"

multiaddrToSockAddr :: Multiaddr -> Either String NS.SockAddr
multiaddrToSockAddr :: Multiaddr -> Either String SockAddr
multiaddrToSockAddr Multiaddr
address = case Multiaddr -> Multiaddr
stripP2P Multiaddr
address of
  Multiaddr [IP4 Word32
word, UDP Word16
port, Protocol
QuicV1] -> SockAddr -> Either String SockAddr
forall a b. b -> Either a b
Right (SockAddr -> Either String SockAddr)
-> SockAddr -> Either String SockAddr
forall a b. (a -> b) -> a -> b
$
    PortNumber -> Word32 -> SockAddr
NS.SockAddrInet (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port)
      ((Word8, Word8, Word8, Word8) -> Word32
NS.tupleToHostAddress (Int -> Word32 -> Word8
octet Int
3 Word32
word, Int -> Word32 -> Word8
octet Int
2 Word32
word, Int -> Word32 -> Word8
octet Int
1 Word32
word, Int -> Word32 -> Word8
octet Int
0 Word32
word))
  Multiaddr [IP6 ByteString
bytes, UDP Word16
port, Protocol
QuicV1]
    | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> SockAddr -> Either String SockAddr
forall a b. b -> Either a b
Right (SockAddr -> Either String SockAddr)
-> SockAddr -> Either String SockAddr
forall a b. (a -> b) -> a -> b
$
        PortNumber -> Word32 -> HostAddress6 -> Word32 -> SockAddr
NS.SockAddrInet6 (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port) Word32
0 (IPv6 -> HostAddress6
toHostAddress6 (ByteString -> IPv6
bytesToIPv6 ByteString
bytes)) Word32
0
  Multiaddr
_ -> String -> Either String SockAddr
forall a b. a -> Either a b
Left String
"expected /ip4|ip6/.../udp/.../quic-v1"

sockAddrToMultiaddr :: NS.SockAddr -> IO Multiaddr
sockAddrToMultiaddr :: SockAddr -> IO Multiaddr
sockAddrToMultiaddr (NS.SockAddrInet PortNumber
port Word32
host) = do
  let (Word8
a, Word8
b, Word8
c, Word8
d) = Word32 -> (Word8, Word8, Word8, Word8)
NS.hostAddressToTuple Word32
host
      word :: Word32
word =
        (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
          Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
          Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
          Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d
  Multiaddr -> IO Multiaddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Multiaddr -> IO Multiaddr) -> Multiaddr -> IO Multiaddr
forall a b. (a -> b) -> a -> b
$ [Protocol] -> Multiaddr
Multiaddr [Word32 -> Protocol
IP4 Word32
word, Word16 -> Protocol
UDP (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port), Protocol
QuicV1]
sockAddrToMultiaddr (NS.SockAddrInet6 PortNumber
port Word32
_ HostAddress6
host Word32
_) =
  Multiaddr -> IO Multiaddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Multiaddr -> IO Multiaddr) -> Multiaddr -> IO Multiaddr
forall a b. (a -> b) -> a -> b
$ [Protocol] -> Multiaddr
Multiaddr [ByteString -> Protocol
IP6 (IPv6 -> ByteString
ipv6ToBytes (HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
host)), Word16 -> Protocol
UDP (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port), Protocol
QuicV1]
sockAddrToMultiaddr SockAddr
_ = String -> IO Multiaddr
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"QUIC transport only supports IPv4 and IPv6 sockets"

socketFamily :: NS.SockAddr -> NS.Family
socketFamily :: SockAddr -> Family
socketFamily NS.SockAddrInet {} = Family
NS.AF_INET
socketFamily NS.SockAddrInet6 {} = Family
NS.AF_INET6
socketFamily SockAddr
_ = Family
NS.AF_UNSPEC

octet :: Int -> Word32 -> Word8
octet :: Int -> Word32 -> Word8
octet Int
index Word32
word = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
word Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff)

renderIPv4 :: Word32 -> String
renderIPv4 :: Word32 -> String
renderIPv4 Word32
word =
  Word8 -> String
forall a. Show a => a -> String
show (Int -> Word32 -> Word8
octet Int
3 Word32
word) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show (Int -> Word32 -> Word8
octet Int
2 Word32
word)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show (Int -> Word32 -> Word8
octet Int
1 Word32
word) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show (Int -> Word32 -> Word8
octet Int
0 Word32
word)

bytesToIPv6 :: BS.ByteString -> IPv6
bytesToIPv6 :: ByteString -> IPv6
bytesToIPv6 ByteString
bytes = HostAddress6 -> IPv6
fromHostAddress6
  ( Int -> Word32
forall {a}. (Bits a, Num a) => Int -> a
readWord32 Int
0
  , Int -> Word32
forall {a}. (Bits a, Num a) => Int -> a
readWord32 Int
4
  , Int -> Word32
forall {a}. (Bits a, Num a) => Int -> a
readWord32 Int
8
  , Int -> Word32
forall {a}. (Bits a, Num a) => Int -> a
readWord32 Int
12
  )
  where
    readWord32 :: Int -> a
readWord32 Int
offset =
      (Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bytes Int
offset) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
        a -> a -> a
forall a. Bits a => a -> a -> a
.|. (Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bytes (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
        a -> a -> a
forall a. Bits a => a -> a -> a
.|. (Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bytes (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
        a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bytes (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3))

ipv6ToBytes :: IPv6 -> BS.ByteString
ipv6ToBytes :: IPv6 -> ByteString
ipv6ToBytes IPv6
ipv6 = [Word8] -> ByteString
BS.pack ((Word32 -> [Word8]) -> [Word32] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word32 -> [Word8]
forall {a} {a}. (Integral a, Bits a, Num a) => a -> [a]
word32Bytes [Word32]
words32)
  where
    (Word32
a, Word32
b, Word32
c, Word32
d) = IPv6 -> HostAddress6
toHostAddress6 IPv6
ipv6
    words32 :: [Word32]
words32 = [Word32
a, Word32
b, Word32
c, Word32
d]
    word32Bytes :: a -> [a]
word32Bytes a
word =
      [ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
word a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
      , a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
word a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
      , a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
word a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
      , a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
word
      ]