Re: lightweight languages

[Shriram Krishnamurthi <address@hidden>]

Dan Weinreb wrote:

> In all fairness, all the Scheme code I have actually read had been
> code written for expository purposes, such as code in textbooks and
> academic papers.  I have not read the source code of an HTTP server
> written in Scheme.

Fair enough.  I could post an "academic" server, but I'd rather post
the dirtier code of the one we actually use.  The whole thing is just
under 900 lines, and handles various junk -- parsing form submissions
(using regexps), dealing with multi-part MIME, providing MIME headers,
tackling our notion of CGI scripts (which are memory-resident
modules), offering continuation-based interaction support, converting
from seconds into GMT strings, managing authentication, reading
configurations, etc.  All that code is in the distribution, and I've
happy to mail the file to anyone who cares.  But here's an
illustrative sample.

----------------------------------------------------------------------
; serve : [Nat] [String -> host] [Nat] -> -> Void
; to start the server on the given port and return an un-server to shut it down
; max-waiting is the maximum number of clients waiting for the acceptance of their connection.
(define serve
  ; use default values from configuration.ss by default
  (opt-lambda ([port port]
               [virtual-hosts virtual-hosts]
               [max-waiting max-waiting])
    (let ([custodian (make-custodian)])
      (parameterize ([current-custodian custodian])
        (let ([listener (tcp-listen port max-waiting)])
          ; If tcp-listen fails, the exception will be raised in the caller's thread.
          (thread (lambda ()
                    (server-loop custodian listener
                                 (make-config virtual-hosts (make-hash-table)
                                              (make-hash-table) (make-hash-table)))))))
      (lambda () (custodian-shutdown-all custodian)))))

; The Server Loop

(define METHOD:REGEXP
  (regexp "^(GET|HEAD|POST|PUT|DELETE|TRACE) (.+) HTTP/([0-9]+)\\.([0-9]+)$"))

; match-method : str -> (union false (list str str str str str))
(define (match-method x)
  (regexp-match METHOD:REGEXP x))

; server-loop : custodian tcp-listener config -> void
(define (server-loop top-custodian listener tables)
  (let bigger-loop ()
    (with-handlers ([void (lambda (exn) (bigger-loop))])
      (let loop ()
        (let ([connection-cust (make-custodian)])
          (parameterize ([current-custodian connection-cust])
            (let-values ([(ip op) (tcp-accept listener)]
                         [(shutdown) (lambda () (custodian-shutdown-all connection-cust))])
              (thread (lambda ()
                        (finally (lambda ()
                                   (serve-connection top-custodian ip op tables
                                                     (start-timer INITIAL-CONNECTION-TIMEOUT shutdown)))
                                 shutdown))))))
        (loop)))))

; serve-connection : custodian iport oport Tables timer -> Void
; to respond to all the requests on an http connection 
; (Currently only the first request is answered.)
(define (serve-connection top-custodian ip op tables timer)
  (let connection-loop ()
    (let-values ([(method uri-string major-version minor-version) (read-request ip op)])
      (let* ([headers (read-headers ip)]
             [uri     (string->url uri-string)]
             [host    (get-host uri headers)]
             [host-conf ((config-hosts tables) host)])
        ; more here - don't extract host-ip and client-ip twice (leakage)
        (let-values ([(host-ip client-ip) (tcp-addresses ip)])
          (display (format-log-message host-ip client-ip method uri host) (host-log host-conf)))
        (dispatch top-custodian method host-conf uri headers ip op tables timer)
        (reset-timer timer INITIAL-CONNECTION-TIMEOUT)
        (unless (close-connection? headers (string->number major-version) (string->number minor-version))
          (connection-loop))))))
----------------------------------------------------------------------

You might wonder what a "custodian" is.  A more thorough description
is in a paper, but basically these are language-based resource
managers; if you care, see

  http://www.cs.rice.edu/CS/PLT/Publications/#icfp99-ffkf
  ICFP 99 Flatt, Findler, Krishnamurthi and Felleisen
  Programming Languages as Operating Systems 
    (or, Revenge of the Son of the Lisp Machine)

Shriram