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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
-- Our HTTP request parser is too simple to be useful in real deployments. It is
-- missing vital functionality and is not resistant to even the most basic
-- denial-of-service attacks.
-- Make the parser honor the Content-Length field properly, if it is present.
{-- From examples/examples/ch16/HttpRequestParser.hs and modified --}
-- No need to import ApplicativeParsec with custom Applicative and Alternative instances
import Control.Applicative
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import Numeric (readDec)
import Control.Monad (liftM4, liftM2)
import Data.List -- For easier definition of test requests
type UserStateContentLength = Integer
unlimitedContentLength :: Integer
unlimitedContentLength = -1
p_headers :: CharParser UserStateContentLength [(String, String)]
p_headers = ((try contentLength) <|> header) `manyTill` crlf
where contentLength = liftA2 (,) (string "Content-Length") (char ':' *> spaces *> contentLengthValue)
contentLengthValue = do
s <- (many1 digit <* crlf)
case readDec s of
[(n, _)] -> do
setState n
return s
_ -> return s
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 UserStateContentLength HttpRequest
p_request = q "GET" Get (pure Nothing)
<|> q "POST" Post (Just <$> getBody)
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
getBody = do
len <- getState
if len >= 0
then getBodyLength len
else many anyChar -- Unlimited body length
getBodyLength 0 = return []
getBodyLength n = (eof *> return []) <|> (liftM2 (:) anyChar (getBodyLength (n-1)))
{-- End of code from examples --}
testReqNoContentLength :: String
testReqNoContentLength = intercalate "\r\n" [
"POST /index.html HTTP/1.1",
"Host: book.realworldhaskell.org",
"User-Agent: Mozilla/5.0",
"Accept: text/html",
"",
"Hello World!"
] ++ "\r\n"
testReqContentLength :: Integer -> String
testReqContentLength len = intercalate "\r\n" [
"POST /index.html HTTP/1.1",
"Host: book.realworldhaskell.org",
"User-Agent: Mozilla/5.0",
"Accept: text/html",
"Content-Length: " ++ show len,
"",
"Hello World!"
] ++ "\r\n"
-- ghci> :l 16_a_1.hs
-- [1 of 2] Compiling Main ( 16_a_1.hs, interpreted )
-- Ok, one module loaded.
-- ghci> runParser p_request unlimitedContentLength "" testReqNoContentLength
-- Right (HttpRequest {reqMethod = Post, reqURL = "index.html", reqHeaders = [("Host","book.realworldhaskell.org"),("User-Agent","Mozilla/5.0"),("Accept","text/html")], reqBody = Just "Hello World!\r\n"})
-- ghci> runParser p_request unlimitedContentLength "" (testReqContentLength 0)
-- Right (HttpRequest {reqMethod = Post, reqURL = "index.html", reqHeaders = [("Host","book.realworldhaskell.org"),("User-Agent","Mozilla/5.0"),("Accept","text/html"),("Content-Length","0")], reqBody = Just ""})
-- ghci> runParser p_request unlimitedContentLength "" (testReqContentLength 7)
-- Right (HttpRequest {reqMethod = Post, reqURL = "index.html", reqHeaders = [("Host","book.realworldhaskell.org"),("User-Agent","Mozilla/5.0"),("Accept","text/html"),("Content-Length","7")], reqBody = Just "Hello W"})
-- ghci> runParser p_request unlimitedContentLength "" (testReqContentLength 123)
-- Right (HttpRequest {reqMethod = Post, reqURL = "index.html", reqHeaders = [("Host","book.realworldhaskell.org"),("User-Agent","Mozilla/5.0"),("Accept","text/html"),("Content-Length","123")], reqBody = Just "Hello World!\r\n"})
|
