Simple.hs

{-# LANGUAGE CPP #-}

module Network.QUIC.Simple
  ( -- * Basic wrappers
    runServer
  , runClient
    -- * CBOR/Serialise wrappers
  , Serialise
  , runServerSimple
  , startClientSimple
    -- * The rest of the QUIC API
  , module Network.QUIC
  ) where

import Network.QUIC
import Network.QUIC.Simple.Stream

import Control.Monad (forever)
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.STM (atomically, readTBQueue, writeTBQueue, newTBQueueIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Codec.Serialise (Serialise)
import Data.IP (IP(..))
import Network.QUIC.Client (ClientConfig(..), defaultClientConfig)
import Network.QUIC.Client qualified as Client
import Network.QUIC.Server (ServerConfig(..), defaultServerConfig)
import Network.QUIC.Server qualified as Server
import Network.QUIC.Simple.Credentials (genCredentials)
import Network.Socket (HostName, PortNumber, ServiceName)

runServer :: [(IP, PortNumber)] -> (Connection -> Stream -> IO ()) -> IO ()
runServer scAddresses action = do
  scCredentials <- genCredentials
  let
    sc = defaultServerConfig
      { scCredentials
      , scAddresses
      }
  Server.run sc \conn -> do
    defaultStream <- acceptStream conn
    action conn defaultStream

runServerSimple
  :: (Serialise q, Serialise r)
  => IP
  -> PortNumber
  -> (q -> IO r)
  -> IO ()
runServerSimple host port action =
  runServer [(host, port)] \_conn stream0 -> do
    (writeQ, readQ) <- streamSerialise stream0
    forever do
      query <- atomically (readTBQueue readQ)
      reply <- action query
      atomically $ writeTBQueue writeQ reply

runClient :: HostName -> ServiceName -> (Connection -> Stream -> IO ()) -> IO ()
runClient ccServerName ccPortName action = do
  Client.run cc \conn -> do
    defaultStream <- stream conn
    action conn defaultStream
  where
    cc = defaultClientConfig
      { ccServerName
      , ccPortName
      , ccValidate = False
#if MIN_VERSION_quic(0,2,10)
      , ccSockConnected = True
      , ccWatchDog = True
#endif
      }

startClientSimple
  :: (Serialise q, Serialise r)
  => HostName
  -> ServiceName
  -> IO (IO (), q -> IO r)
startClientSimple host port = do
  client <- newEmptyMVar
  tid <- forkIO $ runClient host port \_conn stream0 -> do
    requests <- newTBQueueIO 16
    putMVar client requests
    (writeQ, readQ) <- streamSerialise stream0
    forever do
      (query, handler) <- atomically $ readTBQueue requests
      atomically $ writeTBQueue writeQ query
      reply <- atomically $ readTBQueue readQ
      handler reply
  requests <- takeMVar client
  pure
    ( killThread tid
    , \query -> do
        reply <- newEmptyMVar
        atomically $ writeTBQueue requests (query, putMVar reply)
        takeMVar reply
    )