{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Convenience functions for running a HTTP2 server
--
-- Intended for unqualified import.
module Network.GRPC.Server.Run (
    -- * Configuration
    ServerConfig(..)
  , InsecureConfig(..)
  , SecureConfig(..)
    -- * Simple interface
  , runServer
  , runServerWithHandlers
    -- * Full interface
  , RunningServer -- opaque
  , forkServer
  , waitServer
  , waitServerSTM
  , getInsecureSocket
  , getSecureSocket
  , getServerSocket
  , getServerPort
    -- * Exceptions
  , ServerTerminated(..)
  , CouldNotLoadCredentials(..)
  ) where

import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Default
import GHC.Generics (Generic)
import Network.HTTP2.Server qualified as HTTP2
import Network.HTTP2.TLS.Server qualified as HTTP2.TLS
import Network.Run.TCP qualified as Run
import Network.Socket
import Network.TLS qualified as TLS

#if MIN_VERSION_network_run(0,4,4)
import Data.List.NonEmpty qualified as NE
#endif

import Network.GRPC.Common.HTTP2Settings
import Network.GRPC.Server
import Network.GRPC.Util.HTTP2
import Network.GRPC.Util.TLS (SslKeyLog(..))
import Network.GRPC.Util.TLS qualified as Util.TLS

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

-- | Server configuration
--
-- Describes the configuration of both an insecure server and a secure server.
-- See the documentation of 'runServer' for a description of what servers will
-- result from various configurations.
data ServerConfig = ServerConfig {
      -- | Configuration for insecure communication (without TLS)
      --
      -- Set to 'Nothing' to disable.
      ServerConfig -> Maybe InsecureConfig
serverInsecure :: Maybe InsecureConfig

      -- | Configuration for secure communication (over TLS)
      --
      -- Set to 'Nothing' to disable.
    , ServerConfig -> Maybe SecureConfig
serverSecure :: Maybe SecureConfig
    }
  deriving stock (Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> [Char]
(Int -> ServerConfig -> ShowS)
-> (ServerConfig -> [Char])
-> ([ServerConfig] -> ShowS)
-> Show ServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerConfig -> ShowS
showsPrec :: Int -> ServerConfig -> ShowS
$cshow :: ServerConfig -> [Char]
show :: ServerConfig -> [Char]
$cshowList :: [ServerConfig] -> ShowS
showList :: [ServerConfig] -> ShowS
Show, (forall x. ServerConfig -> Rep ServerConfig x)
-> (forall x. Rep ServerConfig x -> ServerConfig)
-> Generic ServerConfig
forall x. Rep ServerConfig x -> ServerConfig
forall x. ServerConfig -> Rep ServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerConfig -> Rep ServerConfig x
from :: forall x. ServerConfig -> Rep ServerConfig x
$cto :: forall x. Rep ServerConfig x -> ServerConfig
to :: forall x. Rep ServerConfig x -> ServerConfig
Generic)

-- | Offer insecure connection (no TLS)
data InsecureConfig =
    -- | Insecure TCP connection
    InsecureConfig {
      -- | Hostname
      InsecureConfig -> Maybe [Char]
insecureHost :: Maybe HostName

      -- | Port number
      --
      -- Can use @0@ to let the server pick its own port. This can be useful in
      -- testing scenarios; see 'getServerPort' or the more general
      -- 'getInsecureSocket' for a way to figure out what this port actually is.
    , InsecureConfig -> PortNumber
insecurePort :: PortNumber
    }
    -- | Insecure (but local) Unix domain socket connection
  | InsecureUnix {
      -- | Path to the socket
      InsecureConfig -> [Char]
insecurePath :: FilePath
    }
  deriving stock (Int -> InsecureConfig -> ShowS
[InsecureConfig] -> ShowS
InsecureConfig -> [Char]
(Int -> InsecureConfig -> ShowS)
-> (InsecureConfig -> [Char])
-> ([InsecureConfig] -> ShowS)
-> Show InsecureConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InsecureConfig -> ShowS
showsPrec :: Int -> InsecureConfig -> ShowS
$cshow :: InsecureConfig -> [Char]
show :: InsecureConfig -> [Char]
$cshowList :: [InsecureConfig] -> ShowS
showList :: [InsecureConfig] -> ShowS
Show, (forall x. InsecureConfig -> Rep InsecureConfig x)
-> (forall x. Rep InsecureConfig x -> InsecureConfig)
-> Generic InsecureConfig
forall x. Rep InsecureConfig x -> InsecureConfig
forall x. InsecureConfig -> Rep InsecureConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InsecureConfig -> Rep InsecureConfig x
from :: forall x. InsecureConfig -> Rep InsecureConfig x
$cto :: forall x. Rep InsecureConfig x -> InsecureConfig
to :: forall x. Rep InsecureConfig x -> InsecureConfig
Generic)

-- | Offer secure connection (over TLS)
data SecureConfig = SecureConfig {
      -- | Hostname to bind to
      --
      -- Unlike in 'InsecureConfig', the 'HostName' is required here, because it
      -- must match the certificate.
      --
      -- This doesn't need to match the common name (CN) in the TLS certificate.
      -- For example, if the client connects to @127.0.0.1@, and the certificate
      -- CN is also @127.0.0.1@, the server can still bind to @0.0.0.0@.
      SecureConfig -> [Char]
secureHost :: HostName

      -- | Port number
      --
      -- See 'insecurePort' for additional discussion.
    , SecureConfig -> PortNumber
securePort :: PortNumber

      -- | TLS public certificate (X.509 format)
    , SecureConfig -> [Char]
securePubCert :: FilePath

      -- | TLS chain certificates (X.509 format)
    , SecureConfig -> [[Char]]
secureChainCerts :: [FilePath]

      -- | TLS private key
    , SecureConfig -> [Char]
securePrivKey :: FilePath

      -- | SSL key log
    , SecureConfig -> SslKeyLog
secureSslKeyLog :: SslKeyLog
    }
  deriving stock (Int -> SecureConfig -> ShowS
[SecureConfig] -> ShowS
SecureConfig -> [Char]
(Int -> SecureConfig -> ShowS)
-> (SecureConfig -> [Char])
-> ([SecureConfig] -> ShowS)
-> Show SecureConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SecureConfig -> ShowS
showsPrec :: Int -> SecureConfig -> ShowS
$cshow :: SecureConfig -> [Char]
show :: SecureConfig -> [Char]
$cshowList :: [SecureConfig] -> ShowS
showList :: [SecureConfig] -> ShowS
Show, (forall x. SecureConfig -> Rep SecureConfig x)
-> (forall x. Rep SecureConfig x -> SecureConfig)
-> Generic SecureConfig
forall x. Rep SecureConfig x -> SecureConfig
forall x. SecureConfig -> Rep SecureConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SecureConfig -> Rep SecureConfig x
from :: forall x. SecureConfig -> Rep SecureConfig x
$cto :: forall x. Rep SecureConfig x -> SecureConfig
to :: forall x. Rep SecureConfig x -> SecureConfig
Generic)

{-------------------------------------------------------------------------------
  Simple interface
-------------------------------------------------------------------------------}

-- | Run a 'HTTP2.Server' with the given 'ServerConfig'.
--
-- If both configurations are disabled, 'runServer' will simply immediately
-- return. If both configurations are enabled, then two servers will be run
-- concurrently; one with the insecure configuration and the other with the
-- secure configuration. Obviously, if only one of the configurations is
-- enabled, then just that server will be run.
--
-- See also 'runServerWithHandlers', which handles the creation of the
-- 'HTTP2.Server' for you.
runServer :: HTTP2Settings -> ServerConfig -> HTTP2.Server -> IO ()
runServer :: HTTP2Settings -> ServerConfig -> Server -> IO ()
runServer HTTP2Settings
http2 ServerConfig
cfg Server
server = HTTP2Settings
-> ServerConfig -> Server -> (RunningServer -> IO ()) -> IO ()
forall a.
HTTP2Settings
-> ServerConfig -> Server -> (RunningServer -> IO a) -> IO a
forkServer HTTP2Settings
http2 ServerConfig
cfg Server
server ((RunningServer -> IO ()) -> IO ())
-> (RunningServer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ RunningServer -> IO ()
waitServer

-- | Convenience function that combines 'runServer' with 'mkGrpcServer'
--
-- NOTE: If you want to override the 'HTTP2Settings', use 'runServer' instead.
runServerWithHandlers ::
     ServerParams
  -> ServerConfig
  -> [SomeRpcHandler IO]
  -> IO ()
runServerWithHandlers :: ServerParams -> ServerConfig -> [SomeRpcHandler IO] -> IO ()
runServerWithHandlers ServerParams
params ServerConfig
config [SomeRpcHandler IO]
handlers = do
    server <- ServerParams -> [SomeRpcHandler IO] -> IO Server
mkGrpcServer ServerParams
params [SomeRpcHandler IO]
handlers
    runServer http2 config server
  where
    http2 :: HTTP2Settings
    http2 :: HTTP2Settings
http2 = HTTP2Settings
forall a. Default a => a
def

{-------------------------------------------------------------------------------
  Full interface
-------------------------------------------------------------------------------}

data RunningServer = RunningServer {
      -- | Insecure server (no TLS)
      --
      -- If the insecure server is disabled, this will be a trivial "Async' that
      -- immediately completes.
      RunningServer -> Async ()
runningServerInsecure :: Async ()

      -- | Secure server (with TLS)
      --
      -- Similar remarks apply as for 'runningInsecure'.
    , RunningServer -> Async ()
runningServerSecure :: Async ()

      -- | Socket used by the insecure server
      --
      -- See 'getInsecureSocket'.
    , RunningServer -> TMVar Socket
runningSocketInsecure :: TMVar Socket

      -- | Socket used by the secure server
      --
      -- See 'getSecureSocket'.
    , RunningServer -> TMVar Socket
runningSocketSecure :: TMVar Socket
    }

data ServerTerminated = ServerTerminated
  deriving stock (Int -> ServerTerminated -> ShowS
[ServerTerminated] -> ShowS
ServerTerminated -> [Char]
(Int -> ServerTerminated -> ShowS)
-> (ServerTerminated -> [Char])
-> ([ServerTerminated] -> ShowS)
-> Show ServerTerminated
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerTerminated -> ShowS
showsPrec :: Int -> ServerTerminated -> ShowS
$cshow :: ServerTerminated -> [Char]
show :: ServerTerminated -> [Char]
$cshowList :: [ServerTerminated] -> ShowS
showList :: [ServerTerminated] -> ShowS
Show)
  deriving anyclass (Show ServerTerminated
Typeable ServerTerminated
(Typeable ServerTerminated, Show ServerTerminated) =>
(ServerTerminated -> SomeException)
-> (SomeException -> Maybe ServerTerminated)
-> (ServerTerminated -> [Char])
-> (ServerTerminated -> Bool)
-> Exception ServerTerminated
SomeException -> Maybe ServerTerminated
ServerTerminated -> Bool
ServerTerminated -> [Char]
ServerTerminated -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> (e -> Bool)
-> Exception e
$ctoException :: ServerTerminated -> SomeException
toException :: ServerTerminated -> SomeException
$cfromException :: SomeException -> Maybe ServerTerminated
fromException :: SomeException -> Maybe ServerTerminated
$cdisplayException :: ServerTerminated -> [Char]
displayException :: ServerTerminated -> [Char]
$cbacktraceDesired :: ServerTerminated -> Bool
backtraceDesired :: ServerTerminated -> Bool
Exception)

-- | Start the server
forkServer ::
     HTTP2Settings
  -> ServerConfig
  -> HTTP2.Server
  -> (RunningServer -> IO a)
  -> IO a
forkServer :: forall a.
HTTP2Settings
-> ServerConfig -> Server -> (RunningServer -> IO a) -> IO a
forkServer HTTP2Settings
http2 ServerConfig{Maybe InsecureConfig
serverInsecure :: ServerConfig -> Maybe InsecureConfig
serverInsecure :: Maybe InsecureConfig
serverInsecure, Maybe SecureConfig
serverSecure :: ServerConfig -> Maybe SecureConfig
serverSecure :: Maybe SecureConfig
serverSecure} Server
server RunningServer -> IO a
k = do
    runningSocketInsecure <- IO (TMVar Socket)
forall a. IO (TMVar a)
newEmptyTMVarIO
    runningSocketSecure   <- newEmptyTMVarIO

    let secure, insecure :: IO ()
        insecure =
          case Maybe InsecureConfig
serverInsecure of
            Maybe InsecureConfig
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just InsecureConfig
cfg -> HTTP2Settings -> InsecureConfig -> TMVar Socket -> Server -> IO ()
runInsecure HTTP2Settings
http2 InsecureConfig
cfg TMVar Socket
runningSocketInsecure Server
server
        secure =
          case Maybe SecureConfig
serverSecure of
            Maybe SecureConfig
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just SecureConfig
cfg -> HTTP2Settings -> SecureConfig -> TMVar Socket -> Server -> IO ()
runSecure HTTP2Settings
http2 SecureConfig
cfg TMVar Socket
runningSocketSecure Server
server

    withAsync insecure $ \Async ()
runningServerInsecure ->
      IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
secure ((Async () -> IO a) -> IO a) -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async ()
runningServerSecure ->
        RunningServer -> IO a
k RunningServer{
              Async ()
runningServerInsecure :: Async ()
runningServerInsecure :: Async ()
runningServerInsecure
            , Async ()
runningServerSecure :: Async ()
runningServerSecure :: Async ()
runningServerSecure
            , TMVar Socket
runningSocketInsecure :: TMVar Socket
runningSocketInsecure :: TMVar Socket
runningSocketInsecure
            , TMVar Socket
runningSocketSecure :: TMVar Socket
runningSocketSecure :: TMVar Socket
runningSocketSecure
            }

-- | Wait for the server to terminate
--
-- Returns the results of the insecure and secure servers separately.
-- Note that under normal circumstances the server /never/ terminates.
waitServerSTM ::
     RunningServer
  -> STM ( Either SomeException ()
         , Either SomeException ()
         )
waitServerSTM :: RunningServer
-> STM (Either SomeException (), Either SomeException ())
waitServerSTM RunningServer
server = do
    insecure <- Async () -> STM (Either SomeException ())
forall a. Async a -> STM (Either SomeException a)
waitCatchSTM (RunningServer -> Async ()
runningServerInsecure RunningServer
server)
    secure   <- waitCatchSTM (runningServerSecure   server)
    return (insecure, secure)

-- | IO version of 'waitServerSTM' that rethrows exceptions
waitServer :: RunningServer -> IO ()
waitServer :: RunningServer -> IO ()
waitServer RunningServer
server =
    STM (Either SomeException (), Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a. STM a -> IO a
atomically (RunningServer
-> STM (Either SomeException (), Either SomeException ())
waitServerSTM RunningServer
server) IO (Either SomeException (), Either SomeException ())
-> ((Either SomeException (), Either SomeException ()) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Right (), Right ()) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (Left  SomeException
e , Either SomeException ()
_       ) -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
      (Either SomeException ()
_       , Left  SomeException
e ) -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e

-- | Get the socket used by the insecure server
--
-- The socket is created as the server initializes; this function will block
-- until that is complete. However:
--
-- * If the server throws an exception, that exception is rethrown here.
-- * If the server has already terminated, we throw 'ServerTerminated'
-- * If the insecure server was not enabled, it is considered to have terminated
--   immediately and the same 'ServerTerminated' exception is thrown.
getInsecureSocket :: RunningServer -> STM Socket
getInsecureSocket :: RunningServer -> STM Socket
getInsecureSocket RunningServer
server = do
    Async () -> TMVar Socket -> STM Socket
getSocket (RunningServer -> Async ()
runningServerInsecure RunningServer
server)
              (RunningServer -> TMVar Socket
runningSocketInsecure RunningServer
server)

-- | Get the socket used by the secure server
--
-- Similar remarks apply as for 'getInsecureSocket'.
getSecureSocket :: RunningServer -> STM Socket
getSecureSocket :: RunningServer -> STM Socket
getSecureSocket RunningServer
server = do
    Async () -> TMVar Socket -> STM Socket
getSocket (RunningServer -> Async ()
runningServerSecure RunningServer
server)
              (RunningServer -> TMVar Socket
runningSocketSecure RunningServer
server)

-- | Get \"the\" socket associated with the server
--
-- Precondition: only one server must be enabled (secure or insecure).
getServerSocket :: RunningServer -> STM Socket
getServerSocket :: RunningServer -> STM Socket
getServerSocket RunningServer
server = do
    insecure <- STM (Either ServerTerminated Socket)
-> (ServerTerminated -> STM (Either ServerTerminated Socket))
-> STM (Either ServerTerminated Socket)
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (Socket -> Either ServerTerminated Socket
forall a b. b -> Either a b
Right (Socket -> Either ServerTerminated Socket)
-> STM Socket -> STM (Either ServerTerminated Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningServer -> STM Socket
getInsecureSocket RunningServer
server) (Either ServerTerminated Socket
-> STM (Either ServerTerminated Socket)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ServerTerminated Socket
 -> STM (Either ServerTerminated Socket))
-> (ServerTerminated -> Either ServerTerminated Socket)
-> ServerTerminated
-> STM (Either ServerTerminated Socket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerTerminated -> Either ServerTerminated Socket
forall a b. a -> Either a b
Left)
    secure   <- catchSTM (Right <$> getSecureSocket   server) (return . Left)
    case (insecure, secure) of
      (Right Socket
sock, Left ServerTerminated
ServerTerminated) ->
        Socket -> STM Socket
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
      (Left ServerTerminated
ServerTerminated, Right Socket
sock) ->
        Socket -> STM Socket
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
      (Left ServerTerminated
ServerTerminated, Left ServerTerminated
ServerTerminated) ->
        ServerTerminated -> STM Socket
forall e a. Exception e => e -> STM a
throwSTM ServerTerminated
ServerTerminated
      (Right Socket
_, Right Socket
_) ->
        [Char] -> STM Socket
forall a. HasCallStack => [Char] -> a
error ([Char] -> STM Socket) -> [Char] -> STM Socket
forall a b. (a -> b) -> a -> b
$ [Char]
"getServerSocket: precondition violated"

-- | Get \"the\" port number used by the server
--
-- Precondition: only one server must be enabled (secure or insecure).
getServerPort :: RunningServer -> IO PortNumber
getServerPort :: RunningServer -> IO PortNumber
getServerPort RunningServer
server = do
    sock <- STM Socket -> IO Socket
forall a. STM a -> IO a
atomically (STM Socket -> IO Socket) -> STM Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ RunningServer -> STM Socket
getServerSocket RunningServer
server
    addr <- getSocketName sock
    case addr of
      SockAddrInet  PortNumber
port   HostAddress
_host   -> PortNumber -> IO PortNumber
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PortNumber
port
      SockAddrInet6 PortNumber
port HostAddress
_ HostAddress6
_host HostAddress
_ -> PortNumber -> IO PortNumber
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PortNumber
port
      SockAddrUnix{} -> [Char] -> IO PortNumber
forall a. HasCallStack => [Char] -> a
error [Char]
"getServerPort: unexpected unix socket"

-- | Internal generalization of 'getInsecureSocket'/'getSecureSocket'
getSocket :: Async () -> TMVar Socket -> STM Socket
getSocket :: Async () -> TMVar Socket -> STM Socket
getSocket Async ()
serverAsync TMVar Socket
socketTMVar = do
    status <-  (Either SomeException () -> Either (Either SomeException ()) Socket
forall a b. a -> Either a b
Left  (Either SomeException ()
 -> Either (Either SomeException ()) Socket)
-> STM (Either SomeException ())
-> STM (Either (Either SomeException ()) Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async () -> STM (Either SomeException ())
forall a. Async a -> STM (Either SomeException a)
waitCatchSTM Async ()
serverAsync)
      STM (Either (Either SomeException ()) Socket)
-> STM (Either (Either SomeException ()) Socket)
-> STM (Either (Either SomeException ()) Socket)
forall a. STM a -> STM a -> STM a
`orElse` (Socket -> Either (Either SomeException ()) Socket
forall a b. b -> Either a b
Right (Socket -> Either (Either SomeException ()) Socket)
-> STM Socket -> STM (Either (Either SomeException ()) Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar Socket -> STM Socket
forall a. TMVar a -> STM a
readTMVar    TMVar Socket
socketTMVar)
    case status of
      Left (Left SomeException
err) -> SomeException -> STM Socket
forall e a. Exception e => e -> STM a
throwSTM SomeException
err
      Left (Right ()) -> ServerTerminated -> STM Socket
forall e a. Exception e => e -> STM a
throwSTM (ServerTerminated -> STM Socket) -> ServerTerminated -> STM Socket
forall a b. (a -> b) -> a -> b
$ ServerTerminated
ServerTerminated
      Right Socket
sock      -> Socket -> STM Socket
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

{-------------------------------------------------------------------------------
  Insecure
-------------------------------------------------------------------------------}

runInsecure ::
     HTTP2Settings
  -> InsecureConfig
  -> TMVar Socket
  -> HTTP2.Server
  -> IO ()
runInsecure :: HTTP2Settings -> InsecureConfig -> TMVar Socket -> Server -> IO ()
runInsecure HTTP2Settings
http2 InsecureConfig
cfg TMVar Socket
socketTMVar Server
server = do
    InsecureConfig -> (Socket -> IO ()) -> IO ()
forall a. InsecureConfig -> (Socket -> IO a) -> IO a
openSock InsecureConfig
cfg ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
listenSock ->
      (Manager -> IO ()) -> IO ()
forall a. (Manager -> IO a) -> IO a
withTimeManager ((Manager -> IO ()) -> IO ()) -> (Manager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Manager
mgr ->
        Socket -> (Socket -> IO ()) -> IO ()
forall a. Socket -> (Socket -> IO a) -> IO a
Run.runTCPServerWithSocket Socket
listenSock ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
clientSock -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HTTP2Settings -> Bool
http2TcpNoDelay HTTP2Settings
http2 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isUnixSocket) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- See description of 'withServerSocket'
            Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
clientSock SocketOption
NoDelay Int
1
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HTTP2Settings -> Bool
http2TcpAbortiveClose HTTP2Settings
http2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Socket -> SocketOption -> StructLinger -> IO ()
forall a. Storable a => Socket -> SocketOption -> a -> IO ()
setSockOpt Socket
clientSock SocketOption
Linger
              (StructLinger { sl_onoff :: CInt
sl_onoff = CInt
1, sl_linger :: CInt
sl_linger = CInt
0 })
          Manager -> Socket -> (Config -> IO ()) -> IO ()
forall a. Manager -> Socket -> (Config -> IO a) -> IO a
withConfigForInsecure Manager
mgr Socket
clientSock ((Config -> IO ()) -> IO ()) -> (Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Config
config ->
            ServerConfig -> Config -> Server -> IO ()
HTTP2.run ServerConfig
serverConfig Config
config Server
server
  where
    serverConfig :: HTTP2.ServerConfig
    serverConfig :: ServerConfig
serverConfig = HTTP2Settings -> ServerConfig
mkServerConfig HTTP2Settings
http2

    openSock :: InsecureConfig -> (Socket -> IO a) -> IO a
    openSock :: forall a. InsecureConfig -> (Socket -> IO a) -> IO a
openSock InsecureConfig{Maybe [Char]
insecureHost :: InsecureConfig -> Maybe [Char]
insecureHost :: Maybe [Char]
insecureHost, PortNumber
insecurePort :: InsecureConfig -> PortNumber
insecurePort :: PortNumber
insecurePort} = do
      HTTP2Settings
-> TMVar Socket
-> Maybe [Char]
-> PortNumber
-> (Socket -> IO a)
-> IO a
forall a.
HTTP2Settings
-> TMVar Socket
-> Maybe [Char]
-> PortNumber
-> (Socket -> IO a)
-> IO a
withServerSocket
        HTTP2Settings
http2
        TMVar Socket
socketTMVar
        Maybe [Char]
insecureHost
        PortNumber
insecurePort
    openSock InsecureUnix{[Char]
insecurePath :: InsecureConfig -> [Char]
insecurePath :: [Char]
insecurePath} = do
      [Char] -> TMVar Socket -> (Socket -> IO a) -> IO a
forall a. [Char] -> TMVar Socket -> (Socket -> IO a) -> IO a
withUnixSocket
        [Char]
insecurePath
        TMVar Socket
socketTMVar

    isUnixSocket :: Bool
isUnixSocket = case InsecureConfig
cfg of
      InsecureConfig{} -> Bool
False
      InsecureUnix{}   -> Bool
True

{-------------------------------------------------------------------------------
  Secure (over TLS)
-------------------------------------------------------------------------------}

runSecure ::
     HTTP2Settings
  -> SecureConfig
  -> TMVar Socket
  -> HTTP2.Server
  -> IO ()
runSecure :: HTTP2Settings -> SecureConfig -> TMVar Socket -> Server -> IO ()
runSecure HTTP2Settings
http2 SecureConfig
cfg TMVar Socket
socketTMVar Server
server = do
    cred :: TLS.Credential <-
          [Char] -> [[Char]] -> [Char] -> IO (Either [Char] Credential)
TLS.credentialLoadX509Chain
            (SecureConfig -> [Char]
securePubCert    SecureConfig
cfg)
            (SecureConfig -> [[Char]]
secureChainCerts SecureConfig
cfg)
            (SecureConfig -> [Char]
securePrivKey    SecureConfig
cfg)
      IO (Either [Char] Credential)
-> (Either [Char] Credential -> IO Credential) -> IO Credential
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left  [Char]
err -> CouldNotLoadCredentials -> IO Credential
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CouldNotLoadCredentials -> IO Credential)
-> CouldNotLoadCredentials -> IO Credential
forall a b. (a -> b) -> a -> b
$ [Char] -> CouldNotLoadCredentials
CouldNotLoadCredentials [Char]
err
            Right Credential
res -> Credential -> IO Credential
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Credential
res

    keyLogger <- Util.TLS.keyLogger (secureSslKeyLog cfg)
    let serverConfig :: HTTP2.ServerConfig
        serverConfig = HTTP2Settings -> ServerConfig
mkServerConfig HTTP2Settings
http2

        tlsSettings :: HTTP2.TLS.Settings
        tlsSettings = HTTP2Settings -> ([Char] -> IO ()) -> Settings
mkTlsSettings HTTP2Settings
http2 [Char] -> IO ()
keyLogger

    withServerSocket
        http2
        socketTMVar
        (Just $ secureHost cfg)
        (securePort cfg) $ \Socket
listenSock ->
      Settings
-> Credentials
-> Socket
-> ByteString
-> (Manager -> IOBackend -> IO ())
-> IO ()
forall a.
Settings
-> Credentials
-> Socket
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
HTTP2.TLS.runTLSWithSocket
          Settings
tlsSettings
          ([Credential] -> Credentials
TLS.Credentials [Credential
cred])
          Socket
listenSock
          ByteString
"h2" ((Manager -> IOBackend -> IO ()) -> IO ())
-> (Manager -> IOBackend -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Manager
mgr IOBackend
backend -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HTTP2Settings -> Bool
http2TcpNoDelay HTTP2Settings
http2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          -- See description of 'withServerSocket'
          Socket -> SocketOption -> Int -> IO ()
setSocketOption (IOBackend -> Socket
HTTP2.TLS.requestSock IOBackend
backend) SocketOption
NoDelay Int
1
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HTTP2Settings -> Bool
http2TcpAbortiveClose HTTP2Settings
http2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Socket -> SocketOption -> StructLinger -> IO ()
forall a. Storable a => Socket -> SocketOption -> a -> IO ()
setSockOpt (IOBackend -> Socket
HTTP2.TLS.requestSock IOBackend
backend) SocketOption
Linger
            (StructLinger { sl_onoff :: CInt
sl_onoff = CInt
1, sl_linger :: CInt
sl_linger = CInt
0 })
        Manager -> IOBackend -> (Config -> IO ()) -> IO ()
forall a. Manager -> IOBackend -> (Config -> IO a) -> IO a
withConfigForSecure Manager
mgr IOBackend
backend ((Config -> IO ()) -> IO ()) -> (Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Config
config ->
          ServerConfig -> Config -> Server -> IO ()
HTTP2.run ServerConfig
serverConfig Config
config Server
server

data CouldNotLoadCredentials =
    -- | Failed to load server credentials
    CouldNotLoadCredentials String
  deriving stock (Int -> CouldNotLoadCredentials -> ShowS
[CouldNotLoadCredentials] -> ShowS
CouldNotLoadCredentials -> [Char]
(Int -> CouldNotLoadCredentials -> ShowS)
-> (CouldNotLoadCredentials -> [Char])
-> ([CouldNotLoadCredentials] -> ShowS)
-> Show CouldNotLoadCredentials
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CouldNotLoadCredentials -> ShowS
showsPrec :: Int -> CouldNotLoadCredentials -> ShowS
$cshow :: CouldNotLoadCredentials -> [Char]
show :: CouldNotLoadCredentials -> [Char]
$cshowList :: [CouldNotLoadCredentials] -> ShowS
showList :: [CouldNotLoadCredentials] -> ShowS
Show)
  deriving anyclass (Show CouldNotLoadCredentials
Typeable CouldNotLoadCredentials
(Typeable CouldNotLoadCredentials, Show CouldNotLoadCredentials) =>
(CouldNotLoadCredentials -> SomeException)
-> (SomeException -> Maybe CouldNotLoadCredentials)
-> (CouldNotLoadCredentials -> [Char])
-> (CouldNotLoadCredentials -> Bool)
-> Exception CouldNotLoadCredentials
SomeException -> Maybe CouldNotLoadCredentials
CouldNotLoadCredentials -> Bool
CouldNotLoadCredentials -> [Char]
CouldNotLoadCredentials -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> (e -> Bool)
-> Exception e
$ctoException :: CouldNotLoadCredentials -> SomeException
toException :: CouldNotLoadCredentials -> SomeException
$cfromException :: SomeException -> Maybe CouldNotLoadCredentials
fromException :: SomeException -> Maybe CouldNotLoadCredentials
$cdisplayException :: CouldNotLoadCredentials -> [Char]
displayException :: CouldNotLoadCredentials -> [Char]
$cbacktraceDesired :: CouldNotLoadCredentials -> Bool
backtraceDesired :: CouldNotLoadCredentials -> Bool
Exception)

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

-- | Create server listen socket
--
-- We set @TCP_NODELAY@ on the server listen socket, but there is no guarantee
-- that the option will be inherited by the sockets returned from @accept@ for
-- each client request. On Linux it seems to be, although I cannot find any
-- authoritative reference to say so; the best I could find is a section in Unix
-- Network Programming [1]. On FreeBSD on the other hand, the man page suggests
-- that @TCP_NODELAY@ is /not/ inherited [2].
--
-- Even the Linux man page for @accept@ is maddingly vague:
--
-- > Portable programs should not rely on inheritance or non‐inheritance of file
-- > status flags and always explicitly set all required flags on the socket
-- > returned from accept().
--
-- Whether that /file status/ flags is significant (as opposed to other kinds of
-- flags?) is unclear, especially in the second half of this sentence. The Linux
-- man page on @tcp@ is even worse; this is the only mention of inheritance in
-- entire page:
--
-- > [TCP_USER_TIMEOUT], like many others, will be inherited by the socket
-- > returned by accept(2), if it was set on the listening socket.
--
-- It is therefore best to explicitly set @TCP_NODELAY@ on the client request
-- socket.
--
-- [1] <https://notes.shichao.io/unp/ch7/#socket-states>
-- [2] <https://man.freebsd.org/cgi/man.cgi?query=tcp>
withServerSocket ::
     HTTP2Settings
  -> TMVar Socket
  -> Maybe HostName
  -> PortNumber
  -> (Socket -> IO a)
  -> IO a
withServerSocket :: forall a.
HTTP2Settings
-> TMVar Socket
-> Maybe [Char]
-> PortNumber
-> (Socket -> IO a)
-> IO a
withServerSocket HTTP2Settings
http2Settings TMVar Socket
socketTMVar Maybe [Char]
host PortNumber
port Socket -> IO a
k = do
#if MIN_VERSION_network_run(0,4,4)
    addr <- SocketType
-> Maybe [Char]
-> [Char]
-> [AddrInfoFlag]
-> (NonEmpty AddrInfo -> AddrInfo)
-> IO AddrInfo
Run.resolve SocketType
Stream Maybe [Char]
host (PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port) [AddrInfoFlag
AI_PASSIVE] NonEmpty AddrInfo -> AddrInfo
forall a. NonEmpty a -> a
NE.head
#else
    addr <- Run.resolve Stream host (show port) [AI_PASSIVE]
#endif
    bracket (openServerSocket addr) close $ \Socket
sock -> do
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Socket -> Socket -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Socket
socketTMVar Socket
sock
      Socket -> IO a
k Socket
sock
  where
    openServerSocket :: AddrInfo -> IO Socket
    openServerSocket :: AddrInfo -> IO Socket
openServerSocket = [(SocketOption, Int)] -> AddrInfo -> IO Socket
Run.openTCPServerSocketWithOptions ([(SocketOption, Int)] -> AddrInfo -> IO Socket)
-> [(SocketOption, Int)] -> AddrInfo -> IO Socket
forall a b. (a -> b) -> a -> b
$ [[(SocketOption, Int)]] -> [(SocketOption, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
          [ (SocketOption
NoDelay, Int
1)
          | HTTP2Settings -> Bool
http2TcpNoDelay HTTP2Settings
http2Settings
          ]
        ]

-- | Create a Unix domain socket
--
-- Note that @TCP_NODELAY@ should not be set on unix domain sockets,
-- otherwise clients would get their connection closed immediately.
withUnixSocket :: FilePath -> TMVar Socket -> (Socket -> IO a) -> IO a
withUnixSocket :: forall a. [Char] -> TMVar Socket -> (Socket -> IO a) -> IO a
withUnixSocket [Char]
path TMVar Socket
socketTMVar Socket -> IO a
k = do
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Socket
openServerSocket Socket -> IO ()
close ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Socket -> Socket -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Socket
socketTMVar Socket
sock
      Socket -> IO a
k Socket
sock
  where
    openServerSocket :: IO Socket
    openServerSocket :: IO Socket
openServerSocket = do
      sock <- Family -> SocketType -> CInt -> IO Socket
socket Family
AF_UNIX SocketType
Stream CInt
0
      setSocketOption sock ReuseAddr 1
      withFdSocket sock setCloseOnExecIfNeeded
      bind sock $ SockAddrUnix path
      listen sock 1024
      return sock