1;;;; web-client.test --- HTTP client -*- mode: scheme; coding: utf-8; -*- 2;;;; 3;;;; Copyright (C) 2013 Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19 20(define-module (test-suite web-client) 21 #:use-module (web client) 22 #:use-module (web request) 23 #:use-module (web response) 24 #:use-module (ice-9 iconv) 25 #:use-module (ice-9 binary-ports) 26 #:use-module (test-suite lib)) 27 28 29(define get-request-headers:www.gnu.org/software/guile/ 30 "GET /software/guile/ HTTP/1.1 31Host: www.gnu.org 32Connection: close 33 34") 35 36(define get-response-headers:www.gnu.org/software/guile/ 37 "HTTP/1.1 200 OK 38Date: Fri, 11 Jan 2013 10:59:11 GMT 39Server: Apache/2.2.14 40Accept-Ranges: bytes 41Cache-Control: max-age=0 42Expires: Fri, 11 Jan 2013 10:59:11 GMT 43Vary: Accept-Encoding 44Content-Length: 8077 45Connection: close 46Content-Type: text/html 47Content-Language: en 48 49") 50 51(define get-response-body:www.gnu.org/software/guile/ 52 "<!DOCTYPE html PUBLIC \"-//IETF//DTD HTML 2.0//EN\"> 53<html> 54<head> 55 <title>GNU Guile (About Guile)</title> 56 <link rel=\"stylesheet\" type=\"text/css\" href=\"/gnu.css\"> 57 <link rel=\"stylesheet\" type=\"text/css\" href=\"/software/guile/guile.css\"> 58 <link rev=\"made\" href=\"mailto:bug-guile@gnu.org\"> 59</head> 60 61<!-- If you edit these html pages directly, you're not doing yourself any 62 favors - these pages get updated programaticly from a pair of files. Edit 63 the files under the template directory instead --> 64 65<!-- Text black on white, unvisited links blue, visited links navy, 66 active links red --> 67 68<body bgcolor=\"#ffffff\" text=\"#000000\" link=\"#1f00ff\" alink=\"#ff0000\" vlink=\"#000080\"> 69 <a name=\"top\"></a> 70 <table cellpadding=\"10\"> 71 <tr> 72 <td> 73\t<a href=\"/software/guile/\"> 74\t <img src=\"/software/guile/graphics/guile-banner.small.png\" alt=\"Guile\"> 75\t</a> 76 </td> 77 <td valign=\"bottom\"> 78\t<h4 align=\"right\">The GNU extension language</h4> 79\t<h4 align=\"right\">About Guile</h4> 80 </td> 81 </tr> 82 </table> 83 <br /> 84 <table border=\"0\"> 85 86 <!-- Table with 2 columns. One along the left (navbar) and one along the 87\t right (body). On the main page, the left links to anchors on the right, 88\t or to other pages. The left has 2 sections. Top is global navigation, 89\t the bottom is local nav. --> 90 91 <tr> 92 <td class=\"sidebar\"> 93\t<table cellpadding=\"4\"> 94\t <tr> 95\t <!-- Global Nav --> 96 97\t <td nowrap=\"\"> 98\t <p><b>About Guile</b><br /> 99\t\t<a href=\"/software/guile/guile.html\">What is Guile?</a><br /> 100\t\t<a href=\"/software/guile/news.html\">News</a><br /> 101\t\t<a href=\"/software/guile/community.html\">Community</a><br /> 102\t </p> 103\t 104\t <p><b>Documentation</b><br /> 105\t\t<a href=\"/software/guile/docs/docs.html\">Manuals</a><br /> 106\t\t<a href=\"/software/guile/docs/faq/guile-faq.html\">FAQ's</a><br /> 107\t </p> 108 109\t <p><b>Download</b><br /> 110\t\t<a href=\"/software/guile/download.html#releases\">Releases</a><br /> 111\t\t<a href=\"/software/guile/download.html#git\">Repository</a><br /> 112\t\t<a href=\"/software/guile/download.html#snapshots\">Snapshots</a><br /> 113\t </p> 114 115\t <p><b>Projects</b><br /> 116\t\t<a href=\"/software/guile/gnu-guile-projects.html#Core\">Core</a><br /> 117\t\t<a href=\"/software/guile/gnu-guile-projects.html#GUI\">GUI</a><br /> 118\t\t<a href=\"/software/guile/gnu-guile-projects.html#File-Formats\">File Formats</a><br /> 119\t\t<a href=\"/software/guile/gnu-guile-projects.html#Networking\">Networking</a><br /> 120\t\t<a href=\"/software/guile/gnu-guile-projects.html#Tools\">Tools</a><br /> 121\t\t<a href=\"/software/guile/gnu-guile-projects.html#Applications\">Applications</a><br /> 122\t </p> 123\t 124\t <p><b>Development</b><br /> 125\t\t<a href=\"http://savannah.gnu.org/projects/guile/\">Project summary</a><br /> 126\t\t<a href=\"/software/guile/developers.html\">Helping out</a><br /> 127\t\t<a href=\"/software/guile/ideas.html\">Cool ideas</a><br /> 128\t </p> 129 130\t <p><b>Resources</b><br> 131\t\t<a href=\"/software/guile/resources.html#guile_resources\">Guile Resources</a><br /> 132\t\t<a href=\"/software/guile/resources.html##scheme_resources\">Scheme Resources</a><br /> 133\t </p> 134\t </td> 135\t </tr> 136\t <tr> 137 138\t <!-- Global Nav End --> 139\t 140 <tr> 141 <td> 142 <p><a href=\"http://www.gnu.org/\">GNU Project home page</a></p> 143 <p><a href=\"#whatisit\">What is Guile?</a></p> 144 <p><a href=\"#get\">Getting Guile</a></p> 145 </td> 146 </tr> 147 148 149\t </tr> 150\t</table> 151 </td> 152 153 <td class=\"rhs-body\"> 154 155\t 156 <a name=\"whatisit\"><h3 align=\"left\">What is Guile? What can it do for you?</h3></a> 157 <p> 158 Guile is the <em>GNU Ubiquitous Intelligent Language for Extensions</em>, 159 the official extension language for the 160 <a href=\"http://www.gnu.org/\">GNU operating system</a>. 161 </p> 162 163 <p> 164 Guile is a library designed to help programmers create flexible 165 applications. Using Guile in an application allows the application's 166 functionality to be <em>extended</em> by users or other programmers with 167 plug-ins, modules, or scripts. Guile provides what might be described as 168 \"practical software freedom,\" making it possible for users to customize an 169 application to meet their needs without digging into the application's 170 internals. 171 </p> 172 173 <p> 174 There is a long list of proven applications that employ extension languages. 175 Successful and long-lived examples of Free Software projects that use 176 Guile are <a href=\"http://www.texmacs.org/\">TeXmacs</a>, 177 <a href=\"http://lilypond.org/\">LilyPond</a>, and 178 <a href=\"http://www.gnucash.org/\">GnuCash</a>. 179 </p> 180 181 <h3>Guile is a programming language</h3> 182 183 <p> 184 Guile is an interpreter and compiler for 185 the <a href=\"http://schemers.org/\">Scheme</a> programming language, a clean 186 and elegant dialect of Lisp. Guile is up to date with recent Scheme 187 standards, supporting the 188 <a href=\"http://www.schemers.org/Documents/Standards/R5RS/\">Revised<sup>5</sup></a> 189 and most of the <a href=\"http://www.r6rs.org/\">Revised<sup>6</sup></a> language 190 reports (including hygienic macros), as well as many 191 <a href=\"http://srfi.schemers.org/\">SRFIs</a>. It also comes with a library 192 of modules that offer additional features, like an HTTP server and client, 193 XML parsing, and object-oriented programming. 194 </p> 195 196 <h3>Guile is an extension language platform</h3> 197 198 <p> 199 Guile is an efficient virtual machine that executes a portable instruction 200 set generated by its optimizing compiler, and integrates very easily with C 201 and C++ application code. In addition to Scheme, Guile includes compiler 202 front-ends for 203 <a href=\"http://www.ecma-international.org/publications/standards/Ecma-262.htm\">ECMAScript</a> 204 and <a href=\"http://www.emacswiki.org/cgi-bin/wiki?EmacsLisp\">Emacs Lisp</a> 205 (support for <a href=\"http://www.lua.org/\">Lua</a> is underway), which means 206 your application can be extended in the language (or languages) most 207 appropriate for your user base. And Guile's tools for parsing and compiling 208 are exposed as part of its standard module set, so support for additional 209 languages can be added without writing a single line of C. 210 </p> 211 212 <h3>Guile gives your programs more power</h3> 213 214 <p> 215 Using Guile with your program makes it more usable. Users don't 216 need to learn the plumbing of your application to customize it; they just 217 need to understand Guile, and the access you've provided. They can easily 218 trade and share features by downloading and creating scripts, instead of 219 trading complex patches and recompiling their applications. They don't need 220 to coordinate with you or anyone else. Using Guile, your application has a 221 full-featured scripting language right from the beginning, so you can focus 222 on the novel and attention-getting parts of your application. 223 </p> 224 225 <a name=\"get\"><h2 align=\"center\">How do I get Guile?</h2></a> 226 227 <ul> 228 <li>The current <em>stable</em> release is 229 <a href=\"ftp://ftp.gnu.org/gnu/guile/guile-2.0.7.tar.gz\">2.0.7</a>. 230 </li> 231 </ul> 232 233 <p> 234 See the <a href=\"download.html\">Download</a> page for additional ways of 235 getting Guile. 236 </p> 237 238 239 240 </td> 241 </tr> 242 </table> 243 244 <br /> 245 <div class=\"copyright\"> 246 247 <p> 248 Please send FSF & GNU inquiries & questions to 249 <a href=\"mailto:gnu@gnu.org\"><em>gnu@gnu.org</em></a>. There are also 250 <a href=\"/home.html#ContactInfo\">other ways to contact</a> the FSF. 251 </p> 252 253 <p> 254 Please send comments on these web pages to 255 <a href=\"mailto:bug-guile@gnu.org\"><em>bug-guile@gnu.org</em></a>, send 256 other questions to <a href=\"mailto:gnu@gnu.org\"><em>gnu@gnu.org</em></a>. 257 </p> 258 259 <p> 260 Copyright (C) 2012 Free Software Foundation, Inc. 261 </p> 262 263 <p> 264 Verbatim copying and distribution of this entire web page is 265 permitted in any medium, provided this notice is preserved.<P> 266 Updated: 267 268 <!-- timestamp start --> 269 $Date: 2012/11/30 00:16:15 $ $Author: civodul $ 270 <!-- timestamp end --> 271 </p> 272 273 </div> 274 275</body> 276</html> 277") 278 279(define head-request-headers:www.gnu.org/software/guile/ 280 "HEAD /software/guile/ HTTP/1.1 281Host: www.gnu.org 282Connection: close 283 284") 285 286(define head-response-headers:www.gnu.org/software/guile/ 287 "HTTP/1.1 200 OK 288Date: Fri, 11 Jan 2013 11:03:14 GMT 289Server: Apache/2.2.14 290Accept-Ranges: bytes 291Cache-Control: max-age=0 292Expires: Fri, 11 Jan 2013 11:03:14 GMT 293Vary: Accept-Encoding 294Content-Length: 8077 295Connection: close 296Content-Type: text/html 297Content-Language: en 298 299") 300 301;; Unfortunately, POST to http://www.gnu.org/software/guile/ succeeds! 302(define post-request-headers:www.apache.org/ 303 "POST / HTTP/1.1 304Host: www.apache.org 305Connection: close 306 307") 308 309(define post-response-headers:www.apache.org/ 310 "HTTP/1.1 405 Method Not Allowed 311Date: Fri, 11 Jan 2013 11:04:34 GMT 312Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g 313Allow: TRACE 314Content-Length: 314 315Connection: close 316Content-Type: text/html; charset=iso-8859-1 317 318") 319 320(define post-response-body:www.apache.org/ 321"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\"> 322<html><head> 323<title>405 Method Not Allowed</title> 324</head><body> 325<h1>Method Not Allowed</h1> 326<p>The requested method POST is not allowed for the URL /.</p> 327<hr> 328<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port 80</address> 329</body></html> 330") 331 332(define put-request-headers:www.apache.org/ 333 "PUT / HTTP/1.1 334Host: www.apache.org 335Connection: close 336 337") 338 339(define put-response-headers:www.apache.org/ 340 "HTTP/1.1 405 Method Not Allowed 341Date: Fri, 11 Jan 2013 11:04:34 GMT 342Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g 343Allow: TRACE 344Content-Length: 313 345Connection: close 346Content-Type: text/html; charset=iso-8859-1 347 348") 349 350(define put-response-body:www.apache.org/ 351 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\"> 352<html><head> 353<title>405 Method Not Allowed</title> 354</head><body> 355<h1>Method Not Allowed</h1> 356<p>The requested method PUT is not allowed for the URL /.</p> 357<hr> 358<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port 80</address> 359</body></html> 360") 361 362(define delete-request-headers:www.apache.org/ 363 "DELETE / HTTP/1.1 364Host: www.apache.org 365Connection: close 366 367") 368 369(define delete-response-headers:www.apache.org/ 370 "HTTP/1.1 405 Method Not Allowed 371Date: Fri, 11 Jan 2013 11:07:19 GMT 372Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g 373Allow: TRACE 374Content-Length: 316 375Connection: close 376Content-Type: text/html; charset=iso-8859-1 377 378") 379 380 381 382(define delete-response-body:www.apache.org/ 383 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\"> 384<html><head> 385<title>405 Method Not Allowed</title> 386</head><body> 387<h1>Method Not Allowed</h1> 388<p>The requested method DELETE is not allowed for the URL /.</p> 389<hr> 390<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port 80</address> 391</body></html> 392") 393 394(define options-request-headers:www.apache.org/ 395 "OPTIONS / HTTP/1.1 396Host: www.apache.org 397Connection: close 398 399") 400 401(define options-response-headers:www.apache.org/ 402 "HTTP/1.1 200 OK 403Date: Fri, 11 Jan 2013 11:08:31 GMT 404Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g 405Allow: OPTIONS,GET,HEAD,POST,TRACE 406Cache-Control: max-age=3600 407Expires: Fri, 11 Jan 2013 12:08:31 GMT 408Content-Length: 0 409Connection: close 410Content-Type: text/html; charset=utf-8 411 412") 413 414;; This depends on the exact request that we send. I copied this off 415;; the console with an "nc" session, so it doesn't include the CR bytes. 416;; But that's OK -- we just have to decode the body as an HTTP request 417;; and check that it's the same. 418(define trace-request-headers:www.apache.org/ 419 "TRACE / HTTP/1.1\r 420Host: www.apache.org\r 421Connection: close\r 422\r 423") 424 425(define trace-response-headers:www.apache.org/ 426 "HTTP/1.1 200 OK\r 427Date: Fri, 11 Jan 2013 12:36:13 GMT\r 428Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g\r 429Connection: close\r 430Transfer-Encoding: chunked\r 431Content-Type: message/http\r 432\r 433") 434 435(define trace-response-body:www.apache.org/ 436 "3d\r 437TRACE / HTTP/1.1\r 438Host: www.apache.org\r 439Connection: close\r 440\r 441\r 4420\r 443\r 444") 445 446(define (requests-equal? r1 r2) 447 (and (equal? (request-method r1) (request-method r2)) 448 (equal? (request-uri r1) (request-uri r2)) 449 (equal? (request-version r1) (request-version r2)) 450 (equal? (request-headers r1) (request-headers r2)))) 451 452(define (responses-equal? r1 r2) 453 (and (equal? (response-code r1) (response-code r2)) 454 (equal? (response-version r1) (response-version r2)) 455 (equal? (response-headers r1) (response-headers r2)))) 456 457(define* (run-with-http-transcript 458 expected-request expected-request-body request-body-encoding 459 response response-body response-body-encoding 460 proc) 461 (let ((reading? #f) 462 (writing? #t) 463 (response-port (open-input-string response)) 464 (response-body-port (open-bytevector-input-port 465 (string->bytevector response-body 466 response-body-encoding)))) 467 (call-with-values (lambda () (open-bytevector-output-port)) 468 (lambda (request-port get-bytevector) 469 (define (put-char c) 470 (unless writing? 471 (error "Port closed for writing")) 472 (put-u8 request-port (char->integer c))) 473 (define (put-string s) 474 (string-for-each put-char s) 475 (set! writing? #f) 476 (set! reading? #t) 477 (let* ((p (open-bytevector-input-port (get-bytevector))) 478 (actual-request (read-request p)) 479 (actual-body (read-request-body actual-request))) 480 (pass-if "requests equal" 481 (requests-equal? actual-request 482 (call-with-input-string expected-request 483 read-request))) 484 (pass-if "request bodies equal" 485 (equal? (or actual-body #vu8()) 486 (string->bytevector expected-request-body 487 request-body-encoding))))) 488 (define (get-char) 489 (unless reading? 490 (error "Port closed for reading")) 491 (let ((c (read-char response-port))) 492 (if (char? c) 493 c 494 (let ((u8 (get-u8 response-body-port))) 495 (if (eof-object? u8) 496 u8 497 (integer->char u8)))))) 498 (define (close) 499 (when writing? 500 (unless (eof-object? (get-u8 response-body-port)) 501 (error "Failed to consume all of body")))) 502 (let ((soft-port (make-soft-port 503 (vector put-char put-string #f get-char close) 504 "rw"))) 505 ;; Arrange it so that the only time our put-char/put-string 506 ;; functions are called is during force-output. 507 (setvbuf soft-port 'block 10000) 508 (proc soft-port)))))) 509 510(define* (check-transaction method uri 511 request-headers request-body request-body-encoding 512 response-headers response-body response-body-encoding 513 proc 514 #:key (response-body-comparison response-body)) 515 (with-test-prefix (string-append method " " uri) 516 (run-with-http-transcript 517 request-headers request-body request-body-encoding 518 response-headers response-body response-body-encoding 519 (lambda (port) 520 (call-with-values (lambda () 521 (proc uri #:port port)) 522 (lambda (response body) 523 (pass-if "response equal" 524 (responses-equal? 525 response 526 (call-with-input-string response-headers read-response))) 527 (pass-if "response body equal" 528 (equal? (or body "") response-body-comparison)))))))) 529 530(check-transaction 531 "GET" "http://www.gnu.org/software/guile/" 532 get-request-headers:www.gnu.org/software/guile/ "" "iso-8859-1" 533 get-response-headers:www.gnu.org/software/guile/ 534 get-response-body:www.gnu.org/software/guile/ "iso-8859-1" 535 http-get) 536 537(check-transaction 538 "HEAD" "http://www.gnu.org/software/guile/" 539 head-request-headers:www.gnu.org/software/guile/ "" "iso-8859-1" 540 head-response-headers:www.gnu.org/software/guile/ "" "iso-8859-1" 541 http-head) 542 543(check-transaction 544 "POST" "http://www.apache.org/" 545 post-request-headers:www.apache.org/ "" "iso-8859-1" 546 post-response-headers:www.apache.org/ 547 post-response-body:www.apache.org/ "iso-8859-1" 548 http-post) 549 550(check-transaction 551 "PUT" "http://www.apache.org/" 552 put-request-headers:www.apache.org/ "" "iso-8859-1" 553 put-response-headers:www.apache.org/ 554 put-response-body:www.apache.org/ "iso-8859-1" 555 http-put) 556 557(check-transaction 558 "DELETE" "http://www.apache.org/" 559 delete-request-headers:www.apache.org/ "" "iso-8859-1" 560 delete-response-headers:www.apache.org/ 561 delete-response-body:www.apache.org/ "iso-8859-1" 562 http-delete) 563 564(check-transaction 565 "OPTIONS" "http://www.apache.org/" 566 options-request-headers:www.apache.org/ "" "utf-8" 567 options-response-headers:www.apache.org/ "" "utf-8" 568 http-options) 569 570(check-transaction 571 "TRACE" "http://www.apache.org/" 572 trace-request-headers:www.apache.org/ "" "iso-8859-1" 573 trace-response-headers:www.apache.org/ 574 trace-response-body:www.apache.org/ "iso-8859-1" 575 http-trace 576 #:response-body-comparison 577 ;; The body will be message/http, which is logically a sequence of 578 ;; bytes, not characters. It happens that iso-8859-1 can encode our 579 ;; body and is compatible with the headers as well. 580 (string->bytevector trace-request-headers:www.apache.org/ 581 "iso-8859-1")) 582
