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
84
85
86
87
88
89
90
91
92
93
94
95
|
-- Another popular attack is to open a connection and either leave it idle or
-- send data extremely slowly.
-- Write a wrapper in the IO monad that will invoke the parser. Use the
-- System.Timeout module to close the connection if the parser does not complete
-- within 30 seconds.
-- The chapter doesn't use network connections in the parsing examples. Closing
-- the connection probably means stopping the parse so it doesn't block for a
-- long time.
import Control.Concurrent (threadDelay)
import System.Timeout (timeout)
import Data.List (intercalate)
{-- From examples/examples/ch16/HttpRequestParser.hs --}
import Control.Applicative
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import Control.Monad (liftM4)
p_headers :: CharParser st [(String, String)]
p_headers = header `manyTill` crlf
where header = liftA2 (,) fieldName (char ':' *> spaces *> contents)
contents = liftA2 (++) (many1 notEOL <* crlf)
(continuation <|> pure [])
continuation = liftA2 (:) (' ' <$ many1 (oneOf " \t")) contents
fieldName = (:) <$> letter <*> many fieldChar
fieldChar = letter <|> digit <|> oneOf "-_"
crlf :: CharParser st ()
crlf = (() <$ string "\r\n") <|> (() <$ newline)
notEOL :: CharParser st Char
notEOL = noneOf "\r\n"
data Method = Get | Post
deriving (Eq, Ord, Show)
data HttpRequest = HttpRequest {
reqMethod :: Method
, reqURL :: String
, reqHeaders :: [(String, String)]
, reqBody :: Maybe String
} deriving (Eq, Show)
p_request :: CharParser () HttpRequest
p_request = q "GET" Get (pure Nothing)
<|> q "POST" Post (Just <$> many anyChar)
where q name ctor body = liftM4 HttpRequest req url p_headers body
where req = ctor <$ string name <* char ' '
url = optional (char '/') *>
manyTill notEOL (try $ string " HTTP/1." <* oneOf "01")
<* crlf
{-- End of code from examples --}
parseWithTimeout parser request = timeout timeoutMicrosec parse
where
timeoutMicrosec = 30 * 10^6 -- 30 seconds
parse = do
req <- request
let res = runParser p_request () "" req
return res
testRequestWithDelay :: Int -> IO String
testRequestWithDelay delayMicrosec = do
let start = intercalate "\r\n" [
"POST /index.html HTTP/1.1",
"Host: book.realworldhaskell.org",
"User-Agent: Mozilla/5.0",
"Accept: text/html",
"",
"Hello "
]
threadDelay delayMicrosec
return (start ++ "World!")
testRequestFast = testRequestWithDelay (25 * 10^6)
testRequestSlow = testRequestWithDelay (32 * 10^6)
-- ghci> :l 16_a_4.hs
-- [1 of 2] Compiling Main ( 16_a_4.hs, interpreted )
-- Ok, one module loaded.
-- ghci> parseWithTimeout p_request testRequestFast
-- Just (Right (HttpRequest {reqMethod = Post, reqURL = "index.html", reqHeaders = [("Host","book.realworldhaskell.org"),("User-Agent","Mozilla/5.0"),("Accept","text/html")], reqBody = Just "Hello World!"}))
-- ghci> parseWithTimeout p_request testRequestSlow
-- Nothing
|
