content: {-# LANGUAGE OverloadedStrings #-}
  
  -- | A server library for HTTP/0.9.
  module Network.HQ.Server (
      -- * Runner
      run,
  
      -- * Common configration
      Config (..),
      allocSimpleConfig,
      freeSimpleConfig,
  
      -- * HQ server
      Server,
  
      -- * Request
      Request,
  
      -- ** Accessing request
      requestPath,
  
      -- * Response
      Response,
  
      -- ** Creating response
      responseNoBody,
      responseFile,
      responseStreaming,
      responseBuilder,
  ) where
  
  import Control.Concurrent
  import qualified Data.ByteString as BS
  import Data.ByteString.Builder (Builder)
  import qualified Data.ByteString.Builder.Extra as B
  import qualified Data.ByteString.Internal as BS
  import Data.IORef
  import Foreign.ForeignPtr
  import GHC.Conc.Sync
  import Network.HPACK.Internal (toTokenHeaderTable)
  import Network.HTTP.Semantics.IO
  import Network.HTTP.Semantics.Server
  import Network.HTTP.Semantics.Server.Internal
  
  import Network.QUIC (Connection, Stream)
  import qualified Network.QUIC as QUIC
  import Network.SockAddr (showSockAddrBS)
  import Network.Socket (SockAddr)
  import qualified System.TimeManager as T
  
  import Imports
  import Network.HTTP3.Config
  import Network.HTTP3.Recv (newSource, readSource')
  
  -- | Running an HQ server.
  run :: Connection -> Config -> Server -> IO ()
  run conn conf server = do
      info <- QUIC.getConnectionInfo conn
      let mysa = QUIC.localSockAddr info
          peersa = QUIC.remoteSockAddr info
      forever $ do
          strm <- QUIC.acceptStream conn
          forkFinally
              (labelMe "H3 processRequest" >> processRequest conf mysa peersa server strm)
              (\_ -> QUIC.closeStream strm)
  
  labelMe :: String -> IO ()
  labelMe label = do
      tid <- myThreadId
      labelThread tid label
  
  processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO ()
  processRequest conf mysa peersa server strm
      | QUIC.isClientInitiatedBidirectional sid =
          void $ T.withHandle (confTimeoutManager conf) (return ()) $ \th -> do
              vt <- recvHeader strm mysa
              src <- newSource strm
              refH <- newIORef Nothing
              let readB = readSource' src
                  req = Request $ InpObj vt Nothing readB refH
                  aux = Aux th mysa peersa
              server req aux $ sendResponse conf strm
      | otherwise = return () -- fixme: should consume the data?
    where
      sid = QUIC.streamId strm
  
  recvHeader :: Stream -> SockAddr -> IO TokenHeaderTable
  recvHeader strm myaddr = do
      (method, path) <- recvRequestLine id
      let auth = showSockAddrBS myaddr
          vt =
              (":path", path)
                  : (":method", method)
                  : (":scheme", "https")
                  : (":authority", auth)
                  : []
      toTokenHeaderTable vt
    where
      recvRequestLine builder = do
          bs <- QUIC.recvStream strm 1024
          if bs == ""
              then do
                  return $ parseRequestLine $ BS.concat $ builder []
              else recvRequestLine (builder . (bs :))
      parseRequestLine bs = (method, path)
        where
          method = "GET"
          path0 = BS.drop 4 bs
          path = BS.take (BS.length path0 - 2) path0
  
  sendResponse :: Config -> Stream -> Response -> [PushPromise] -> IO ()
  sendResponse conf strm (Response outobj) _ = case outObjBody outobj of
      OutBodyNone -> return ()
      OutBodyFile (FileSpec path fileoff bytecount) -> do
          (pread, sentinel) <- confPositionReadMaker conf path
          let next = fillFileBodyGetNext pread fileoff bytecount sentinel
          sendNext strm next
      OutBodyBuilder builder -> do
          let next = fillBuilderBodyGetNext builder
          sendNext strm next
      OutBodyStreaming strmbdy -> sendStreaming strm strmbdy
      OutBodyStreamingIface _ ->
          error "sendResponse: server does not support OutBodyStreamingUnmask"
  
  sendNext :: Stream -> DynaNext -> IO ()
  sendNext strm action = do
      fp <- BS.mallocByteString 2048
      Next len _reqflush mnext <- withForeignPtr fp $ \buf -> action buf 2048
      if len == 0
          then return ()
          else do
              let bs = PS fp 0 len
              QUIC.sendStream strm bs
              case mnext of
                  Nothing -> return ()
                  Just next -> sendNext strm next
  
  sendStreaming :: Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()
  sendStreaming strm strmbdy = do
      strmbdy write flush
    where
      flush = return ()
      write builder = do
          newByteStringAndSend strm (B.runBuilder builder) >>= loop
        where
          loop B.Done = return ()
          loop (B.More _ writer) =
              newByteStringAndSend strm writer >>= loop
          loop (B.Chunk bs writer) = do
              QUIC.sendStream strm bs
              newByteStringAndSend strm writer >>= loop
  
  newByteStringAndSend :: Stream -> B.BufferWriter -> IO B.Next
  newByteStringAndSend strm action = do
      fp <- BS.mallocByteString 2048
      (len, signal) <- withForeignPtr fp $ \buf -> action buf 2048
      if len == 0
          then return signal
          else do
              let bs = PS fp 0 len
              QUIC.sendStream strm bs
              return signal
  