From 8db2f4fda69c213f0083eab0cfd7cd5c0ffce36a Mon Sep 17 00:00:00 2001
From: Jan Sucan <jan@jansucan.com>
Date: Wed, 27 Aug 2025 21:30:27 +0200
Subject: 16_a_4: Add solution

---
 README.md      |  2 +-
 ch16/16_a_4.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 96 insertions(+), 1 deletion(-)
 create mode 100644 ch16/16_a_4.hs

diff --git a/README.md b/README.md
index 064c941..c14bd63 100644
--- a/README.md
+++ b/README.md
@@ -175,7 +175,7 @@ are prefixed with 'Module_'.
 | **_16_a_1_**   | yes    | 403  | 16. Using parsec |
 | 16_a_2         | yes    |      | |
 | 16_a_3         | yes    |      | |
-| 16_a_4         |        |      | |
+| 16_a_4         | yes    |      | |
 | **_18_a_1_**   |        | 436  | 18. Monad transformers |
 | 18_a_2         |        |      | |
 | 18_a_3         |        |      | |
diff --git a/ch16/16_a_4.hs b/ch16/16_a_4.hs
new file mode 100644
index 0000000..c828c37
--- /dev/null
+++ b/ch16/16_a_4.hs
@@ -0,0 +1,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
-- 
cgit v1.2.3