1 files changed, 62 insertions, 0 deletions
diff --git a/mini-http/Network/HTTP/Server/Mini.hs b/mini-http/Network/HTTP/Server/Mini.hs
new file mode 100644
index 0000000..5af52da
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini.hs
@@ -0,0 +1,62 @@
+module Network.HTTP.Server.Mini (
+  module Network.HTTP.Server.Mini,
+  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.Parser
+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 }
+  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
+  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
+            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).
+            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 = do
+  req <- readRequest (setMaxRequestSize settings) (recv conn)
+  print req