Convert from wai/warp to mini-http-server

7 files changed, 264 insertions, 24 deletions

diff --git a/mini-http/Main.hs b/mini-http/Main.hs
new file mode 100644
index 0000000..08e66c1
--- /dev/null
+++ b/mini-http/Main.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Data.ByteString.Char8 qualified as BS8
+
+import Network.HTTP.Server.Mini
+
+
+main :: IO ()
+main =
+  run defaultSettings { setPort = 8000 } $ \req ->
+    return (responseBS status200 [("Content-Type", "text/plain")] (BS8.pack (show req)))
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)))
+  addrs <- getAddrInfo @NE.NonEmpty (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
+  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
diff --git a/mini-http/Network/HTTP/Server/Mini/Parser.hs b/mini-http/Network/HTTP/Server/Mini/Parser.hs
index 02da6d3..97e25c1 100644
--- a/mini-http/Network/HTTP/Server/Mini/Parser.hs
+++ b/mini-http/Network/HTTP/Server/Mini/Parser.hs
@@ -1,10 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 module Network.HTTP.Server.Mini.Parser where
 
+import Control.Monad (guard)
 import Control.Monad.Trans.Maybe
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
+import Data.ByteString.Short (ShortByteString)
+import Data.ByteString.Short qualified as SBS
+import Data.Char
+import Data.Word
+import FlatParse.Basic qualified as P
 
 import Network.HTTP.Server.Mini.Types
+import Network.HTTP.Server.Mini.URI
+import Network.HTTP.Server.Mini.Util
 
 
 readRequest :: Monad m => Int -> (Int -> m ByteString) -> m (Maybe Request)
@@ -13,7 +23,71 @@ readRequest maxsize recv = runMaybeT $ do
   hoistMaybe (parseRequest bs)
 
 parseRequest :: ByteString -> Maybe Request
-parseRequest = _
+parseRequest bs =
+  case P.runParser pRequest bs of
+    P.OK req rest | BS.null rest -> Just req
+    _ -> Nothing
+
+pRequest :: P.Parser e Request
+pRequest = do
+  (method, uri) <- pFirstLine
+  headers <- P.many pHeader
+  let (path, query) = parseURI uri
+  return Request { reqMethod = method
+                 , reqURI = uri
+                 , reqHeaders = headers
+                 , reqPath = path
+                 , reqQuery = query }
+
+pFirstLine :: P.Parser e (ShortByteString, ByteString)
+pFirstLine = do
+  method <- pTakeUntil (ord8 ' ')
+  guard (BS.length method <= 32)  -- will put it in an SBS later
+  P.word8 32
+  uri <- pTakeUntil (ord8 ' ')
+  P.word8 32
+  $(P.bytes (map (fromIntegral @Int @Word . ord) "HTTP/1."))
+  version <- P.anyWord8
+  guard (version == ord8 '0' || version == ord8 '1')
+  pNewline
+  return (SBS.pack (map toAsciiUpperCase (BS.unpack method)), uri)
+
+pHeader :: P.Parser e (Header, ByteString)
+pHeader = do
+  key <- pTakeUntil (ord8 ':')
+  guard (BS.length key <= 128)  -- will put it in an SBS later
+  P.word8 (ord8 ':')
+  P.skipMany (P.satisfy isLinearSpace)
+  value <- pValue []
+  return (SBS.pack (map toAsciiLowerCase (BS.unpack key)), value)
+  where
+    pValue revlines = do
+      line <- trimCR <$> pTakeUntil 10
+      P.word8 10
+      P.withOption (P.lookahead (P.skipSatisfyAscii isLinearSpace))
+        (\_ -> pValue (line : revlines))
+        (return (BS.concat (reverse (line : revlines))))
+
+    trimCR bs
+      | len >= 1, bs `BS.index` (len - 1) == 13 = BS.take (len - 1) bs
+      | otherwise = bs
+      where len = BS.length bs
+
+isLinearSpace :: Char -> Bool
+isLinearSpace c = c == ' ' || c == '\t'
+
+pTakeUntil :: Word8 -> P.Parser e ByteString
+pTakeUntil term = do
+  midx <- P.lookahead (BS.elemIndex term <$> P.takeRest)
+  case midx of
+    Just idx -> P.take idx
+    Nothing -> P.failed
+
+pNewline :: P.Parser e ()
+pNewline = P.withAnyWord8 $ \case
+  10 -> return ()
+  13 -> P.word8 10
+  _ -> P.failed
 
 readUntilTerminator :: Monad m => Int -> (Int -> m ByteString) -> [ByteString] -> m (Maybe ByteString)
 readUntilTerminator 0 _ _ = return Nothing
@@ -76,3 +150,13 @@ findTerminator bs =
             -- [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
+
+toAsciiUpperCase :: Word8 -> Word8
+toAsciiUpperCase c
+  | ord8 'a' <= c, c <= ord8 'z' = c - 32
+  | otherwise = c
+
+toAsciiLowerCase :: Word8 -> Word8
+toAsciiLowerCase c
+  | ord8 'A' <= c, c <= ord8 'Z' = c + 32
+  | otherwise = c
diff --git a/mini-http/Network/HTTP/Server/Mini/Printer.hs b/mini-http/Network/HTTP/Server/Mini/Printer.hs
new file mode 100644
index 0000000..ab6c1f6
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini/Printer.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.HTTP.Server.Mini.Printer where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.ByteString.Builder qualified as BSB
+import Network.Socket
+import Network.Socket.ByteString
+
+import Network.HTTP.Server.Mini.Types
+
+
+sendResponse :: Socket -> Response -> IO ()
+sendResponse conn (Response status hdrs (BodyLBS body)) =
+  sendResponseChunks conn status hdrs body
+sendResponse conn (Response status hdrs (BodyFile path)) =
+  -- lazy IO is fine here because the whole thing is traversed before the end of this function in sendMany
+  sendResponseChunks conn status hdrs =<< BSL.readFile path
+
+sendResponseChunks :: Socket -> Status -> [(Header, ByteString)] -> BSL.ByteString -> IO ()
+sendResponseChunks conn (Status code reason) hdrs body =
+  sendMany conn $
+    BSL.toStrict (BSB.toLazyByteString
+      (BSB.shortByteString "HTTP/1.1 "
+       <> BSB.intDec code
+       <> BSB.char8 ' '
+       <> BSB.shortByteString reason
+       <> BSB.shortByteString "\r\n"
+       <> foldMap (\(key, val) ->
+                    BSB.shortByteString key <> BSB.shortByteString ": "
+                    <> BSB.byteString (wrapHdrVal val) <> BSB.shortByteString "\r\n")
+                  hdrs
+       <> BSB.shortByteString "Content-Length: " <> BSB.int64Dec (BSL.length body)
+       <> BSB.shortByteString "\r\nConnection: close\r\n\r\n"))
+    : BSL.toChunks body
+
+wrapHdrVal :: ByteString -> ByteString
+wrapHdrVal bs = BS.intercalate (BS.singleton 32) (BS.split 10 bs)
diff --git a/mini-http/Network/HTTP/Server/Mini/Types.hs b/mini-http/Network/HTTP/Server/Mini/Types.hs
index 1099f94..c764182 100644
--- a/mini-http/Network/HTTP/Server/Mini/Types.hs
+++ b/mini-http/Network/HTTP/Server/Mini/Types.hs
@@ -1,31 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Network.HTTP.Server.Mini.Types where
 
 import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy (LazyByteString)
+import Data.ByteString.Builder (Builder)
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Short (ShortByteString)
 
 
 data Settings = Settings
-  { setPort :: Int
-  , setMaxParallelRequests :: Int
-  , setMaxRequestSize :: Int
+  { setPort :: !Int
+  , setListenQueue :: !Int
+  , setMaxParallelRequests :: !Int
+  , setMaxRequestSize :: !Int
   }
   deriving (Show)
 
 defaultSettings :: Settings
 defaultSettings = Settings
   { setPort = 80
+  , setListenQueue = 32
   , setMaxParallelRequests = 4
   , setMaxRequestSize = 8192
   }
 
--- | All-lowercase.
-type Header = ByteString
+type Header = ShortByteString
 
 data Request = Request
-  { reqMethod :: ByteString
-  , reqURI :: ByteString
-  , reqHeaders :: [(Header, ByteString)] }
+  { reqMethod :: !ShortByteString  -- | All-uppercase
+  , reqURI :: !ByteString
+  , reqHeaders :: ![(Header, ByteString)]  -- | Header name in all-lowercase
+  , reqPath :: [ByteString]  -- | Lazy field
+  , reqQuery :: [(ByteString, ByteString)]  -- | Lazy field
+  }
+  deriving (Show)
+
+data Status = Status !Int !ShortByteString
   deriving (Show)
 
-data Response
-  = ResponseBS ByteString
+data Response = Response
+  { resStatus :: !Status
+  , resHeaders :: ![(Header, ByteString)]
+  , resBody :: !ResponseBody }
   deriving (Show)
+
+data ResponseBody
+  = BodyLBS !LazyByteString
+  | BodyFile !FilePath
+  deriving (Show)
+
+status200 :: Status
+status200 = Status 200 "OK"
+
+status404 :: Status
+status404 = Status 404 "Not Found"
+
+responseLBS :: Status -> [(Header, ByteString)] -> LazyByteString -> Response
+responseLBS status hdrs = Response status hdrs . BodyLBS
+
+responseBS :: Status -> [(Header, ByteString)] -> ByteString -> Response
+responseBS status hdrs = responseLBS status hdrs . BS.fromStrict
+
+responseBuilder :: Status -> [(Header, ByteString)] -> Builder -> Response
+responseBuilder status hdrs = responseLBS status hdrs . BSB.toLazyByteString
+
+responseFile :: Status -> [(Header, ByteString)] -> FilePath -> Response
+responseFile status hdrs = Response status hdrs . BodyFile
diff --git a/mini-http/Network/HTTP/Server/Mini/URI.hs b/mini-http/Network/HTTP/Server/Mini/URI.hs
new file mode 100644
index 0000000..13d7c35
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini/URI.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ViewPatterns #-}
+module Network.HTTP.Server.Mini.URI where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+
+import Network.HTTP.Server.Mini.Util
+
+
+-- | (path components, query string)
+--
+-- TODO: percent-decode
+parseURI :: ByteString -> ([ByteString], [(ByteString, ByteString)])
+parseURI = \bs ->
+  case BS.uncons bs of
+    Just ((== ord8 '/') -> True, bs1) -> goPath id bs1
+    _ -> ([], [])
+  where
+    goPath f bs
+      | BS.null bs = (f [], [])
+      | otherwise =
+          let (comp, bs1) = BS.span (\c -> c /= ord8 '/' && c /= ord8 '?') bs
+          in case BS.uncons bs1 of
+               Just ((== ord8 '/') -> True, bs2) ->
+                 goPath (f . (comp:)) bs2
+               Just ((== ord8 '?') -> True, bs2) ->
+                 (f [comp], goQuery bs2)
+               _ -> (f [comp], [])
+
+    goQuery bs
+      | BS.null bs = []
+      | Just ((== ord8 '&') -> True, bs1) <- BS.uncons bs = goQuery bs1
+      | otherwise =
+          let (key, bs1) = BS.span (\c -> c /= ord8 '=' && c /= ord8 '&') bs
+          in case BS.uncons bs1 of
+               Just ((== ord8 '=') -> True, bs2) ->
+                 let (val, bs3) = BS.span (\c -> c /= ord8 '&') bs2
+                 in case BS.uncons bs3 of
+                      Just (_, bs4) -> (key, val) : goQuery bs4
+                      Nothing -> [(key, val)]
+               Just ((== ord8 '&') -> True, bs2) ->
+                 (key, BS.empty) : goQuery bs2
+               _ ->
+                 [(key, BS.empty)]
diff --git a/mini-http/Network/HTTP/Server/Mini/Util.hs b/mini-http/Network/HTTP/Server/Mini/Util.hs
new file mode 100644
index 0000000..c29a8e6
--- /dev/null
+++ b/mini-http/Network/HTTP/Server/Mini/Util.hs
@@ -0,0 +1,9 @@
+module Network.HTTP.Server.Mini.Util where
+
+import Data.Char
+import Data.Word
+
+
+{-# INLINE ord8 #-}
+ord8 :: Char -> Word8
+ord8 = fromIntegral . ord