1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
|
