{-# 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 Codec.Serialise (Serialise)
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.STM (atomically, readTBQueue, writeTBQueue, newTBQueueIO)
import Control.Exception (onException)
import Control.Monad (forever)
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 :: [(IP, PortNumber)] -> (Connection -> Stream -> IO ()) -> IO ()
runServer [(IP, PortNumber)]
scAddresses Connection -> Stream -> IO ()
action = do
  Credentials
scCredentials <- IO Credentials
genCredentials
  let
    sc :: ServerConfig
sc = ServerConfig
defaultServerConfig
      { scCredentials
      , scAddresses
      }
  ServerConfig -> (Connection -> IO ()) -> IO ()
Server.run ServerConfig
sc \Connection
conn -> do
    Stream
defaultStream <- Connection -> IO Stream
acceptStream Connection
conn
    Connection -> Stream -> IO ()
action Connection
conn Stream
defaultStream

runServerSimple
  :: (Serialise q, Serialise r)
  => IP
  -> PortNumber
  -> (q -> IO r)
  -> IO ()
runServerSimple :: forall q r.
(Serialise q, Serialise r) =>
IP -> PortNumber -> (q -> IO r) -> IO ()
runServerSimple IP
host PortNumber
port q -> IO r
action =
  [(IP, PortNumber)] -> (Connection -> Stream -> IO ()) -> IO ()
runServer [(IP
host, PortNumber
port)] \Connection
_conn Stream
stream0 -> do
    (TBQueue r
writeQ, TBQueue q
readQ) <- Stream -> IO (TBQueue r, TBQueue q)
forall sendMsg recvMsg.
(Serialise sendMsg, Serialise recvMsg) =>
Stream -> IO (MessageQueues sendMsg recvMsg)
streamSerialise Stream
stream0
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
      q
query <- STM q -> IO q
forall a. STM a -> IO a
atomically (TBQueue q -> STM q
forall a. TBQueue a -> STM a
readTBQueue TBQueue q
readQ)
      r
reply <- q -> IO r
action q
query
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue r -> r -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue r
writeQ r
reply

runClient :: HostName -> ServiceName -> (Connection -> Stream -> IO ()) -> IO ()
runClient :: HostName -> HostName -> (Connection -> Stream -> IO ()) -> IO ()
runClient HostName
ccServerName HostName
ccPortName Connection -> Stream -> IO ()
action = do
  ClientConfig -> (Connection -> IO ()) -> IO ()
forall a. ClientConfig -> (Connection -> IO a) -> IO a
Client.run ClientConfig
cc \Connection
conn -> do
    Stream
defaultStream <- Connection -> IO Stream
stream Connection
conn
    Connection -> Stream -> IO ()
action Connection
conn Stream
defaultStream
  where
    cc :: ClientConfig
cc = ClientConfig
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 :: forall q r.
(Serialise q, Serialise r) =>
HostName -> HostName -> IO (IO (), q -> IO r)
startClientSimple HostName
host HostName
port = do
  MVar (TBQueue (q, r -> IO ()))
client <- IO (MVar (TBQueue (q, r -> IO ())))
forall a. IO (MVar a)
newEmptyMVar
  ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ HostName -> HostName -> (Connection -> Stream -> IO ()) -> IO ()
runClient HostName
host HostName
port \Connection
_conn Stream
stream0 -> do
    TBQueue (q, r -> IO ())
requests <- Natural -> IO (TBQueue (q, r -> IO ()))
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
16
    MVar (TBQueue (q, r -> IO ())) -> TBQueue (q, r -> IO ()) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (TBQueue (q, r -> IO ()))
client TBQueue (q, r -> IO ())
requests
    (TBQueue q
writeQ, TBQueue r
readQ) <- Stream -> IO (TBQueue q, TBQueue r)
forall sendMsg recvMsg.
(Serialise sendMsg, Serialise recvMsg) =>
Stream -> IO (MessageQueues sendMsg recvMsg)
streamSerialise Stream
stream0
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
      (q
query, r -> IO ()
handler) <- STM (q, r -> IO ()) -> IO (q, r -> IO ())
forall a. STM a -> IO a
atomically (STM (q, r -> IO ()) -> IO (q, r -> IO ()))
-> STM (q, r -> IO ()) -> IO (q, r -> IO ())
forall a b. (a -> b) -> a -> b
$ TBQueue (q, r -> IO ()) -> STM (q, r -> IO ())
forall a. TBQueue a -> STM a
readTBQueue TBQueue (q, r -> IO ())
requests
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue q -> q -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue q
writeQ q
query
      r
reply <- STM r -> IO r
forall a. STM a -> IO a
atomically (STM r -> IO r) -> STM r -> IO r
forall a b. (a -> b) -> a -> b
$ TBQueue r -> STM r
forall a. TBQueue a -> STM a
readTBQueue TBQueue r
readQ
      r -> IO ()
handler r
reply
  TBQueue (q, r -> IO ())
requests <- MVar (TBQueue (q, r -> IO ())) -> IO (TBQueue (q, r -> IO ()))
forall a. MVar a -> IO a
takeMVar MVar (TBQueue (q, r -> IO ()))
client IO (TBQueue (q, r -> IO ()))
-> IO () -> IO (TBQueue (q, r -> IO ()))
forall a b. IO a -> IO b -> IO a
`onException` ThreadId -> IO ()
killThread ThreadId
tid
  (IO (), q -> IO r) -> IO (IO (), q -> IO r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ThreadId -> IO ()
killThread ThreadId
tid
    , \q
query -> do
        MVar r
reply <- IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (q, r -> IO ()) -> (q, r -> IO ()) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (q, r -> IO ())
requests (q
query, MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
reply)
        MVar r -> IO r
forall a. MVar a -> IO a
takeMVar MVar r
reply
    )