diff options
| -rw-r--r-- | README.md | 2 | ||||
| -rw-r--r-- | ch16/16_a_1.hs | 110 |
2 files changed, 111 insertions, 1 deletions
@@ -172,7 +172,7 @@ are prefixed with 'Module_'. | **_15_a_1_** | yes | 382 | 15. Programming with monads | | 15_a_2 | yes, in 15_a_1 | | | | 15_a_3 | yes | | | -| **_16_a_1_** | | 403 | 16. Using parsec | +| **_16_a_1_** | yes | 403 | 16. Using parsec | | 16_a_2 | | | | | 16_a_3 | | | | | 16_a_4 | | | | diff --git a/ch16/16_a_1.hs b/ch16/16_a_1.hs new file mode 100644 index 0000000..9f8bc2f --- /dev/null +++ b/ch16/16_a_1.hs @@ -0,0 +1,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"}) |