Initial CHICKEN 5 port of intarweb 1.72.0

3 files changed, 121 insertions, 0 deletions

diff --git a/benchmarks/parsers.scm b/benchmarks/parsers.scm
new file mode 100644
index 0000000..e4612e2
--- /dev/null
+++ b/benchmarks/parsers.scm
@@ -0,0 +1,60 @@
+(import intarweb chicken.string chicken.time chicken.time.posix
+        chicken.port srfi-13)
+
+(define (mk-headers . strs)
+  (string-append (string-join strs "\r\n") "\r\n\r\n"))
+
+(begin (newline)
+       (print "---  Request parsing ---")
+       (begin (print "Parsing a minimal HTTP/1.0 request many times")
+              (let* ((str (mk-headers "GET / HTTP/1.0"
+                                      "Host: 127.0.0.1:8080"
+                                      "User-Agent: ApacheBench/2.3"))
+                     (p (open-input-string str)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i  100000))
+                        (##sys#setslot p 10 0) ; rewind
+                        (read-request p)))))
+
+       (begin (print "Parsing a realistic HTTP/1.1 request many times")
+              (let* ((str (mk-headers "GET /foo HTTP/1.1"
+                                      "Host: localhost:8080"
+                                      "User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20140722 Firefox/24.0 Iceweasel/24.7.0"
+                                      "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
+                                      "Accept-Language: en-US,en;q=0.5"
+                                      "Accept-Encoding: gzip, deflate"
+                                      "Connection: keep-alive"))
+                     (p (open-input-string str)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i  100000))
+                        (##sys#setslot p 10 0) ; rewind
+                        (read-request p))))))
+
+(begin (newline)
+       (print "---  Response parsing ---")
+       (begin (print "Parsing a minimal HTTP/1.0 response many times")
+              (let* ((str (mk-headers "HTTP/1.0 200 OK"
+                                      "Content-Length: 10"))
+                     (p (open-input-string str)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i  100000))
+                        (##sys#setslot p 10 0) ; rewind
+                        (read-response p)))))
+
+       (begin (newline)
+              (print "Parsing a realistic HTTP/1.1 response many times")
+              (let* ((str (mk-headers
+                           "HTTP/1.1 404 Not Found"
+                           "Date: Tue, 19 Aug 2014 19:14:24 GMT"
+                           "Server: Apache"
+                           "Vary: Accept-Encoding"
+                           "Content-Encoding: gzip"
+                           "Content-Length: 176"
+                           "Keep-Alive: timeout=15, max=100"
+                           "Connection: Keep-Alive"
+                           "Content-Type: text/html; charset=iso-8859-1"))
+                     (p (open-input-string str)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i  100000))
+                        (##sys#setslot p 10 0) ; rewind
+                        (read-response p))))))
diff --git a/benchmarks/run.scm b/benchmarks/run.scm
new file mode 100644
index 0000000..c7d45c8
--- /dev/null
+++ b/benchmarks/run.scm
@@ -0,0 +1,7 @@
+(print "Unparsers:")
+(print "==========\n")
+(load "unparsers")
+
+(print "\nParsers:")
+(print "==========\n")
+(load "parsers")
diff --git a/benchmarks/unparsers.scm b/benchmarks/unparsers.scm
new file mode 100644
index 0000000..b8db0c8
--- /dev/null
+++ b/benchmarks/unparsers.scm
@@ -0,0 +1,54 @@
+(import chicken.port chicken.time chicken.time.posix intarweb uri-common)
+
+(define null-output-port
+  (make-output-port void void))
+
+(begin (newline)
+       (print "---  Response unparsing ---")
+       (begin (print "Unparsing a minimal HTTP/1.1 response many times")
+              (let ((response (make-response port: null-output-port)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i 100000))
+                        (write-response response)))))
+
+       (begin (print "Unparsing a realistic HTTP/1.1 response many times")
+              (let ((response
+                     (make-response
+                      port: null-output-port
+                      headers: (headers
+                                `((content-type text/css)
+                                  (etag (strong . "1234-0123456789"))
+                                  (content-length 1234)
+                                  (last-modified #(,(seconds->utc-time (current-seconds)) ()))
+                                  (date #(,(seconds->utc-time (current-seconds)) ())))))))
+                (time (do ((i 0 (add1 i)))
+                          ((= i 100000))
+                        (write-response response))))))
+
+(begin (newline)
+       (print "---  Request unparsing ---")
+       (begin (print "Unparsing a minimal HTTP/1.1 request many times")
+              (let ((request
+                     (make-request port: null-output-port)))
+                (time (do ((i 0 (add1 i)))
+                          ((= i 100000))
+                        (write-request request)))))
+
+       (begin (print "Unparsing a realistic HTTP/1.1 request many times")
+              (let ((request
+                     (make-request
+                      port: null-output-port
+                      uri: (uri-reference "http://www.call-cc.org/test.example")
+                      headers: (headers
+                                `((user-agent (("Mozilla" "5.0"
+                                                "X11; U; NetBSD amd64; en-US; rv:1.9.0.3")
+                                               ("Gecko" "2008110501" #f)
+                                               ("Minefield" "3.0.3" #f)))
+                                  (host ("example.com" . 8080))
+                                  (accept text/html application/xhtml+xml
+                                          #(application/xml ((q . 0.9))) #(*/* ((q . 0.8))))
+                                  (accept-language en-US #(en ((q . 0.5))))
+                                  (accept-encoding gzip deflate))))))
+                (time (do ((i 0 (add1 i)))
+                          ((= i 100000))
+                        (write-request request))))))