{-# LANGUAGE TypeApplications #-}
module Network.HTTP.Server.Mini (
  run,
  module Network.HTTP.Server.Mini.Types,
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.List.NonEmpty qualified as NE
import Network.Socket
import Network.Socket.ByteString

import Network.HTTP.Server.Mini.Internal.Parser
import Network.HTTP.Server.Mini.Internal.Instrument
import Network.HTTP.Server.Mini.Printer
import Network.HTTP.Server.Mini.Types


-- | The request handler will run in a forkIO thread.
run :: Settings -> (Request -> IO Response) -> IO ()
run settings handler = do
  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE]
                           , addrSocketType = Stream }
  addrs <- getAddrInfo @NE.NonEmpty (Just hints) Nothing (Just (show (setPort settings)))

  semaphore <- newTVarIO (setMaxParallelRequests settings)
  finishVar <- newEmptyMVar

  threads <- forM addrs $ \addr ->
    forkIO $
      bracket
        (openSocket addr)
        (\sock -> close sock `finally` putMVar finishVar ())
        (\sock -> do
          setSocketOption sock ReusePort 1
          bind sock (addrAddress addr)
          listen sock (setListenQueue settings)
          acceptLoop sock semaphore)

  takeMVar finishVar
  forM_ threads killThread
  where
    -- Put the forever _outside_ the mask_ to unmask briefly between iterations
    -- (when it's safe because we have nothing ongoing).
    acceptLoop sock semaphore = forever $ mask_ $ do
      -- Because we're masked, if atomically exits with an async exception, it
      -- was while blocking so the transaction failed, so nothing happened, so
      -- no cleanup necessary.
      atomically $ do
        n <- readTVar semaphore
        when (n == 0) retry
        writeTVar semaphore $! n - 1
      let increment = atomically (modifyTVar' semaphore (+1))

      (conn, _peer) <- accept sock `onException` increment
      let cleanup = close conn `finally` increment

      onException
        (do allowInterrupt  -- we're masked but we just blocked (in `accept` in FFI), so let exceptions through
            -- Now either the forkIO succeeds (and the responsibility for
            -- closing and incrementing is passed to the thread) or it fails
            -- (and we retain both responsibilities).
            void $ forkIO $
              handleConnection settings conn handler `finally` cleanup)
        cleanup

-- | Will not close the connection, instead will just return, expecting the
-- caller to close the connection then.
handleConnection :: Settings -> Socket -> (Request -> IO Response) -> IO ()
handleConnection settings conn handler =
  readRequest (setMaxRequestSize settings) (recv conn) >>= \case
    Nothing -> return ()
    Just req -> do
      resp <- instrument "handler" $ handler req
      instrument "sendResponse" $ sendResponse conn resp