{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}

module Simplex.Messaging.Transport.HTTP2.Server where

import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
import Control.Concurrent.STM
import Control.Monad
import Data.Time.Clock.System (getSystemTime, systemSeconds)
import Network.HPACK (BufferSize)
import Network.HTTP2.Server (Request, Response)
import qualified Network.HTTP2.Server as H
import Network.Socket
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.Server (SNICredentialUsed, ServerCredentials, TLSServerCredential (..), TransportServerConfig (..), loadServerCredential, newSocketState, runTransportServerState_)
import Simplex.Messaging.Util (threadDelay')
import UnliftIO (finally)
import UnliftIO.Concurrent (forkIO, killThread)

type HTTP2ServerFunc = SessionId -> Maybe ALPN -> Request -> (Response -> IO ()) -> IO ()

data HTTP2ServerConfig = HTTP2ServerConfig
  { HTTP2ServerConfig -> Natural
qSize :: Natural,
    HTTP2ServerConfig -> ServiceName
http2Port :: ServiceName,
    HTTP2ServerConfig -> BufferSize
bufferSize :: BufferSize,
    HTTP2ServerConfig -> BufferSize
bodyHeadSize :: Int,
    HTTP2ServerConfig -> Supported
serverSupported :: T.Supported,
    HTTP2ServerConfig -> ServerCredentials
https2Credentials :: ServerCredentials,
    HTTP2ServerConfig -> TransportServerConfig
transportConfig :: TransportServerConfig
  }
  deriving (BufferSize -> HTTP2ServerConfig -> ShowS
[HTTP2ServerConfig] -> ShowS
HTTP2ServerConfig -> ServiceName
(BufferSize -> HTTP2ServerConfig -> ShowS)
-> (HTTP2ServerConfig -> ServiceName)
-> ([HTTP2ServerConfig] -> ShowS)
-> Show HTTP2ServerConfig
forall a.
(BufferSize -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: BufferSize -> HTTP2ServerConfig -> ShowS
showsPrec :: BufferSize -> HTTP2ServerConfig -> ShowS
$cshow :: HTTP2ServerConfig -> ServiceName
show :: HTTP2ServerConfig -> ServiceName
$cshowList :: [HTTP2ServerConfig] -> ShowS
showList :: [HTTP2ServerConfig] -> ShowS
Show)

data HTTP2Request = HTTP2Request
  { HTTP2Request -> SessionId
sessionId :: SessionId,
    HTTP2Request -> Maybe SessionId
sessionALPN :: Maybe ALPN,
    HTTP2Request -> Request
request :: Request,
    HTTP2Request -> HTTP2Body
reqBody :: HTTP2Body,
    HTTP2Request -> Response -> IO ()
sendResponse :: Response -> IO ()
  }

data HTTP2Server = HTTP2Server
  { HTTP2Server -> Async ()
action :: Async (),
    HTTP2Server -> TBQueue HTTP2Request
reqQ :: TBQueue HTTP2Request
  }

-- This server is for testing only, it processes all requests in a single queue.
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {Natural
qSize :: HTTP2ServerConfig -> Natural
qSize :: Natural
qSize, ServiceName
http2Port :: HTTP2ServerConfig -> ServiceName
http2Port :: ServiceName
http2Port, BufferSize
bufferSize :: HTTP2ServerConfig -> BufferSize
bufferSize :: BufferSize
bufferSize, BufferSize
bodyHeadSize :: HTTP2ServerConfig -> BufferSize
bodyHeadSize :: BufferSize
bodyHeadSize, Supported
serverSupported :: HTTP2ServerConfig -> Supported
serverSupported :: Supported
serverSupported, ServerCredentials
https2Credentials :: HTTP2ServerConfig -> ServerCredentials
https2Credentials :: ServerCredentials
https2Credentials, TransportServerConfig
transportConfig :: HTTP2ServerConfig -> TransportServerConfig
transportConfig :: TransportServerConfig
transportConfig} = do
  Credential
srvCreds <- ServerCredentials -> IO Credential
loadServerCredential ServerCredentials
https2Credentials
  TMVar Bool
started <- IO (TMVar Bool)
forall a. IO (TMVar a)
newEmptyTMVarIO
  TBQueue HTTP2Request
reqQ <- Natural -> IO (TBQueue HTTP2Request)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
qSize
  Async ()
action <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
    TMVar Bool
-> ServiceName
-> BufferSize
-> Supported
-> Credential
-> Maybe Credential
-> TransportServerConfig
-> Maybe ExpirationConfig
-> (SessionId -> IO ())
-> (Bool -> HTTP2ServerFunc)
-> IO ()
runHTTP2Server TMVar Bool
started ServiceName
http2Port BufferSize
bufferSize Supported
serverSupported Credential
srvCreds Maybe Credential
forall a. Maybe a
Nothing TransportServerConfig
transportConfig Maybe ExpirationConfig
forall a. Maybe a
Nothing (IO () -> SessionId -> IO ()
forall a b. a -> b -> a
const (IO () -> SessionId -> IO ()) -> IO () -> SessionId -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Bool -> HTTP2ServerFunc) -> IO ())
-> (Bool -> HTTP2ServerFunc) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
_sniUsed SessionId
sessionId Maybe SessionId
sessionALPN Request
r Response -> IO ()
sendResponse -> do
      HTTP2Body
reqBody <- Request -> BufferSize -> IO HTTP2Body
forall a. HTTP2BodyChunk a => a -> BufferSize -> IO HTTP2Body
getHTTP2Body Request
r BufferSize
bodyHeadSize
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue HTTP2Request -> HTTP2Request -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue HTTP2Request
reqQ HTTP2Request {SessionId
sessionId :: SessionId
sessionId :: SessionId
sessionId, Maybe SessionId
sessionALPN :: Maybe SessionId
sessionALPN :: Maybe SessionId
sessionALPN, request :: Request
request = Request
r, HTTP2Body
reqBody :: HTTP2Body
reqBody :: HTTP2Body
reqBody, Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse}
  IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> (STM Bool -> IO Bool) -> STM Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO ()) -> STM Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
