1 files changed, 83 insertions, 0 deletions
diff --git a/server-test/Main.hs b/server-test/Main.hs
new file mode 100644
index 0000000..d15ad70
--- /dev/null
+++ b/server-test/Main.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Monad.Trans.State.Strict
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Hedgehog
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+import System.Exit
+
+import Network.HTTP.Server.Mini.Internal.Parser
+import Network.HTTP.Server.Mini.Types
+
+
+randomSlicing :: Int -> Int -> Gen [Int]
+randomSlicing n _ | n <= 0 = error "no slices"
+randomSlicing 1 target = return [target]
+randomSlicing numslice target = do
+  n1 <- Gen.integral (Range.constant 1 (target - numslice))
+  ns <- (n1:) <$> go (numslice - 1) (target - n1)
+  if sum ns /= target || any (== 0) ns then error (show (ns, target)) else return ()
+  Gen.shuffle ns
+  where
+    go 1 tg
+      | tg <= 0 = error "impossible"
+      | otherwise = return [tg]
+    go ns tg
+      | tg < ns = error "impossible"
+      | tg == ns = return (replicate ns 1)
+      | otherwise = do
+          s <- Gen.integral (Range.constant 1 (min (tg - (ns-1)) (round (fromIntegral (3 * tg) / fromIntegral ns :: Double))))
+          (s:) <$> go (ns-1) (tg - s)
+
+randomTextSlicing :: ByteString -> Gen [ByteString]
+randomTextSlicing str = do
+  nfragments <- Gen.integral (Range.linear 1 10)
+  lens <- randomSlicing nfragments (BS.length str)
+  let slices [] _ = []
+      slices (l:ls) r = let (pre, post) = BS.splitAt l r
+                        in pre : slices ls post
+  return (slices lens str)
+
+readRequestSliced :: Int -> [ByteString] -> Maybe Request
+readRequestSliced maxlen slices =
+  evalState (readRequest maxlen (\_ -> state (\case x:xs -> (x, xs)
+                                                    [] -> (BS.empty, []))))
+            slices
+
+prop_valid :: Property
+prop_valid = property $ do
+  crlf <- forAll (Gen.choice [pure "\r\n", pure "\n"])
+  slices <- forAll (randomTextSlicing (requestText crlf))
+  readRequestSliced 4096 slices === Just answer
+  where
+    requestText :: ByteString -> ByteString
+    requestText crlf = BS.concat
+      ["GET /path/x?q=1&a=2 HTTP/1.1", crlf
+      ,"Host: tirclogv.example", crlf
+      ,"Accept: */*", crlf
+      ,crlf]
+
+    answer = Request
+      { reqMethod = "GET"
+      , reqURI = "/path/x?q=1&a=2"
+      , reqHeaders = [("host", "tirclogv.example"), ("accept", "*/*")]
+      , reqPath = ["path", "x"]
+      , reqQuery = [("q", "1"), ("a", "2")]
+      }
+
+tests :: IO Bool
+tests = checkParallel $ Group "mini-http-server"
+  [("valid", withTests 10000 prop_valid)
+  ]
+
+-- main :: IO ()
+-- main = do
+--   print $ evalState (readRequest 4096 (\_ -> state (\case x:xs -> (x, xs); [] -> (BS.empty, [])))) ["GET /path/x?q=1&a=2 HTTP/1.1\r\nHost: tirclogv.example\r\nAccept: */*\r\n", "\r", "\n"]
+
+main :: IO ()
+main = tests >>= \case
+  True -> exitSuccess
+  False -> exitFailure