Test http parser somewhat

2 files changed, 110 insertions, 17 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
diff --git a/tirclogv.cabal b/tirclogv.cabal
index c212830..cf073b0 100644
--- a/tirclogv.cabal
+++ b/tirclogv.cabal
@@ -6,7 +6,17 @@ maintainer:      Tom Smeding
 license:         BSD-3-Clause
 build-type:      Simple
 
+common common
+  default-language: Haskell2010
+  default-extensions:
+    ImportQualifiedPost
+    LambdaCase
+    MultiWayIf
+    TypeApplications
+    TupleSections
+
 executable tirclogv
+  import: common
   main-is: Main.hs
   other-modules:
     AtomicPrint
@@ -38,16 +48,10 @@ executable tirclogv
     vector
   hs-source-dirs: src
   c-sources: cbits/mmap.c
-  default-language: Haskell2010
-  default-extensions:
-    ImportQualifiedPost
-    LambdaCase
-    MultiWayIf
-    TypeApplications
-    TupleSections
   ghc-options: -Wall -threaded
 
 library mini-http-server
+  import: common
   exposed-modules:
     Network.HTTP.Server.Mini
     Network.HTTP.Server.Mini.URI
@@ -65,20 +69,26 @@ library mini-http-server
     transformers,
     stm
   hs-source-dirs: mini-http-server
-  default-language: Haskell2010
-  default-extensions:
-    ImportQualifiedPost
-    LambdaCase
-    MultiWayIf
   ghc-options: -Wall
 
-executable mini-http-server-test
-  main-is: mini-http/Main.hs
+test-suite server-test
+  import: common
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  build-depends:
+    base,
+    mini-http-server,
+    bytestring,
+    hedgehog,
+    transformers
+  hs-source-dirs: server-test
+  ghc-options: -Wall
+
+executable echo-server
+  import: common
+  main-is: mini-http-server/Main.hs
   build-depends:
     base,
     mini-http-server,
     bytestring
-  default-language: Haskell2010
-  default-extensions:
-    ImportQualifiedPost
   ghc-options: -Wall