Convert from wai/warp to mini-http-server

1 files changed, 16 insertions, 44 deletions

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