From 61270c31ae292d504c2d43b84d4291c2377e31d7 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 3 May 2026 21:35:05 +0100
Subject: Convert from wai/warp to mini-http-server

---
 mini-http/Network/HTTP/Server/Mini.hs | 42 +++++++++++++++++++++++------------
 1 file changed, 28 insertions(+), 14 deletions(-)

(limited to 'mini-http/Network/HTTP/Server/Mini.hs')

diff --git a/mini-http/Network/HTTP/Server/Mini.hs b/mini-http/Network/HTTP/Server/Mini.hs
index 5af52da..3c5c3f6 100644
--- a/mini-http/Network/HTTP/Server/Mini.hs
+++ b/mini-http/Network/HTTP/Server/Mini.hs
@@ -1,5 +1,6 @@
+{-# LANGUAGE TypeApplications #-}
 module Network.HTTP.Server.Mini (
-  module Network.HTTP.Server.Mini,
+  run,
   module Network.HTTP.Server.Mini.Types,
 ) where
 
@@ -12,6 +13,7 @@ import Network.Socket
 import Network.Socket.ByteString
 
 import Network.HTTP.Server.Mini.Parser
+import Network.HTTP.Server.Mini.Printer
 import Network.HTTP.Server.Mini.Types
 
 
@@ -20,14 +22,24 @@ run :: Settings -> (Request -> IO Response) -> IO ()
 run settings handler = do
   let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE]
                            , addrSocketType = Stream }
-  addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just (show (setPort settings)))
-
-  bracket (openSocket addr) close $ \sock -> do
-    setSocketOption sock ReusePort 1
-    bind sock (addrAddress addr)
-    listen sock 64
-    semaphore <- newTVarIO (setMaxParallelRequests settings)
-    acceptLoop sock semaphore
+  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).
@@ -41,12 +53,11 @@ run settings handler = do
         writeTVar semaphore $! n - 1
       let increment = atomically (modifyTVar' semaphore (+1))
 
-      (conn, peer) <- accept sock `onException` increment
+      (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
-            print peer
             -- 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).
@@ -57,6 +68,9 @@ run settings handler = do
 -- | 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 = do
-  req <- readRequest (setMaxRequestSize settings) (recv conn)
-  print req
+handleConnection settings conn handler =
+  readRequest (setMaxRequestSize settings) (recv conn) >>= \case
+    Nothing -> return ()
+    Just req -> do
+      resp <- handler req
+      sendResponse conn resp
-- 
cgit v1.3.1