examples/web-server/http.scm

   1 ;==============================================================================
   2
   3 ; File: "http.scm", Time-stamp: <2009-03-13 12:05:07 feeley>
   4
   5 ; Copyright (c) 2005-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ;==============================================================================
   8
   9 (##namespace ("http#"))
  10
  11 (##include "~~lib/gambit#.scm")
  12 (##include "html#.scm")
  13
  14 (##include "http#.scm")
  15
  16 (declare
  17   (standard-bindings)
  18   (extended-bindings)
  19   (block)
  20   (not safe)
  21 )
  22
  23 ;==============================================================================
  24
  25 ; Token tables.
  26
  27 (define hash-substring
  28   (lambda (str start end)
  29
  30     (define loop
  31       (lambda (h i)
  32         (if (< i end)
  33             (loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
  34                           65536)
  35                   (+ i 1))
  36             h)))
  37
  38     (loop 0 start)))
  39
  40 (define-macro make-token-table
  41   (lambda alist
  42
  43     ; "alist" is a list of lists of the form "(string expression)"
  44
  45     ; The result is a perfect hash-table represented as a vector of
  46     ; length 2*N, where N is the hash modulus.  If the string S is in
  47     ; the hash-table it is at index
  48     ;
  49     ;   X = (* 2 (modulo (hash-substring S 0 (string-length S)) N))
  50     ;
  51     ; and the associated expression is at index X+1.
  52
  53     (define hash-substring    ; repeated from above to be
  54       (lambda (str start end) ; available for macro expansion
  55
  56         (define loop
  57           (lambda (h i)
  58             (if (< i end)
  59                 (loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
  60                               65536)
  61                       (+ i 1))
  62                 h)))
  63
  64         (loop 0 start)))
  65
  66     (define make-perfect-hash-table
  67       (lambda (alist)
  68         (let loop1 ((n (length alist)))
  69           (let ((v (make-vector (* 2 n) #f)))
  70             (let loop2 ((lst alist))
  71               (if (pair? lst)
  72                   (let* ((x (car lst))
  73                          (str (car x)))
  74                     (let ((h
  75                            (* 2
  76                               (modulo (hash-substring str 0 (string-length str))
  77                                       n))))
  78                       (if (vector-ref v h)
  79                           (loop1 (+ n 1))
  80                           (begin
  81                             (vector-set! v h str)
  82                             (vector-set! v (+ h 1) (cadr x))
  83                             (loop2 (cdr lst))))))
  84                   v))))))
  85
  86       (cons 'vector (vector->list (make-perfect-hash-table alist)))))
  87
  88 (define token-table-lookup-substring
  89   (lambda (table str start end)
  90     (let* ((n (quotient (vector-length table) 2))
  91            (h (* 2 (modulo (hash-substring str start end) n)))
  92            (x (vector-ref table h)))
  93
  94       (define loop
  95         (lambda (i j)
  96           (if (< i end)
  97               (if (char=? (string-ref str i) (string-ref x j))
  98                   (loop (+ i 1) (+ j 1))
  99                   #f)
 100               h)))
 101
 102       (and x
 103            (= (string-length x) (- end start))
 104            (loop start 0)))))
 105
 106 (define token-table-lookup-string
 107   (lambda (table str)
 108     (token-table-lookup-substring table str 0 (string-length str))))
 109
 110 ;==============================================================================
 111
 112 ; URI parsing.
 113
 114 (define hex-digit
 115   (lambda (str i)
 116     (let ((n (char->integer (string-ref str i))))
 117       (cond ((and (>= n 48) (<= n 57))
 118              (- n 48))
 119             ((and (>= n 65) (<= n 70))
 120              (- n 55))
 121             ((and (>= n 97) (<= n 102))
 122              (- n 87))
 123             (else
 124              #f)))))
 125
 126 (define hex-octet
 127   (lambda (str i)
 128     (let ((n1 (hex-digit str i)))
 129       (and n1
 130            (let ((n2 (hex-digit str (+ i 1))))
 131              (and n2
 132                   (+ (* n1 16) n2)))))))
 133
 134 (define plausible-hex-escape?
 135   (lambda (str end j)
 136     (and (< (+ j 2) end)
 137          (not (control-or-space-char? (string-ref str (+ j 1))))
 138          (not (control-or-space-char? (string-ref str (+ j 2)))))))
 139
 140 (define control-or-space-char?
 141   (lambda (c)
 142     (or (not (char<? #\space c))
 143         (not (char<? c #\x7f)))))
 144
 145 (define excluded-char?
 146   (lambda (c)
 147     (or (not (char<? #\space c))
 148         (not (char<? c #\x7f))
 149         (char=? c #\<)
 150         (char=? c #\>)
 151         (char=? c #\#)
 152         (char=? c #\%)
 153         (char=? c #\")
 154         (char=? c #\{)
 155         (char=? c #\})
 156         (char=? c #\|)
 157         (char=? c #\\)
 158         (char=? c #\^)
 159         (char=? c #\[)
 160         (char=? c #\])
 161         (char=? c #\`))))
 162
 163 (define extract-escaped
 164   (lambda (str start n)
 165     (let ((result (make-string n)))
 166       (let loop ((i start) (j 0))
 167         (if (< j n)
 168             (let ((c (string-ref str i)))
 169               (if (char=? c #\%)
 170                   (let ((n (hex-octet str (+ i 1))))
 171                     (and n
 172                          (begin
 173                            (string-set! result j (integer->char n))
 174                            (loop (+ i 3)
 175                                  (+ j 1)))))
 176                   (begin
 177                     (string-set! result j (if (char=? c #\+) #\space c))
 178                     (loop (+ i 1)
 179                           (+ j 1)))))
 180             result)))))
 181
 182 (define-type uri
 183   id: 62788556-c247-11d9-9598-00039301ba52
 184
 185   scheme
 186   authority
 187   path
 188   query
 189   fragment
 190 )
 191
 192 (define parse-uri
 193   (lambda (str start end decode? cont)
 194     (let ((uri (make-uri #f #f "" #f #f)))
 195
 196       (define extract-string
 197         (lambda (i j n)
 198           (if decode?
 199               (extract-escaped str i n)
 200               (substring str i j))))
 201
 202       (define extract-query
 203         (lambda (i j n)
 204           (if decode?
 205               (parse-uri-query
 206                str
 207                i
 208                j
 209                decode?
 210                (lambda (bindings end)
 211                  bindings))
 212               (substring str i j))))
 213
 214       (define state0 ; possibly inside the "scheme" part
 215         (lambda (i j n)
 216           (if (< j end)
 217               (let ((c (string-ref str j)))
 218                 (cond ((char=? c #\:)
 219                        (if (= n 0)
 220                            (state2 j (+ j 1) 1) ; the ":" is in the "path" part
 221                            (let ((scheme (extract-string i j n)))
 222                              (and scheme
 223                                   (begin
 224                                     (uri-scheme-set! uri scheme)
 225                                     (if (and (< (+ j 2) end)
 226                                              (char=? (string-ref str (+ j 1))
 227                                                      #\/)
 228                                              (char=? (string-ref str (+ j 2))
 229                                                      #\/))
 230                                         (state1 (+ j 3) (+ j 3) 0)
 231                                         (state2 (+ j 1) (+ j 1) 0)))))))
 232                       ((char=? c #\/)
 233                        (if (and (= n 0)
 234                                 (< (+ j 1) end)
 235                                 (char=? (string-ref str (+ j 1)) #\/))
 236                            (state1 (+ j 2) (+ j 2) 0)
 237                            (state2 i (+ j 1) (+ n 1))))
 238                       ((char=? c #\?)
 239                        (let ((path (extract-string i j n)))
 240                          (and path
 241                               (begin
 242                                 (uri-path-set! uri path)
 243                                 (state3 (+ j 1) (+ j 1) 0)))))
 244                       ((char=? c #\#)
 245                        (let ((path (extract-string i j n)))
 246                          (and path
 247                               (begin
 248                                 (uri-path-set! uri path)
 249                                 (state4 (+ j 1) (+ j 1) 0)))))
 250                       ((char=? c #\%)
 251                        (and (plausible-hex-escape? str end j)
 252                             (state0 i (+ j 3) (+ n 1))))
 253                       ((control-or-space-char? c)
 254                        (let ((path (extract-string i j n)))
 255                          (and path
 256                               (begin
 257                                 (uri-path-set! uri path)
 258                                 j))))
 259                       (else
 260                        (state0 i (+ j 1) (+ n 1)))))
 261               (let ((path (extract-string i j n)))
 262                 (and path
 263                      (begin
 264                        (uri-path-set! uri path)
 265                        j))))))
 266
 267       (define state1 ; inside the "authority" part
 268         (lambda (i j n)
 269           (if (< j end)
 270               (let ((c (string-ref str j)))
 271                 (cond ((char=? c #\/)
 272                        (let ((authority (extract-string i j n)))
 273                          (and authority
 274                               (begin
 275                                 (uri-authority-set! uri authority)
 276                                 (state2 j (+ j 1) 1)))))
 277                       ((char=? c #\?)
 278                        (let ((authority (extract-string i j n)))
 279                          (and authority
 280                               (begin
 281                                 (uri-authority-set! uri authority)
 282                                 (state3 (+ j 1) (+ j 1) 0)))))
 283                       ((char=? c #\#)
 284                        (let ((authority (extract-string i j n)))
 285                          (and authority
 286                               (begin
 287                                 (uri-authority-set! uri authority)
 288                                 (state4 (+ j 1) (+ j 1) 0)))))
 289                       ((char=? c #\%)
 290                        (and (plausible-hex-escape? str end j)
 291                             (state1 i (+ j 3) (+ n 1))))
 292                       ((control-or-space-char? c)
 293                        (let ((authority (extract-string i j n)))
 294                          (and authority
 295                               (begin
 296                                 (uri-authority-set! uri authority)
 297                                 j))))
 298                       (else
 299                        (state1 i (+ j 1) (+ n 1)))))
 300               (let ((authority (extract-string i j n)))
 301                 (and authority
 302                      (begin
 303                        (uri-authority-set! uri authority)
 304                        j))))))
 305
 306       (define state2 ; inside the "path" part
 307         (lambda (i j n)
 308           (if (< j end)
 309               (let ((c (string-ref str j)))
 310                 (cond ((char=? c #\?)
 311                        (let ((path (extract-string i j n)))
 312                          (and path
 313                               (begin
 314                                 (uri-path-set! uri path)
 315                                 (state3 (+ j 1) (+ j 1) 0)))))
 316                       ((char=? c #\#)
 317                        (let ((path (extract-string i j n)))
 318                          (and path
 319                               (begin
 320                                 (uri-path-set! uri path)
 321                                 (state4 (+ j 1) (+ j 1) 0)))))
 322                       ((char=? c #\%)
 323                        (and (plausible-hex-escape? str end j)
 324                             (state2 i (+ j 3) (+ n 1))))
 325                       ((control-or-space-char? c)
 326                        (let ((path (extract-string i j n)))
 327                          (and path
 328                               (begin
 329                                 (uri-path-set! uri path)
 330                                 j))))
 331                       (else
 332                        (state2 i (+ j 1) (+ n 1)))))
 333               (let ((path (extract-string i j n)))
 334                 (and path
 335                      (begin
 336                        (uri-path-set! uri path)
 337                        j))))))
 338
 339       (define state3 ; inside the "query" part
 340         (lambda (i j n)
 341           (if (< j end)
 342               (let ((c (string-ref str j)))
 343                 (cond ((char=? c #\#)
 344                        (let ((query (extract-query i j n)))
 345                          (and query
 346                               (begin
 347                                 (uri-query-set! uri query)
 348                                 (state4 (+ j 1) (+ j 1) 0)))))
 349                       ((char=? c #\%)
 350                        (and (plausible-hex-escape? str end j)
 351                             (state3 i (+ j 3) (+ n 1))))
 352                       ((control-or-space-char? c)
 353                        (let ((query (extract-query i j n)))
 354                          (and query
 355                               (begin
 356                                 (uri-query-set! uri query)
 357                                 j))))
 358                       (else
 359                        (state3 i (+ j 1) (+ n 1)))))
 360               (let ((query (extract-query i j n)))
 361                 (and query
 362                      (begin
 363                        (uri-query-set! uri query)
 364                        j))))))
 365
 366       (define state4 ; inside the "fragment" part
 367         (lambda (i j n)
 368           (if (< j end)
 369               (let ((c (string-ref str j)))
 370                 (cond ((char=? c #\%)
 371                        (and (plausible-hex-escape? str end j)
 372                             (state4 i (+ j 3) (+ n 1))))
 373                       ((control-or-space-char? c)
 374                        (let ((fragment (extract-string i j n)))
 375                          (and fragment
 376                               (begin
 377                                 (uri-fragment-set! uri fragment)
 378                                 j))))
 379                       (else
 380                        (state4 i (+ j 1) (+ n 1)))))
 381               (let ((fragment (extract-string i j n)))
 382                 (and fragment
 383                      (begin
 384                        (uri-fragment-set! uri fragment)
 385                        j))))))
 386
 387       (let ((i (state0 start start 0)))
 388         (cont (and i uri)
 389               (or i start))))))
 390
 391 (define parse-uri-query
 392   (lambda (str start end decode? cont)
 393     (let ((rev-bindings '()))
 394
 395       (define extract-string
 396         (lambda (i j n)
 397           (if decode?
 398               (extract-escaped str i n)
 399               (substring str i j))))
 400
 401       (define state0
 402         (lambda (i j n)
 403           (if (< j end)
 404             (let ((c (string-ref str j)))
 405               (cond ((char=? c #\%)
 406                      (and (plausible-hex-escape? str end j)
 407                           (state0 i
 408                                   (+ j 3)
 409                                   (+ n 1))))
 410                     ((char=? c #\=)
 411                      (let ((name (extract-string i j n)))
 412                        (and name
 413                             (let ((j (+ j 1)))
 414                               (state1 j
 415                                       j
 416                                       0
 417                                       name)))))
 418                     ((char=? c #\&)
 419                      #f)
 420                     ((excluded-char? c)
 421                      (if (= n 0)
 422                          j
 423                          #f))
 424                     (else
 425                      (state0 i
 426                              (+ j 1)
 427                              (+ n 1)))))
 428             (if (= n 0)
 429                 j
 430                 #f))))
 431
 432       (define state1
 433         (lambda (i j n name)
 434           (if (< j end)
 435             (let ((c (string-ref str j)))
 436               (cond ((char=? c #\%)
 437                      (and (plausible-hex-escape? str end j)
 438                           (state1 i
 439                                   (+ j 3)
 440                                   (+ n 1)
 441                                   name)))
 442                     ((char=? c #\&)
 443                      (let ((val (extract-string i j n)))
 444                        (and val
 445                             (let ((j (+ j 1)))
 446                               (set! rev-bindings
 447                                     (cons (cons name val) rev-bindings))
 448                               (and (< j end)
 449                                    (state0 j
 450                                            j
 451                                            0))))))
 452                     ((char=? c #\=)
 453                      #f)
 454                     ((excluded-char? c)
 455                      (let ((val (extract-string i j n)))
 456                        (and val
 457                             (begin
 458                               (set! rev-bindings
 459                                     (cons (cons name val) rev-bindings))
 460                               j))))
 461                     (else
 462                      (state1 i
 463                              (+ j 1)
 464                              (+ n 1)
 465                              name))))
 466             (let ((val (extract-string i j n)))
 467               (and val
 468                    (begin
 469                      (set! rev-bindings
 470                            (cons (cons name val) rev-bindings))
 471                      j))))))
 472
 473       (let ((i (state0 start start 0)))
 474         (cont (and i (reverse rev-bindings))
 475               (or i start))))))
 476
 477 (define string->uri
 478   (lambda (str decode?)
 479     (parse-uri str
 480                0
 481                (string-length str)
 482                decode?
 483                (lambda (uri end)
 484                  (and (= end (string-length str))
 485                       uri)))))
 486
 487 (define string->uri-query
 488   (lambda (str decode?)
 489     (parse-uri-query str
 490                      0
 491                      (string-length str)
 492                      decode?
 493                      (lambda (query end)
 494                        (and (= end (string-length str))
 495                             query)))))
 496
 497 (define encode-for-uri
 498   (lambda (str)
 499     (let ((end (string-length str)))
 500
 501       (define copy
 502         (lambda (result i j n)
 503           (if (< i j)
 504               (let ((new-j (- j 1))
 505                     (new-n (- n 1)))
 506                 (string-set! result new-n (string-ref str new-j))
 507                 (copy result i new-j new-n))
 508               result)))
 509
 510       (define hex
 511         (lambda (x)
 512           (string-ref "0123456789ABCDEF" (bitwise-and x 15))))
 513
 514       (define encode
 515         (lambda (i j n)
 516           (if (< j end)
 517               (let ((c (string-ref str j)))
 518                 (cond ((char=? c #\space)
 519                        (let ((result (encode (+ j 1) (+ j 1) (+ n 1))))
 520                          (string-set! result n #\+)
 521                          (copy result i j n)))
 522                       ((or (char=? c #\+)
 523                            (excluded-char? c))
 524                        (let ((result (encode (+ j 1) (+ j 1) (+ n 3))))
 525                          (let* ((x (char->integer c))
 526                                 (hi (hex (arithmetic-shift x -4)))
 527                                 (lo (hex x)))
 528                            (string-set! result n #\%)
 529                            (string-set! result (+ n 1) hi)
 530                            (string-set! result (+ n 2) lo))
 531                          (copy result i j n)))
 532                       (else
 533                        (encode i (+ j 1) (+ n 1)))))
 534               (let ((result (make-string n)))
 535                 (copy result i j n)))))
 536
 537       (encode 0 0 0))))
 538
 539 ;==============================================================================
 540
 541 ; x-www-form-urlencoded encoding and decoding.
 542
 543 (define encode-x-www-form-urlencoded
 544   (lambda (fields)
 545
 546     (define write-urlencoded
 547       (lambda (str)
 548
 549         (define write-nibble
 550           (lambda (n)
 551             (write-char (string-ref "0123456789ABCDEF" n))))
 552
 553         (let loop ((i 0))
 554           (if (< i (string-length str))
 555               (let ((c (string-ref str i)))
 556                 (cond ((or (and (char>=? c #\a) (char<=? c #\z))
 557                            (and (char>=? c #\A) (char<=? c #\Z))
 558                            (and (char>=? c #\0) (char<=? c #\9)))
 559                        (write-char c))
 560                       ((char=? c #\space)
 561                        (write-char #\+))
 562                       (else
 563                        (let ((n (char->integer c)))
 564                          (write-char #\%)
 565                          (write-nibble
 566                           (bitwise-and (arithmetic-shift n -4) 15))
 567                          (write-nibble (bitwise-and n 15)))))
 568                 (loop (+ i 1)))))))
 569
 570     (define write-field
 571       (lambda (field)
 572         (write-urlencoded (car field))
 573         (write-char #\=)
 574         (write-urlencoded (cdr field))))
 575
 576     (if (null? fields)
 577         ""
 578         (with-output-to-string
 579           ""
 580           (lambda ()
 581             (let ((field1 (car fields)))
 582               (write-field field1)
 583               (for-each (lambda (field)
 584                           (write-char #\&)
 585                           (write-field field))
 586                         (cdr fields))))))))
 587
 588 (define decode-x-www-form-urlencoded
 589   (lambda (str)
 590     (let ((n (string-length str)))
 591
 592       (define extract
 593         (lambda (start len)
 594           (let ((s (make-string len)))
 595             (let loop ((i start) (j 0))
 596               (if (< j len)
 597                   (let ((c (string-ref str i)))
 598                     (cond ((char=? c #\%)
 599                            (cond ((hex (+ i 1))
 600                                   =>
 601                                   (lambda (x)
 602                                     (string-set! s j (integer->char x))
 603                                     (loop (+ i 3) (+ j 1))))
 604                                  (else
 605                                   #f)))
 606                           ((char=? c #\+)
 607                            (string-set! s j #\space)
 608                            (loop (+ i 1) (+ j 1)))
 609                           (else
 610                            (string-set! s j c)
 611                            (loop (+ i 1) (+ j 1)))))
 612                   s)))))
 613
 614       (define hex
 615         (lambda (i)
 616           (if (< (+ i 1) n)
 617               (let ((h1 (nibble i))
 618                     (h2 (nibble (+ i 1))))
 619                 (and h1 h2 (+ (* h1 16) h2)))
 620               #f)))
 621
 622       (define nibble
 623         (lambda (i)
 624           (let ((c (string-ref str i)))
 625             (cond ((and (char>=? c #\0) (char<=? c #\9))
 626                    (- (char->integer c) (char->integer #\0)))
 627                   ((and (char>=? c #\a) (char<=? c #\f))
 628                    (+ 10 (- (char->integer c) (char->integer #\a))))
 629                   ((and (char>=? c #\A) (char<=? c #\F))
 630                    (+ 10 (- (char->integer c) (char->integer #\A))))
 631                   (else
 632                    #f)))))
 633
 634       (define state0 ; at beginning of string
 635         (lambda (i rev-fields)
 636           (if (< i n)
 637               (state1 i
 638                       i
 639                       0
 640                       rev-fields)
 641               (reverse rev-fields))))
 642
 643       (define state1 ; in field name
 644         (lambda (i start len rev-fields)
 645           (if (< i n)
 646               (let ((c (string-ref str i)))
 647                 (cond ((char=? c #\=)
 648                        (state2 (+ i 1)
 649                                (+ i 1)
 650                                0
 651                                (extract start len)
 652                                rev-fields))
 653                       ((char=? c #\%)
 654                        (and (hex (+ i 1))
 655                             (state1 (+ i 3)
 656                                     start
 657                                     (+ len 1)
 658                                     rev-fields)))
 659                       (else
 660                        (state1 (+ i 1)
 661                                start
 662                                (+ len 1)
 663                                rev-fields))))
 664               #f)))
 665
 666       (define state2 ; in field value
 667         (lambda (i start len name rev-fields)
 668
 669           (define end-of-field
 670             (lambda ()
 671               (cons (cons name (extract start len))
 672                     rev-fields)))
 673
 674           (if (< i n)
 675               (let ((c (string-ref str i)))
 676                 (cond ((char=? c #\&)
 677                        (state1 (+ i 1)
 678                                (+ i 1)
 679                                0
 680                                (end-of-field)))
 681                       ((char=? c #\%)
 682                        (and (hex (+ i 1))
 683                             (state2 (+ i 3)
 684                                     start
 685                                     (+ len 1)
 686                                     name
 687                                     rev-fields)))
 688                       (else
 689                        (state2 (+ i 1)
 690                                start
 691                                (+ len 1)
 692                                name
 693                                rev-fields))))
 694               (reverse (end-of-field)))))
 695
 696       (state0 0 '()))))
 697
 698 ;==============================================================================
 699
 700 ; HTTP server.
 701
 702 (define-type server
 703   id: c69165bd-c13f-11d9-830f-00039301ba52
 704
 705   port-number
 706   timeout
 707   threaded?
 708   method-table
 709 )
 710
 711 (define-type request
 712   id: 8e66862f-c143-11d9-9f4e-00039301ba52
 713
 714   (server unprintable:)
 715   connection
 716   method
 717   uri
 718   version
 719   attributes
 720   query
 721 )
 722
 723 (define make-http-server
 724   (lambda (#!key
 725            (port-number 80)
 726            (timeout     300)
 727            (threaded?   #f)
 728            (OPTIONS     unimplemented-method)
 729            (GET         unimplemented-method)
 730            (HEAD        unimplemented-method)
 731            (POST        unimplemented-method)
 732            (PUT         unimplemented-method)
 733            (DELETE      unimplemented-method)
 734            (TRACE       unimplemented-method)
 735            (CONNECT     unimplemented-method))
 736     (make-server
 737      port-number
 738      timeout
 739      threaded?
 740      (make-token-table
 741       ("OPTIONS" OPTIONS)
 742       ("GET"     GET)
 743       ("HEAD"    HEAD)
 744       ("POST"    POST)
 745       ("PUT"     PUT)
 746       ("DELETE"  DELETE)
 747       ("TRACE"   TRACE)
 748       ("CONNECT" CONNECT)))))
 749
 750 (define http-server-start!
 751   (lambda (hs)
 752     (let ((server-port
 753            (open-tcp-server
 754             (list server-address: '#u8(127 0 0 1) ; on localhost interface only
 755                   port-number: (server-port-number hs)
 756                   backlog: 128
 757                   reuse-address: #t
 758                   char-encoding: 'ISO-8859-1))))
 759       (accept-connections hs server-port))))
 760
 761 (define accept-connections
 762   (lambda (hs server-port)
 763     (let loop ()
 764       (let ((connection
 765              (read server-port)))
 766         (if (server-threaded? hs)
 767             (let ((dummy-port (open-dummy)))
 768               (parameterize ((current-input-port dummy-port)
 769                              (current-output-port dummy-port))
 770                 (thread-start!
 771                  (make-thread
 772                   (lambda ()
 773                     (serve-connection hs connection))))))
 774             (serve-connection hs connection)))
 775       (loop))))
 776
 777 (define send-error
 778   (lambda (connection html)
 779     (write-html html connection)
 780     (close-port connection)))
 781
 782 (define method-not-implemented-error
 783   (lambda (connection)
 784     (send-error
 785      connection
 786      (<html> (<head> (<title> "501 Method Not Implemented"))
 787              (<body>
 788               (<h1> "Method Not Implemented"))))))
 789
 790 (define unimplemented-method
 791   (lambda ()
 792     (let* ((request (current-request))
 793            (connection (request-connection request)))
 794       (method-not-implemented-error connection))))
 795
 796 (define bad-request-error
 797   (lambda (connection)
 798     (send-error
 799      connection
 800      (<html> (<head> (<title> "400 Bad Request"))
 801              (<body>
 802               (<h1> "Bad Request")
 803               (<p> "Your browser sent a request that this server could "
 804                    "not understand."
 805                    (<br>)))))))
 806
 807 (define reply
 808   (lambda (thunk)
 809     (let* ((request
 810             (current-request))
 811            (connection
 812             (request-connection request))
 813            (version
 814             (request-version request)))
 815
 816       (define generate-reply
 817         (lambda (port)
 818           (if (or (eq? version 'HTTP/1.0)
 819                   (eq? version 'HTTP/1.1))
 820               (let ((message
 821                      (with-output-to-u8vector
 822                       '(char-encoding: ISO-8859-1
 823                         eol-encoding: cr-lf)
 824                       thunk))
 825                     (eol
 826                      "\r\n"))
 827                 (print
 828                  (list version " 200 OK" eol
 829                        "Content-Length: " (u8vector-length message) eol
 830                        "Content-Type: text/html; charset=ISO-8859-1" eol
 831                        "Connection: close" eol
 832                        eol)
 833                  port)
 834                 (write-subu8vector
 835                  message
 836                  0
 837                  (u8vector-length message)
 838                  port))
 839               (with-output-to-port port thunk))))
 840
 841       (define debug? #f)
 842
 843       (if (not debug?)
 844           (generate-reply connection)
 845           (let ((output
 846                  (call-with-output-u8vector
 847                   '#u8()
 848                   (lambda (port) (generate-reply port)))))
 849             (write-subu8vector output 0 (u8vector-length output) ##stdout-port)
 850             (force-output ##stdout-port)
 851             (write-subu8vector output 0 (u8vector-length output) connection)))
 852
 853       (close-port connection))))
 854
 855 (define reply-html
 856   (lambda (html)
 857     (reply (lambda () (write-html html)))))
 858
 859 (define current-request
 860   (lambda ()
 861     (thread-specific (current-thread)))) ; request is stored in thread
 862
 863 ;------------------------------------------------------------------------------
 864
 865 (define serve-connection
 866   (lambda (hs connection)
 867
 868     ; Configure the connection with the client so that if we can't
 869     ; read the request after 300 seconds, the read operation will fail
 870     ; (and the thread will terminate).
 871
 872     (input-port-timeout-set! connection 300)
 873
 874     ; Configure the connection with the client so that if we can't
 875     ; write the response after 300 seconds, the write operation will
 876     ; fail (and the thread will terminate).
 877
 878     (output-port-timeout-set! connection 300)
 879
 880     (let ((req (permissive-read-line connection)))
 881       (if (not (string? req))
 882           (bad-request-error connection)
 883           (let* ((end
 884                   (let loop ((i 0))
 885                     (cond ((= i (string-length req))
 886                            #f)
 887                           ((char=? (string-ref req i) #\space)
 888                            i)
 889                           (else
 890                            (loop (+ i 1))))))
 891                  (method-index
 892                   (and end
 893                        (token-table-lookup-substring
 894                         (server-method-table hs)
 895                         req
 896                         0
 897                         end))))
 898             (if method-index
 899
 900                 (parse-uri
 901                  req
 902                  (+ end 1)
 903                  (string-length req)
 904                  #t
 905                  (lambda (uri i)
 906
 907                    (define handle-version
 908                      (lambda (version)
 909                        (case version
 910                          ((HTTP/1.0 HTTP/1.1)
 911                           (let ((attributes (read-header connection)))
 912                             (if attributes
 913                                 (handle-request version attributes)
 914                                 (bad-request-error connection))))
 915                          ((#f)
 916                           ; this is an HTTP/0.9 request
 917                           (handle-request 'HTTP/0.9 '()))
 918                          (else
 919                           (bad-request-error connection)))))
 920
 921                    (define handle-request
 922                      (lambda (version attributes)
 923                        (let* ((method-table
 924                                (server-method-table hs))
 925                               (method-name
 926                                (vector-ref method-table method-index))
 927                               (method-action
 928                                (vector-ref method-table (+ method-index 1)))
 929                               (content
 930                                (read-content connection attributes))
 931                               (query
 932                                (let ((x (assoc "Content-Type" attributes)))
 933                                  (if (and x
 934                                           (string=?
 935                                            (cdr x)
 936                                            "application/x-www-form-urlencoded"))
 937                                      (decode-x-www-form-urlencoded content)
 938                                      (uri-query uri)))))
 939                          (let ((request
 940                                 (make-request
 941                                  hs
 942                                  connection
 943                                  method-name
 944                                  uri
 945                                  version
 946                                  attributes
 947                                  query)))
 948                            (thread-specific-set! (current-thread) request))
 949                          (method-action))))
 950
 951                    (cond ((not uri)
 952                           (bad-request-error connection))
 953                          ((not (< i (string-length req)))
 954                           (handle-version #f))
 955                          ((not (char=? (string-ref req i) #\space))
 956                           (bad-request-error connection))
 957                          (else
 958                           (let ((version-index
 959                                  (token-table-lookup-substring
 960                                   version-table
 961                                   req
 962                                   (+ i 1)
 963                                   (string-length req))))
 964                             (if version-index
 965                                 (handle-version
 966                                  (vector-ref version-table
 967                                              (+ version-index 1)))
 968                                 (bad-request-error connection)))))))
 969
 970                 (method-not-implemented-error connection)))))))
 971
 972 (define version-table
 973   (make-token-table
 974    ("HTTP/1.0" 'HTTP/1.0)
 975    ("HTTP/1.1" 'HTTP/1.1)))
 976
 977 (define read-header
 978   (lambda (connection)
 979     (let loop ((attributes '()))
 980       (let ((line (permissive-read-line connection)))
 981         (cond ((not line)
 982                #f)
 983               ((= (string-length line) 0)
 984                attributes)
 985               (else
 986                (let ((attribute (split-attribute-line line)))
 987                  (if attribute
 988                      (loop (cons attribute attributes))
 989                      #f))))))))
 990
 991 (define read-content
 992   (lambda (connection attributes)
 993     (let ((cl
 994            (cond ((assoc "Content-Length" attributes)
 995                   =>
 996                   (lambda (x)
 997                     (let ((n (string->number (cdr x))))
 998                       (and n (integer? n) (exact? n) n))))
 999                  (else
1000                   #f))))
1001       (if cl
1002           (let ((str (make-string cl)))
1003             (let ((n (read-substring str 0 cl connection)))
1004               (if (= n cl)
1005                   str
1006                   "")))
1007           ""))))
1008
1009 (define permissive-read-line
1010   (lambda (port)
1011     (let ((s (read-line port)))
1012       (if (and (string? s)
1013                (> (string-length s) 0)
1014                (char=? (string-ref s (- (string-length s) 1)) #\return))
1015           ; efficient version of (substring s 0 (- (string-length s) 1))
1016           (begin (##string-shrink! s (- (string-length s) 1)) s)
1017           s))))
1018
1019 (define find-char-pos
1020   (lambda (str char)
1021     (let loop ((i 0))
1022       (if (< i (string-length str))
1023           (if (char=? char (string-ref str i))
1024               i
1025               (loop (+ i 1)))
1026           #f))))
1027
1028 (define split-attribute-line
1029   (lambda (line)
1030     (let ((pos (find-char-pos line #\:)))
1031       (and pos
1032            (< (+ pos 1) (string-length line))
1033            (char=? #\space (string-ref line (+ pos 1)))
1034            (cons (substring line 0 pos)
1035                  (substring line (+ pos 2) (string-length line)))))))
1036
1037 ;==============================================================================