{-# LANGUAGE ScopedTypeVariables #-}

module Network.Transport.QUIC.Internal.Server (forkServer) where

import Control.Concurrent (ThreadId, forkIOWithUnmask)
import Control.Exception (SomeException, catch, finally, mask, mask_)
import Data.List.NonEmpty (NonEmpty)
import Network.QUIC qualified as QUIC
import Network.QUIC.Server qualified as QUIC.Server
import Network.Socket (Socket)
import Network.Transport.QUIC.Internal.Configuration (Credential, mkServerConfig)

forkServer ::
  Socket ->
  NonEmpty Credential ->
  -- | Error handler that runs whenever an exception is thrown inside
  --  the thread that accepted an incoming connection
  (SomeException -> IO ()) ->
  -- | Termination handler that runs if the server thread catches an exception
  (SomeException -> IO ()) ->
  -- | Request handler. The stream is closed after this handler returns.
  (QUIC.Stream -> IO ()) ->
  IO ThreadId
forkServer :: Socket
-> NonEmpty Credential
-> (SomeException -> IO ())
-> (SomeException -> IO ())
-> (Stream -> IO ())
-> IO ThreadId
forkServer Socket
socket NonEmpty Credential
creds SomeException -> IO ()
errorHandler SomeException -> IO ()
terminationHandler Stream -> IO ()
requestHandler = do
  ServerConfig
serverConfig <- NonEmpty Credential -> IO ServerConfig
mkServerConfig NonEmpty Credential
creds

  let acceptConnection :: QUIC.Connection -> IO ()
      acceptConnection :: Connection -> IO ()
acceptConnection Connection
conn = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        Connection -> IO ()
QUIC.waitEstablished Connection
conn
        Stream
stream <- Connection -> IO Stream
QUIC.acceptStream Connection
conn

        IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
          (IO () -> IO ()
forall a. IO a -> IO a
restore (Stream -> IO ()
requestHandler Stream
stream IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Stream -> IO ()
QUIC.closeStream Stream
stream))
          SomeException -> IO ()
errorHandler

  -- We have to make sure that the exception handler is
  -- installed /before/ any asynchronous exception occurs. So we mask_, then
  -- forkIOWithUnmask (the child thread inherits the masked state from the parent), then
  -- unmask only inside the catch.
  --
  -- See the documentation for `forkIOWithUnmask`.
  IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask
      ( \forall a. IO a -> IO a
unmask ->
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
            (IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Socket] -> ServerConfig -> (Connection -> IO ()) -> IO ()
QUIC.Server.runWithSockets [Socket
socket] ServerConfig
serverConfig (\Connection
conn -> IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Connection -> IO ()
acceptConnection Connection
conn) SomeException -> IO ()
errorHandler))
            SomeException -> IO ()
terminationHandler
      )