3 files changed, 171 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
diff --git a/mini-http/Network/HTTP/Server/Mini/Parser.hs b/mini-http/Network/HTTP/Server/Mini/Parser.hs
new file mode 100644
index 0000000..02da6d3
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini/Parser.hs
@@ -0,0 +1,78 @@
+module Network.HTTP.Server.Mini.Parser where
+
+import Control.Monad.Trans.Maybe
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+
+import Network.HTTP.Server.Mini.Types
+
+
+readRequest :: Monad m => Int -> (Int -> m ByteString) -> m (Maybe Request)
+readRequest maxsize recv = runMaybeT $ do
+  bs <- MaybeT $ readUntilTerminator maxsize recv []
+  hoistMaybe (parseRequest bs)
+
+parseRequest :: ByteString -> Maybe Request
+parseRequest = _
+
+readUntilTerminator :: Monad m => Int -> (Int -> m ByteString) -> [ByteString] -> m (Maybe ByteString)
+readUntilTerminator 0 _ _ = return Nothing
+readUntilTerminator maxsize recv toprevprefix = do
+  text <- recv maxsize
+  if BS.length text == 0
+    then return Nothing
+    else goFind toprevprefix text
+  where
+    goFind revprefix text =
+      case findTerminator text of
+        NoTerm -> readUntilTerminator (maxsize - BS.length text) recv (text : revprefix)
+        IncompleteTerm haveCR
+          | maxsize == BS.length text -> return Nothing
+          | otherwise -> do
+              text2 <- recv (maxsize - BS.length text)
+              text2' <- case BS.length text2 of
+                1 -> (text2 <>) <$> recv (maxsize - BS.length text - 1)  -- premature concat but rare
+                _ -> return text2  -- also for length 0 (i.e. EOF)!
+              -- now text2' has length at least 2 if available before EOF
+              case (haveCR, BS.length text2') of
+                (_, 0) -> return Nothing
+                (False, _) | text2' `BS.index` 0 == 10 -> return (Just (BS.concat (reverse revprefix)))
+                (False, n) | n >= 2, text2' `BS.index` 0 == 13, text2' `BS.index` 0 == 10 ->
+                  return (Just (BS.concat (reverse revprefix)))
+                (True, _) | text2' `BS.index` 0 == 10 -> return (Just (BS.init (BS.concat (reverse revprefix))))
+                (_, 1) -> return Nothing  -- second recv returned EOF and no terminator found before that
+                _ -> goFind (text : revprefix) text2'
+        FoundTerm i -> return (Just (BS.concat (reverse (BS.take i text : revprefix))))
+
+data FoundTerminator
+  = NoTerm
+  | IncompleteTerm {-# UNPACK #-} !Bool
+      -- ^ Bool indicates "have CR".
+      -- If False, then LF at end of segment, requires LF or CRLF at start of next.
+      -- If True, then LF CR at end of segment, requires LF at start of next.
+  | FoundTerm Int  -- ^ Index right after the first [CR]LF sequence in the terminator
+  deriving (Show)
+
+findTerminator :: ByteString -> FoundTerminator
+findTerminator bs =
+  -- We're looking for [CR] LF [CR] LF. Look for the first LF, and see if it's
+  -- followed by CRLF or LF.
+  go (BS.elemIndices 10 bs)
+  where
+    len = BS.length bs
+
+    go [] = NoTerm
+    go (i:is)
+      | i == len - 1 = IncompleteTerm False
+      | i == len - 2 =
+          case bs `BS.index` (i+1) of
+            10 -> FoundTerm (i+1)
+            13 -> IncompleteTerm True
+            _ -> NoTerm
+      -- now certainly two bytes after this LF
+      | otherwise =
+          case bs `BS.index` (i+1) of
+            10 -> FoundTerm (i+1)
+            -- [i+2] is read twice if this check fails, but LF CR (!=LF) will be very rare so it's fine
+            13 | bs `BS.index` (i+2) == 10 -> FoundTerm (i+1)
+            _ -> go is
diff --git a/mini-http/Network/HTTP/Server/Mini/Types.hs b/mini-http/Network/HTTP/Server/Mini/Types.hs
new file mode 100644
index 0000000..1099f94
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini/Types.hs
@@ -0,0 +1,31 @@
+module Network.HTTP.Server.Mini.Types where
+
+import Data.ByteString (ByteString)
+
+
+data Settings = Settings
+  { setPort :: Int
+  , setMaxParallelRequests :: Int
+  , setMaxRequestSize :: Int
+  }
+  deriving (Show)
+
+defaultSettings :: Settings
+defaultSettings = Settings
+  { setPort = 80
+  , setMaxParallelRequests = 4
+  , setMaxRequestSize = 8192
+  }
+
+-- | All-lowercase.
+type Header = ByteString
+
+data Request = Request
+  { reqMethod :: ByteString
+  , reqURI :: ByteString
+  , reqHeaders :: [(Header, ByteString)] }
+  deriving (Show)
+
+data Response
+  = ResponseBS ByteString
+  deriving (Show)