1 files changed, 76 insertions, 0 deletions
diff --git a/mini-http-server/Network/HTTP/Server/Mini.hs b/mini-http-server/Network/HTTP/Server/Mini.hs
new file mode 100644
index 0000000..266e958
--- /dev/null
+++ b/mini-http-server/Network/HTTP/Server/Mini.hs
@@ -0,0 +1,76 @@
+{-# 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.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 <- handler req
+      sendResponse conn resp