takeTMVar TMVar Bool
started
  HTTP2Server -> IO HTTP2Server
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Server {Async ()
action :: Async ()
action :: Async ()
action, TBQueue HTTP2Request
reqQ :: TBQueue HTTP2Request
reqQ :: TBQueue HTTP2Request
reqQ}

closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server = Async () -> IO ()
forall a. Async a -> IO ()
uninterruptibleCancel (Async () -> IO ())
-> (HTTP2Server -> Async ()) -> HTTP2Server -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTTP2Server -> Async ()
action

runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> (SNICredentialUsed -> HTTP2ServerFunc) -> IO ()
runHTTP2Server :: TMVar Bool
-> ServiceName
-> BufferSize
-> Supported
-> Credential
-> Maybe Credential
-> TransportServerConfig
-> Maybe ExpirationConfig
-> (SessionId -> IO ())
-> (Bool -> HTTP2ServerFunc)
-> IO ()
runHTTP2Server TMVar Bool
started ServiceName
port BufferSize
bufferSize Supported
srvSupported Credential
srvCreds Maybe Credential
httpCreds_ TransportServerConfig
transportConfig Maybe ExpirationConfig
expCfg_ SessionId -> IO ()
clientFinished = Maybe ExpirationConfig
-> (SessionId -> IO ())
-> BufferSize
-> (((Bool, TLS 'TServer) -> IO ()) -> IO ())
-> (Bool -> HTTP2ServerFunc)
-> IO ()
forall (p :: TransportPeer) a.
Maybe ExpirationConfig
-> (SessionId -> IO ())
-> BufferSize
-> (((Bool, TLS p) -> IO ()) -> a)
-> (Bool -> HTTP2ServerFunc)
-> a
runHTTP2ServerWith_ Maybe ExpirationConfig
expCfg_ SessionId -> IO ()
clientFinished BufferSize
bufferSize ((Bool, TLS 'TServer) -> IO ()) -> IO ()
forall {c :: TransportPeer -> *}.
Transport c =>
((Bool, c 'TServer) -> IO ()) -> IO ()
setup
  where
    setup :: ((Bool, c 'TServer) -> IO ()) -> IO ()
setup (Bool, c 'TServer) -> IO ()
handler = do
      SocketState
ss <- IO SocketState
newSocketState
      let combinedCreds :: TLSServerCredential
combinedCreds = TLSServerCredential {$sel:credential:TLSServerCredential :: Credential
credential = Credential
srvCreds, $sel:sniCredential:TLSServerCredential :: Maybe Credential
sniCredential = Maybe Credential
httpCreds_}
      SocketState
-> TMVar Bool
-> ServiceName
-> Supported
-> TLSServerCredential
-> TransportServerConfig
-> (Socket -> (Bool, c 'TServer) -> IO ())
-> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
SocketState
-> TMVar Bool
-> ServiceName
-> Supported
-> TLSServerCredential
-> TransportServerConfig
-> (Socket -> (Bool, c 'TServer) -> IO ())
-> IO ()
runTransportServerState_ SocketState
ss TMVar Bool
started ServiceName
port Supported
srvSupported TLSServerCredential
combinedCreds TransportServerConfig
transportConfig ((Socket -> (Bool, c 'TServer) -> IO ()) -> IO ())
-> (Socket -> (Bool, c 'TServer) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
_ -> (Bool, c 'TServer) -> IO ()
handler

-- HTTP2 server can be run on both client and server TLS connections.
runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith :: forall (p :: TransportPeer) a.
BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith BufferSize
bufferSize (TLS p -> IO ()) -> a
tlsSetup HTTP2ServerFunc
http2Server =
  Maybe ExpirationConfig
-> (SessionId -> IO ())
-> BufferSize
-> (((Bool, TLS p) -> IO ()) -> a)
-> (Bool -> HTTP2ServerFunc)
-> a
forall (p :: TransportPeer) a.
Maybe ExpirationConfig
-> (SessionId -> IO ())
-> BufferSize
-> (((Bool, TLS p) -> IO ()) -> a)
-> (Bool -> HTTP2ServerFunc)
-> a
runHTTP2ServerWith_
    Maybe ExpirationConfig
forall a. Maybe a
Nothing
    (\SessionId
_sessId -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    BufferSize
bufferSize
    (\(Bool, TLS p) -> IO ()
handler -> (TLS p -> IO ()) -> a
tlsSetup ((TLS p -> IO ()) -> a) -> (TLS p -> IO ()) -> a
forall a b. (a -> b) -> a -> b
$ \TLS p
tls -> (Bool, TLS p) -> IO ()
handler (Bool
False, TLS p
tls))
    (HTTP2ServerFunc -> Bool -> HTTP2ServerFunc
forall a b. a -> b -> a
const HTTP2ServerFunc
http2Server)

runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> (((SNICredentialUsed, TLS p) -> IO ()) -> a) -> (SNICredentialUsed -> HTTP2ServerFunc) -> a
runHTTP2ServerWith_ :: forall (p :: TransportPeer) a.
Maybe ExpirationConfig
-> (SessionId -> IO ())
-> BufferSize
-> (((Bool, TLS p) -> IO ()) -> a)
-> (Bool -> HTTP2ServerFunc)
-> a
runHTTP2ServerWith_ Maybe ExpirationConfig
expCfg_ SessionId -> IO ()
clientFinished BufferSize
bufferSize ((Bool, TLS p) -> IO ()) -> a
setup Bool -> HTTP2ServerFunc
http2Server = ((Bool, TLS p) -> IO ()) -> a
setup (((Bool, TLS p) -> IO ()) -> a) -> ((Bool, TLS p) -> IO ()) -> a
forall a b. (a -> b) -> a -> b
$ \(Bool
sniUsed, TLS p
tls) -> do
  TVar SystemTime
activeAt <- SystemTime -> IO (TVar SystemTime)
forall a. a -> IO (TVar a)
newTVarIO (SystemTime -> IO (TVar SystemTime))
-> IO SystemTime -> IO (TVar SystemTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SystemTime
getSystemTime
  Maybe ThreadId
tid_ <- (ExpirationConfig -> IO ThreadId)
-> Maybe ExpirationConfig -> IO (Maybe ThreadId)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (ExpirationConfig -> IO ()) -> ExpirationConfig -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLS p -> TVar SystemTime -> ExpirationConfig -> IO ()
forall {c :: TransportPeer -> *} {p :: TransportPeer}.
Transport c =>
c p -> TVar SystemTime -> ExpirationConfig -> IO ()
expireInactiveClient TLS p
tls TVar SystemTime
activeAt) Maybe ExpirationConfig
expCfg_
  BufferSize -> (Config -> IO ()) -> IO () -> TLS p -> IO ()
forall a (p :: TransportPeer).
BufferSize -> (Config -> IO a) -> IO () -> TLS p -> IO a
withHTTP2 BufferSize
bufferSize (Bool -> TLS p -> TVar SystemTime -> Config -> IO ()
forall {p :: TransportPeer}.
Bool -> TLS p -> TVar SystemTime -> Config -> IO ()
run Bool
sniUsed TLS p
tls TVar SystemTime
activeAt) (SessionId -> IO ()
clientFinished (SessionId -> IO ()) -> SessionId -> IO ()
forall a b. (a -> b) -> a -> b
$ TLS p -> SessionId
forall (p :: TransportPeer). TLS p -> SessionId
tlsUniq TLS p
tls) TLS p
tls IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread Maybe ThreadId
tid_
  where
    run :: Bool -> TLS p -> TVar SystemTime -> Config -> IO ()
run Bool
sniUsed TLS p
tls TVar SystemTime
activeAt Config
cfg = ServerConfig -> Config -> Server -> IO ()
H.run ServerConfig
H.defaultServerConfig Config
cfg (Server -> IO ()) -> Server -> IO ()
forall a b. (a -> b) -> a -> b
$ \Request
req Aux
_aux Response -> [PushPromise] -> IO ()
sendResp -> do
      IO SystemTime
getSystemTime IO SystemTime -> (SystemTime -> 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
>>= STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (SystemTime -> STM ()) -> SystemTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar SystemTime -> SystemTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SystemTime
activeAt
      Bool -> HTTP2ServerFunc
http2Server Bool
sniUsed (TLS p -> SessionId
forall (p :: TransportPeer). TLS p -> SessionId
tlsUniq TLS p
tls) (TLS p -> Maybe SessionId
forall (p :: TransportPeer). TLS p -> Maybe SessionId
tlsALPN TLS p
tls) Request
req (Response -> [PushPromise] -> IO ()
`sendResp` [])
    expireInactiveClient :: c p -> TVar SystemTime -> ExpirationConfig -> IO ()
expireInactiveClient c p
tls TVar SystemTime
activeAt ExpirationConfig
expCfg = IO ()
loop
      where
        loop :: IO ()
loop = do
          Int64 -> IO ()
threadDelay' (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ExpirationConfig -> Int64
checkInterval ExpirationConfig
expCfg Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000
          Int64
old <- ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
expCfg
          SystemTime
ts <- TVar SystemTime -> IO SystemTime
forall a. TVar a -> IO a
readTVarIO TVar SystemTime
activeAt
          if SystemTime -> Int64
systemSeconds SystemTime
ts Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
old
            then c p -> IO ()
forall (p :: TransportPeer). c p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection c p
tls
            else IO ()
loop