Convert from wai/warp to mini-http-server

9 files changed, 298 insertions, 73 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
diff --git a/src/Main.hs b/src/Main.hs
index 45a9eca..6b8e884 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,15 +3,13 @@
 {-# LANGUAGE ViewPatterns #-}
 module Main (main) where
 
-import Control.Exception (mask_)
-import Control.Monad (when, forM, guard)
+import Control.Monad (forM, guard)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as BSL
 import Data.Char (isDigit, ord)
-import Data.Function (on, (&))
-import Data.IORef
+import Data.Function (on)
 import Data.List.NonEmpty (NonEmpty((:|)), groupBy)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -20,18 +18,15 @@ import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import Data.Text.IO.Utf8 qualified as T
 import Data.Time (Day, toGregorian, fromGregorianValid)
-import Network.Wai
-import Network.HTTP.Types
-import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort)
-import Network.Wai.Handler.Warp.Internal (Settings(..))
 import System.Environment
 import System.Exit (die)
-import System.Posix.Resource
 import Text.Mustache (Template, compileTemplate, substituteValue, (~>))
 import Text.Mustache qualified as M
 import Text.Mustache.Types (Value(..))
 import Text.Read (readMaybe)
 
+import Network.HTTP.Server.Mini
+
 -- import Debug.Trace
 
 import AtomicPrint
@@ -185,10 +180,7 @@ classListAdd Nothing t = t
 classListAdd (Just l) t = l <> " " <> t
 
 query :: Request -> ByteString -> Maybe ByteString
-query req key = case lookup key (queryString req) of
-              Nothing -> Nothing
-              Just Nothing -> Nothing  -- given but empty; treat as not given
-              Just (Just value) -> Just value
+query req key = lookup key (reqQuery req)
 
 -- Returns: (classlist, (nickwrap1, nick, nickwrap2), message)
 renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text)
@@ -247,14 +239,6 @@ page404 message = return $ responseLBS
   [("Content-Type", "text/plain")]
   message
 
-getUlimitFiles :: IO Int
-getUlimitFiles = do
-  limits <- getResourceLimit ResourceOpenFiles
-  let infer ResourceLimitInfinity = maxBound
-      infer ResourceLimitUnknown = maxBound
-      infer (ResourceLimit n) = fromIntegral n
-  return (infer (softLimit limits) `min` infer (hardLimit limits))
-
 mainServe :: FilePath -> IO ()
 mainServe confpath = do
   config <- enrichConfig <$> readConfig confpath
@@ -270,34 +254,22 @@ mainServe confpath = do
                Right tpl -> return (name, tpl)
                Left err -> die (show err)
 
-  -- TODO: handle this more properly with making clients wait (or dropping them
-  -- in the kernel already) instead of dropping connections here
-  ulimitFiles <- getUlimitFiles
-  counter <- newIORef 0
-  let connectionLimit = max 2 (ulimitFiles - 100)
-      checkedFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
-      checkedFork k = mask_ $ do
-        count <- atomicModifyIORef' counter (\i -> (i + 1, i + 1))
-        when (count <= connectionLimit) $
-          settingsFork defaultSettings k
-        atomicModifyIORef' counter (\i -> (i - 1, ()))
-      settings = defaultSettings & setFork checkedFork
-                                 & setPort (confPort config)
+  let settings = defaultSettings { setPort = confPort config }
 
   atomicPrintS $ "Listening on port " ++ show (confPort config)
-  runSettings settings $ \req respond -> case pathInfo req of
+  run settings $ \req -> case reqPath req of
     [] ->
-      respond =<< pageIndex config pages
-    ["log", alias] ->
-      respond =<< pageLog config pages index req alias
-    ["cal", alias] ->
-      respond =<< pageCalendar config pages index alias
-    ["cal", alias, date] ->
-      respond =<< pageCalendarDay config pages index req alias date
+      pageIndex config pages
+    ["log", TE.decodeUtf8' -> Right alias] ->
+      pageLog config pages index req alias
+    ["cal", TE.decodeUtf8' -> Right alias] ->
+      pageCalendar config pages index alias
+    ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] ->
+      pageCalendarDay config pages index req alias date
     [fname] | fname `elem` staticFiles ->
-      respond $ responseFile status200 [] ("pages/" ++ T.unpack fname) Nothing
+      return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname)
     _ ->
-      respond =<< page404 "URL not found"
+      page404 "URL not found"
 
 testParseLog :: FilePath -> IO ()
 testParseLog fname = print =<< parseLog <$> BS.readFile fname
diff --git a/tirclogv.cabal b/tirclogv.cabal
index c1070ab..cb7f58b 100644
--- a/tirclogv.cabal
+++ b/tirclogv.cabal
@@ -21,6 +21,7 @@ executable tirclogv
     ZNC
   build-depends:
     base >= 4.19,
+    mini-http-server,
     attoparsec,
     bytestring,
     clock,
@@ -28,16 +29,13 @@ executable tirclogv
     directory,
     filepath,
     fsnotify,
-    http-types,
     mustache,
     random,
     text >= 2.1.2,
     transformers,
     time,
     unix,
-    vector,
-    wai,
-    warp >= 3.4.12
+    vector
   hs-source-dirs: src
   c-sources: cbits/mmap.c
   default-language: Haskell2010
@@ -49,15 +47,19 @@ executable tirclogv
     TupleSections
   ghc-options: -Wall -threaded
 
-library mini-http
+library mini-http-server
   exposed-modules:
     Network.HTTP.Server.Mini
+    Network.HTTP.Server.Mini.URI
     Network.HTTP.Server.Mini.Types
   other-modules:
     Network.HTTP.Server.Mini.Parser
+    Network.HTTP.Server.Mini.Printer
+    Network.HTTP.Server.Mini.Util
   build-depends:
     base,
     bytestring,
+    flatparse,
     network,
     transformers,
     stm
@@ -68,3 +70,14 @@ library mini-http
     LambdaCase
     MultiWayIf
   ghc-options: -Wall
+
+executable mini-http-server-test
+  main-is: mini-http/Main.hs
+  build-depends:
+    base,
+    mini-http-server,
+    bytestring
+  default-language: Haskell2010
+  default-extensions:
+    ImportQualifiedPost
+  ghc-options: -Wall