diff --git a/lib/chibi/net/http-server.scm b/lib/chibi/net/http-server.scm
new file mode 100644
index 00000000..02a9790d
--- /dev/null
+++ b/lib/chibi/net/http-server.scm
@@ -0,0 +1,511 @@
+;; http-server.scm -- combinator-based http server
+;; Copyright (c) 2013-2014 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Runs an http server listening at the given address, with the given
+;;> servlet.
+;;>
+;;> An servlet is a procedure which takes three arguments: an
+;;> \scheme{Http-Request} record, which contains the I/O ports and
+;;> parsed request and headers; a \scheme{next} procedure to call the
+;;> next available servlet if any, and a \scheme{restart} procedure to
+;;> restart the servlets with a new request.
+
+(define (run-http-server listener-or-addr servlet . o)
+ (let ((cfg (if (pair? o) (car o) (make-conf '() #f #f #f))))
+ (run-net-server
+ listener-or-addr
+ (command-handler
+ (lambda (command ls in out sock addr)
+ (cond
+ ((= 2 (length ls))
+ (let ((request
+ (make-request command (car ls) (cadr ls) in out sock addr)))
+ (log-info `(request: ,command ,(car ls) ,(cadr ls)
+ ,(request-headers request)))
+ (let restart ((request request))
+ (servlet cfg request servlet-bad-request restart))))
+ (else
+ (let ((request (make-request command #f #f in out sock addr)))
+ (servlet-respond request 400 "bad request")))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Servlets.
+
+(define (http-chain-servlets f . o)
+ (let lp ((f f) (ls o))
+ (if (pair? ls)
+ (let ((g (lp (car ls) (cdr ls))))
+ (lambda (cfg request next restart)
+ (let ((next2 (lambda (cfg request) (g cfg request next restart))))
+ (f cfg request next2 restart))))
+ f)))
+
+(define (http-wrap-default servlet)
+ (http-chain-servlets servlet http-default-servlet))
+
+(define (http-guard-servlet cfg request next restart)
+ (let ((orig-out (request-out request))
+ (tmp-out (open-output-string))
+ (request2 (copy-request request)))
+ (request-out-set! request2 tmp-out)
+ (protect (exn (else (servlet-respond request 500 "Interal server error")))
+ (next cfg request2)
+ (display (get-output-string tmp-out) orig-out))))
+
+(define (http-parse-body-servlet cfg request next restart)
+ (let ((request2 (copy-request request)))
+ (servlet-parse-body! request2)
+ (next cfg request2)))
+
+(define (http-get*-servlet proc)
+ (lambda (cfg request next restart)
+ (if (memq (request-method request) '(GET POST))
+ (proc cfg request next restart)
+ (next cfg request))))
+
+;; Generate a simple page listing the linked files in a directory.
+(define (send-directory path out)
+ (display "\n" out)
+ (for-each
+ (lambda (file)
+ (display "" out)
+ (display file out)
+ (display "\n" out))
+ (sort (directory-files path)))
+ (display "
\n" out))
+
+;; TODO: If the index-rx is a short list of fixed strings, check
+;; individually to avoid the full directory lookup.
+(define (find-index-file dir index-rx)
+ (and index-rx
+ (any (lambda (f) (and (regexp-matches? index-rx f) (make-path dir f)))
+ (directory-files dir))))
+
+(define (http-send-directory request path index-rx restart)
+ (cond
+ ((find-index-file path index-rx)
+ => (lambda (index-file)
+ ;; Generate and restart a new request with explicit index file.
+ (let* ((uri (request-uri request))
+ (path2 (make-path (uri-path uri) index-file)))
+ (restart
+ (request-with-uri request (uri-with-path uri path2))))))
+ (else
+ (send-directory path (request-out request)))))
+
+(define (http-send-file request path)
+ (cond
+ ((file-exists? path)
+ (servlet-respond request 200 "OK")
+ (send-file path (request-out request)))
+ (else
+ (servlet-respond request 404 "Not Found"))))
+
+(define (http-file-servlet . o)
+ (let ((dir (if (pair? o) (car o) "."))
+ (index-rx (and (pair? o) (pair? (cdr o)) (cadr o))))
+ (http-get*-servlet
+ (lambda (cfg request next restart)
+ (let ((path (make-path dir (request-path request))))
+ (if (file-directory? path)
+ (http-send-directory request path index-rx restart)
+ (http-send-file request path)))))))
+
+(define (http-procedure-servlet path proc)
+ (http-get*-servlet
+ (lambda (cfg request next restart)
+ (cond
+ ((equal? path (path-normalize (request-path request)))
+ (servlet-respond request 200 "OK")
+ (proc request))
+ (else
+ (next cfg request))))))
+
+(define (http-regexp-servlet rules get-field)
+ (lambda (cfg request next restart)
+ (let ((str (get-field request)))
+ (let lp ((request request) (ls rules))
+ (cond
+ ((null? ls)
+ (next cfg request))
+ ((not (valid-sre? (caar ls)))
+ (log-warn "invalid sre: " (caar ls))
+ (lp request (cdr ls)))
+ ((regexp-matches? (caar ls) str)
+ => (lambda (m)
+ (let ((next (lambda (cfg request) (lp request (cdr ls)))))
+ ((cdar ls) cfg request next restart))))
+ (else
+ (lp request (cdr ls))))))))
+
+(define (http-uri-regexp-servlet rules)
+ (http-regexp-servlet rules request-uri-string))
+
+(define (http-path-regexp-servlet rules)
+ (http-regexp-servlet
+ rules
+ (lambda (request) (uri-path (request-uri request)))))
+
+(define (http-host-regexp-servlet rules)
+ (http-regexp-servlet rules request-host))
+
+(define (http-regexp-replace-servlet rules helper)
+ (lambda (cfg request next restart)
+ (let ((uri (uri->string (request-uri request))))
+ (let lp ((ls rules))
+ (if (null? ls)
+ (next cfg request)
+ (let ((uri2 (regexp-replace (caar ls) uri (cdar ls))))
+ (cond
+ ((equal? uri uri2)
+ (lp (cdr ls)))
+ ((string->path-uri uri2)
+ => (lambda (uri)
+ (helper (request-with-uri request uri) next restart)))
+ (else
+ (log-warn "invalid rewritten uri: " uri2)
+ (lp (cdr ls))))))))))
+
+(define (http-redirect-servlet rules)
+ (http-regexp-replace-servlet
+ rules
+ (lambda (cfg request next restart)
+ (let ((headers `(Location . ,(uri->string (request-uri request)))))
+ (servlet-respond request 302 "Found" headers)))))
+
+(define (http-rewrite-servlet rules)
+ (http-regexp-replace-servlet
+ rules
+ (lambda (cfg request next restart) (restart request))))
+
+(define (index-path-map-servlet from to index-rx servlet)
+ (http-get*-servlet
+ (lambda (cfg request next restart)
+ (let* ((path (path-normalize (uri-path (request-uri request))))
+ (rel-path (path-relative-to path from)))
+ (cond
+ (rel-path
+ (let* ((local-path (make-path to rel-path))
+ (local-path
+ (if (and index-rx (file-directory? local-path))
+ (find-index-file local-path index-rx)
+ local-path)))
+ (if (file-exists? local-path)
+ (servlet cfg request local-path next restart)
+ (servlet-respond request 404 "Not found"))))
+ (else
+ (next cfg request)))))))
+
+(define (path-map-servlet from to servlet)
+ (index-path-map-servlet from to #f servlet))
+
+(define (http-cgi-bin-servlet request local-path next restart)
+ (call-with-temp-file "cgi.out"
+ (lambda (temp-file out)
+ (let ((pid (fork)))
+ (cond
+ ((zero? pid)
+ (duplicate-file-descriptor-to
+ (port-fileno (request-in request)) 0)
+ (duplicate-file-descriptor-to (port-fileno out) 1)
+ (setenv "HTTP_HOST" (request-host request))
+ (setenv "REQUEST_URI" (uri->string (request-uri request)))
+ (setenv "REQUEST_METHOD"
+ (symbol->string (request-method request)))
+ (setenv "QUERY_STRING"
+ (or (uri-query (request-uri request)) ""))
+ (let ((res (execute local-path (list local-path))))
+ (display "failed to execute program: " (current-error-port))
+ (write local-path (current-error-port))
+ (display " => " (current-error-port))
+ (write res (current-error-port))
+ (newline (current-error-port))
+ (exit 1)))
+ (else
+ (let ((status (waitpid pid 0)))
+ (cond
+ ((negative? (car status))
+ (servlet-respond request 500 "Internal server error"))
+ (else
+ (display "HTTP/1.1 200 OK\r\n" (request-out request))
+ (flush-output (request-out request))
+ (send-file temp-file (request-out request))
+ (close-output-port out))))))))))
+
+(define (http-cgi-bin-dir-servlet local-dir . o)
+ (let ((virtual-dir (if (pair? o) (car o) "/cgi-bin")))
+ (path-map-servlet
+ virtual-dir local-dir
+ (lambda (cfg request prog-path next restart)
+ (http-cgi-bin-servlet request prog-path next restart)))))
+
+(define (with-add-to-load-path dir thunk)
+ (if dir
+ (let* ((orig-path (current-module-path))
+ (new-path (cons dir (current-module-path))))
+ (dynamic-wind (lambda () (current-module-path new-path))
+ thunk
+ (lambda () (current-module-path orig-path))))
+ (thunk)))
+
+(define (make-import-environment)
+ (let ((env (make-environment)))
+ (%import env (current-environment) '(import) #t)
+ env))
+
+(define (load-scheme-script path . o)
+ (if (and (file-exists? path) (not (file-directory? path)))
+ (let ((env (make-import-environment))
+ (handle #f))
+ (protect (exn (else
+ (log-error "failed to load servlet " exn)))
+ (let ((e1 (call-with-input-file path read)))
+ (cond
+ ((not (and (pair? e1) (eq? 'import (car e1))))
+ (log-error "not a scheme program (no import): " path))
+ (else
+ (parameterize ((servlet-handler (lambda (h) (set! handle h))))
+ (with-add-to-load-path (and (pair? o) (car o))
+ (lambda () (load path env))))))))
+ (cond ((not (procedure? handle))
+ (log-error "no servlet defined in " path)
+ (lambda (cfg request next restart)
+ (servlet-respond request 500 "Internal server error")))
+ (else handle)))
+ (lambda (cfg request next restart)
+ (servlet-respond request 404 "Not found"))))
+
+(define load-scheme-script/memoized
+ (memoize-file-loader load-scheme-script))
+
+(define (http-scheme-script-dir-servlet local-dir . o)
+ (let ((virtual-dir (or (and (pair? o) (car o)) "/"))
+ (index-rx (and (pair? o) (pair? (cdr o)) (cadr o))))
+ (index-path-map-servlet
+ virtual-dir local-dir index-rx
+ (lambda (cfg request script-path next restart)
+ (let ((servlet (load-scheme-script/memoized script-path local-dir)))
+ (protect (exn
+ (else
+ (servlet-respond request 500 "Internal server error")))
+ (servlet cfg request next restart)))))))
+
+(define (http-scheme-script-ext-servlet cfg request local-path next restart)
+ ((load-scheme-script/memoized local-path) cfg request next restart))
+
+(define (get-ext-servlet x file)
+ (if (procedure? x)
+ x
+ (case x
+ ((scheme) http-scheme-script-ext-servlet)
+ ((cgi) http-cgi-bin-servlet)
+ (else (error "unknown ext servlet" x)))))
+
+(define (http-ext-servlet rules local-dir . o)
+ (let ((virtual-dir (if (pair? o) (car o) "/")))
+ (path-map-servlet
+ virtual-dir local-dir
+ (lambda (cfg request local-path next restart)
+ (cond
+ ((assoc (path-extension local-path) rules)
+ => (lambda (cell)
+ (let ((name (if (pair? (cdr cell)) (cadr cell) (cdr cell))))
+ ((get-ext-servlet name local-path) cfg request local-path next restart))))
+ (else
+ (next cfg request)))))))
+
+(define (http-default-servlet cfg request next restart)
+ (case (request-method request)
+ ((HEAD)
+ (call-with-temp-file "get.out"
+ (lambda (temp-file out)
+ (let ((request2 (copy-request request)))
+ (request-method-set! request2 'GET)
+ (request-out-set! request2 out)
+ (restart request2)
+ (close-output-port out)
+ (call-with-input-file temp-file
+ (lambda (in)
+ (let* ((status (read-line in))
+ (headers (mime-headers->list in))
+ (out (request-out request)))
+ (display status out)
+ (display "\r\n" out)
+ (mime-write-headers headers out)
+ (display "\r\n" out))))))))
+ ((BREW)
+ (servlet-respond request 418 "I'm a teapot"))
+ (else
+ (servlet-bad-request cfg request next restart))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Config-based servlets.
+
+;; Utility to wrap SRE rules.
+(define (http-wrap-sre-config cfg clear ls)
+ (map
+ (lambda (x)
+ (cond
+ ((valid-sre? (car x))
+ `(,(regexp (car x))
+ . ,(http-config-servlet
+ (make-conf (cdr x) (make-conf `((,clear)) cfg #f #f) #f #f))))
+ (else
+ (log-error "invalid sre in config: " (car x))
+ `(,(regexp '(+ (~ any)))
+ . ,(lambda (request) (error "unreachable servlet"))))))
+ ls))
+
+;; Utility to wrap servlets which take a local path as the first arg.
+(define (http-wrap-doc-root f)
+ (lambda (args cfg)
+ (let* ((root (conf-get cfg 'doc-root "."))
+ (local-dir (if (pair? args) (car args) "/"))
+ (virtual-dir (if (and (pair? args) (pair? (cdr args)))
+ (cadr args)
+ (make-path "/" local-dir)))
+ (args (append (list (make-path root local-dir) virtual-dir)
+ (if (and (pair? args) (pair? (cdr args)))
+ (cddr args)
+ '()))))
+ (f args cfg))))
+
+(define (http-config-file-servlet cfg . o)
+ (let* ((root (conf-get cfg 'doc-root "."))
+ (dir (make-path root (if (pair? o) (car o) ".")))
+ (index-rx (if (and (pair? o) (pair? (cdr o)))
+ (cadr o)
+ (conf-get cfg 'index-regexp "index.html"))))
+ (http-file-servlet dir index-rx)))
+
+;; Ordered list of servlets to try for a given config. Generally
+;; gives the intuitive order, but manual ordering can be imposed with
+;; regexp rules.
+(define ordered-config-servlets
+ `((redirect . ,(lambda (rules cfg) (http-redirect-servlet rules)))
+ (rewrite . ,(lambda (rules cfg) (http-rewrite-servlet rules)))
+ (host . ,(lambda (hosts cfg)
+ (http-host-regexp-servlet
+ (http-wrap-sre-config cfg 'host hosts))))
+ (uri . ,(lambda (rules cfg)
+ (http-uri-regexp-servlet
+ (http-wrap-sre-config cfg 'uri rules))))
+ (path . ,(lambda (rules cfg)
+ (http-path-regexp-servlet
+ (http-wrap-sre-config cfg 'path rules))))
+ (file . ,(lambda (x cfg)
+ (apply http-config-file-servlet cfg x)))
+ (cgi . ,(http-wrap-doc-root
+ (lambda (dirs cfg) (apply http-cgi-bin-dir-servlet dirs))))
+ (scheme . ,(http-wrap-doc-root
+ (lambda (dirs cfg)
+ (let ((local-dir (car dirs))
+ (virtual-dir (cadr dirs))
+ (index-rx (conf-get cfg 'index-regexp "index.scm")))
+ (http-scheme-script-dir-servlet
+ local-dir virtual-dir index-rx)))))
+ (ext . ,(lambda (rules cfg)
+ (http-ext-servlet rules (conf-get cfg 'doc-root "."))))
+ ))
+
+;; Config servlet for an already constructed config.
+(define (http-config-conf-servlet cfg . o)
+ (http-chain-servlets
+ (lambda (orig-cfg request next restart)
+ (next cfg request))
+ (let lp ((ls ordered-config-servlets))
+ (cond
+ ((null? ls)
+ (if (pair? o)
+ (http-chain-servlets (car o) http-default-servlet)
+ http-default-servlet))
+ ((conf-get-cdr cfg (caar ls))
+ => (lambda (x)
+ (let ((rest (lp (cdr ls))))
+ (if (or (pair? x) (null? x))
+ (http-chain-servlets ((cdar ls) x cfg) rest)
+ rest))))
+ (else
+ (lp (cdr ls)))))))
+
+;; Config servlet to load a config from a file.
+(define (http-config-servlet-load file . o)
+ (let* ((cfg (conf-load file))
+ (cfg (if (and (pair? o) (conf? (car o)))
+ (if (and (pair? (cdr o)) (conf? (cadr o)))
+ (conf-append (car o) (conf-append cfg (cadr o)))
+ (conf-append (car o) cfg))
+ cfg)))
+ (http-config-conf-servlet cfg (http-config-file-servlet cfg))))
+
+;; Primary config servlet which dispatches on argument type.
+(define (http-config-servlet x)
+ (cond
+ ((procedure? x)
+ x)
+ ((list? x)
+ (http-config-conf-servlet (make-conf x #f #f (current-second))))
+ ((string? x)
+ (if (file-directory? x)
+ (http-file-servlet x)
+ (http-config-servlet (make-conf #f #f x -1))))
+ ((not (conf? x))
+ (error "unknown type for http-config-servlet" x))
+ ((and (string? (conf-source x))
+ (file-exists? (conf-source x)))
+ (let* ((f (conf-source x))
+ (mtime (file-modification-time f)))
+ ((memoize-file-loader
+ (lambda (f) (http-config-servlet-load f #f (conf-parent x)))
+ 'reloader?: #true
+ 'cache: `(((,mtime . ,f) . ,x)))
+ f)))
+ ((and (conf-parent x)
+ (string? (conf-source (conf-parent x)))
+ (file-exists? (conf-source (conf-parent x))))
+ (let* ((f (conf-source (conf-parent x)))
+ (mtime (file-modification-time f)))
+ ((memoize-file-loader
+ (lambda (f) (http-config-servlet-load f (conf-head x) (conf-parent x)))
+ 'reloader?: #true
+ 'cache: `(((,mtime . ,f) . ,x)))
+ f)))
+ (else
+ (http-config-conf-servlet x))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sample main. In chibi-scheme you can run:
+;;
+;; chibi-scheme -Rchibi.net.http-config-server -- []
+;;
+;; which defaults to serving the current directory on port 8000.
+
+(define (run-app cfg spec . args)
+ (define (run cfg servlet)
+ (run-http-server (conf-get cfg 'port 8000) servlet cfg))
+ (cond
+ ((> (length args) 1)
+ (error "usage: httpd []"))
+ ((or (null? args) (file-directory? (car args)))
+ (let ((dir (if (null? args) "." (car args))))
+ (run cfg (http-wrap-default (http-config-file-servlet cfg dir)))))
+ (else
+ (let* ((cfg-file (car args))
+ (last-cfg
+ (make-conf `((doc-root . ,(path-directory cfg-file))) #f #f #f))
+ (cfg (conf-append cfg (conf-append (conf-load cfg-file) last-cfg))))
+ (run cfg (http-config-servlet cfg))))))
+
+(define app-spec
+ `(http-config-server
+ "Config-based HTTP server"
+ (@
+ ((port integer)
+ (doc-root string)
+ (verbose? boolean (#\v "verbose"))))
+ ,run-app))
+
+(define (main args) (run-application app-spec args))
diff --git a/lib/chibi/net/http-server.sld b/lib/chibi/net/http-server.sld
new file mode 100644
index 00000000..f917907a
--- /dev/null
+++ b/lib/chibi/net/http-server.sld
@@ -0,0 +1,17 @@
+
+(define-library (chibi net http-server)
+ (export
+ ;; main interface
+ run-http-server
+ ;; basic servlets
+ http-chain-servlets http-default-servlet http-wrap-default
+ http-file-servlet http-procedure-servlet http-ext-servlet
+ http-regexp-servlet http-path-regexp-servlet http-uri-regexp-servlet
+ http-host-regexp-servlet http-redirect-servlet http-rewrite-servlet
+ http-cgi-bin-dir-servlet http-scheme-script-dir-servlet)
+ (import (scheme time) (srfi 39) (srfi 95)
+ (chibi) (chibi mime) (chibi regexp) (chibi pathname) (chibi uri)
+ (chibi filesystem) (chibi io) (chibi string) (chibi process)
+ (chibi net server) (chibi net server-util) (chibi net servlet)
+ (chibi app) (chibi ast) (chibi config) (chibi log) (chibi memoize))
+ (include "http-server.scm"))
diff --git a/lib/chibi/net/server-util.scm b/lib/chibi/net/server-util.scm
new file mode 100644
index 00000000..7b735192
--- /dev/null
+++ b/lib/chibi/net/server-util.scm
@@ -0,0 +1,119 @@
+
+(define (get-host uri headers)
+ (cond
+ ((assq 'host headers)
+ => (lambda (x)
+ (let ((s (string-trim (cdr x))))
+ (substring-cursor s 0 (string-find s #\:)))))
+ ((uri-host uri))
+ (else "localhost")))
+
+(define (line-handler handler)
+ (lambda (in out sock addr)
+ (let ((line (read-line in)))
+ (if (eof-object? line)
+ #f
+ (handler line in out sock addr)))))
+
+(define (parse-command line)
+ (let ((ls (string-split line #\space)))
+ (cons (string->symbol (car ls)) (cdr ls))))
+
+(define (command-handler handler)
+ (line-handler
+ (cond
+ ((hash-table? handler)
+ (lambda (line in out sock addr)
+ (let ((ls (parse-command line)))
+ (cond
+ ((hash-table-ref/default handler (car ls))
+ => (lambda (handler)
+ (handler (car ls) (cdr ls) in out sock addr)))))))
+ ((list? handler)
+ (lambda (line in out sock addr)
+ (let ((ls (parse-command line)))
+ (cond
+ ((assq (car ls) handler)
+ => (lambda (cell)
+ ((cdr cell) (car ls) (cdr ls) in out sock addr)))))))
+ ((procedure? handler)
+ (lambda (line in out sock addr)
+ (let ((ls (parse-command line)))
+ (handler (car ls) (cdr ls) in out sock addr))))
+ (else
+ (error "invalid handler" handler)))))
+
+(define (load-mime-types ht file)
+ (protect
+ (exn
+ (else
+ (display "couldn't load mime types from " (current-error-port))
+ (write file (current-error-port))
+ (newline (current-error-port))
+ (print-exception exn)))
+ (call-with-input-file file
+ (lambda (in)
+ (let lp ()
+ (let ((line (read-line in)))
+ (cond
+ ((not (eof-object? line))
+ (let ((ls (string-split
+ (cond ((string-find line #\#)
+ => (lambda (i) (substring line 0 i)))
+ (else line)))))
+ (if (and (pair? ls) (pair? (cdr ls)))
+ (for-each
+ (lambda (x)
+ (hash-table-set! ht (string->symbol x) (car ls)))
+ (cdr ls)))
+ (lp))))))))))
+
+(define file-mime-type
+ (let ((ext-types #f))
+ (lambda (file . o)
+ ;; set mime types on first use
+ (if (not ext-types)
+ (let ((ht (make-hash-table eq?)))
+ (cond
+ ((any file-exists? '("/etc/mime.types"
+ "/etc/httpd/mime.types"
+ "/etc/apache2/mime.types"))
+ => (lambda (file) (load-mime-types ht file))))
+ (set! ext-types ht)))
+ (let* ((ext (path-extension file))
+ (mtype (or (and ext (hash-table-ref/default
+ ext-types
+ (string->symbol
+ (string-downcase-ascii ext))
+ #f))
+ "application/octet-stream")))
+ ;; TODO: auto-detect charset
+ (if (equal? mtype "text/html")
+ (string-append mtype "; charset=UTF-8")
+ mtype)))))
+
+(define (call-with-temp-file template proc)
+ (let ((base (string-append
+ "/tmp/" (path-strip-extension template)
+ "-" (number->string (current-process-id)) "-"
+ (number->string (round (current-seconds))) "-"))
+ (ext (path-extension template)))
+ (let lp ((i 0))
+ (let ((path (string-append base (number->string i) "." ext)))
+ (cond
+ ((> i 100) ;; give up after too many tries regardless
+ (error "Repeatedly failed to generate temp file in /tmp"))
+ ((file-exists? path)
+ (lp (+ i 1)))
+ (else
+ (let ((fd (open path
+ (bitwise-ior open/write open/create open/exclusive))))
+ (if (not fd)
+ (if (file-exists? path) ;; created between test and open
+ (lp (+ i 1))
+ (error "Couldn't generate temp file in /tmp " path))
+ (let* ((out (open-output-file-descriptor fd #o700))
+ (res (proc path out)))
+ (close-output-port out)
+ (delete-file path)
+ res)))))))))
diff --git a/lib/chibi/net/server-util.sld b/lib/chibi/net/server-util.sld
new file mode 100644
index 00000000..5a502724
--- /dev/null
+++ b/lib/chibi/net/server-util.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi net server-util)
+ (import (chibi) (chibi io) (chibi net) (chibi string) (chibi uri)
+ (chibi process) (chibi time) (chibi pathname) (chibi filesystem)
+ (srfi 33) (srfi 69))
+ (export line-handler command-handler parse-command
+ get-host file-mime-type call-with-temp-file)
+ (include "server-util.scm"))
diff --git a/lib/chibi/net/servlet.scm b/lib/chibi/net/servlet.scm
new file mode 100644
index 00000000..af335252
--- /dev/null
+++ b/lib/chibi/net/servlet.scm
@@ -0,0 +1,240 @@
+;; servlet.scm -- basic web servlets and utilities
+;; Copyright (c) 2013-2014 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Library for http and cgi servlets.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Uploads.
+
+(define-record-type Upload
+ (make-upload name filename sxml)
+ upload?
+ (name upload-name upload-name-set!)
+ (filename upload-filename upload-filename-set!)
+ (sxml upload-sxml upload-sxml-set!))
+
+;; Currently uploads are only represented as inlined strings, but may
+;; be saved to temp files in later versions so we provide only this
+;; abstract API.
+
+(define (upload-headers upload)
+ (cadr (upload-sxml upload)))
+
+(define (upload->string upload)
+ (car (cddr (upload-sxml upload))))
+
+(define (upload-input-port upload)
+ (open-input-string (upload->string upload)))
+
+(define (upload-save upload path)
+ (call-with-output-file path
+ (lambda (out) (display (upload->string upload) out))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Requests.
+
+(define-record-type Request
+ (%make-request
+ method host uri version headers body params uploads in out sock addr status)
+ request?
+ (method request-method request-method-set!)
+ (host request-host request-host-set!)
+ (uri request-uri request-uri-set!)
+ (version request-version request-version-set!)
+ (headers request-headers request-headers-set!)
+ (body request-body request-body-set!)
+ (params request-params request-params-set!)
+ (uploads request-uploads request-uploads-set!)
+ (in request-in request-in-set!)
+ (out request-out request-out-set!)
+ (sock request-sock request-sock-set!)
+ (addr request-addr request-addr-set!)
+ (status request-status request-status-set!))
+
+(define (request-uri-string request)
+ (uri->string (request-uri request)))
+
+(define (request-path request)
+ (uri-path (request-uri request)))
+
+(define (copy-request r)
+ (%make-request
+ (request-method r) (request-host r) (request-uri r) (request-version r)
+ (request-headers r) (request-body r) (request-params r) (request-uploads r)
+ (request-in r) (request-out r) (request-sock r) (request-addr r)
+ (request-status r)))
+
+(define (request-with-uri request uri)
+ (let ((request2 (copy-request request)))
+ (request-uri-set! request2 (string->path-uri 'http uri))
+ request2))
+
+(define (request-param request name . o)
+ (cond ((assoc name (request-params request)) => cdr)
+ (else (and (pair? o) (car o)))))
+
+(define (assoc-multi ls key)
+ (let lp ((ls ls) (res '()))
+ (cond ((not (pair? ls)) (reverse res))
+ ((equal? key (caar ls)) (lp (cdr ls) (cons (cdar ls) res)))
+ (else (lp (cdr ls)res)))))
+
+(define (request-param-list request name)
+ (assoc-multi (request-params request) name))
+
+(define (request-upload request name . o)
+ (cond ((assoc name (request-uploads request)) => cdr)
+ (else (and (pair? o) (car o)))))
+
+(define (request-upload-list request name)
+ (assoc-multi (request-uploads request) name))
+
+(define (make-request method path version in out sock addr)
+ (let* ((uri (string->path-uri 'http path))
+ (headers (mime-headers->list in))
+ (host (get-host uri headers))
+ (params (uri-query->alist (or (uri-query uri) ""))))
+ (%make-request method host uri version headers #f params '()
+ in out sock addr #f)))
+
+(define (make-cgi-request)
+ (let* ((method (or (get-environment-variable "REQUEST_METHOD") "GET"))
+ (uri (string->path-uri
+ 'http (or (get-environment-variable "REQUEST_URI") "")))
+ (params (uri-query->alist (or (uri-query uri) "")))
+ (headers `((host . ,(or (get-environment-variable "HTTP_HOST")
+ ""))))
+ (host (get-host uri headers))
+ (version (or (get-environment-variable "SERVER_PROTOCOL")
+ "HTTP/1.0")))
+ (%make-request method host uri version headers #f params '()
+ (current-input-port) (current-output-port) #f #f #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Higher-level utilities.
+
+(define (servlet-write-status out status msg)
+ (display "HTTP/1.1 " out)
+ (display status out)
+ (display " " out)
+ (display msg out)
+ (display "\r\n" out))
+
+;;> Respond with a numeric status, string message and optional headers.
+
+(define (servlet-respond request status msg . o)
+ (cond
+ ((not (and (integer? status) (<= 0 status 999)))
+ (error "http status must be a 3-digit integer" status))
+ ((request-status request)
+ (error "can't set servlet status multiple times: "
+ (request-status request) status))
+ (else
+ (request-status-set! request status)
+ (let* ((out (request-out request))
+ (headers (if (pair? o) (car o) '()))
+ (headers
+ (cond
+ ;; Socket bound, not CGI, send normal status.
+ ((request-sock request)
+ (servlet-write-status out status msg)
+ headers)
+ ;; No socket bound, we're in CGI, send status as a header.
+ (else
+ (let ((str (string-append (number->string status) " " msg)))
+ `((Status . ,str)
+ ,@headers))))))
+ (mime-write-headers headers out)
+ (display "\r\n" out)
+ (flush-output out)))))
+
+;;> Write the contents of a string to the request. If no status has
+;;> been sent, assume a default of 200.
+
+(define (servlet-write request str)
+ (if (not (request-status request))
+ (servlet-respond request 200 "OK"))
+ (display str (request-out request)))
+
+(define (extract-form-data sxml)
+ (define (form-data x)
+ (and (pair? x) (eq? 'mime (car x))
+ (pair? (cdr x)) (pair? (cadr x)) (eq? '@ (car (cadr x)))
+ (string? (car (cddr x)))
+ (assq 'content-disposition (cdr (cadr x)))))
+ (let lp ((ls sxml) (res '()) (files '()))
+ (cond
+ ((null? ls)
+ (cons (reverse res) (reverse files)))
+ ((form-data (car ls))
+ => (lambda (x)
+ (let ((disp (mime-parse-content-type (cdr x))))
+ (cond
+ ((and (pair? disp) (assq 'name (cdr disp)))
+ => (lambda (y)
+ (let ((name (cdr y))
+ (val (cadr (cdar ls))))
+ (cond
+ ((assq 'filename (cdr disp))
+ => (lambda (z)
+ ;; If it has a filename it's an upload,
+ ;; we take the param value to be the
+ ;; filename, and accumulate the file.
+ (let ((upload (make-upload name (cdr z) (car ls))))
+ (lp (cdr ls)
+ (cons (cons name (cdr z)) res)
+ (cons (cons name upload) files)))))
+ (else
+ (lp (cdr ls) (cons (cons name val) res) files))))))
+ (else
+ (log-warn "ignoring form-data with no name: " x)
+ (lp (cdr ls) res files))))))
+ (else
+ (lp (cdr ls) res files)))))
+
+(define (servlet-parse-body! request)
+ (let* ((headers (request-headers request))
+ (ctype
+ (mime-parse-content-type
+ (cond ((assq 'content-type headers) => cdr)
+ (else ""))))
+ (in (request-in request)))
+ (cond
+ ((and (pair? ctype) (eq? 'multipart/form-data (car ctype)))
+ (let* ((sxml (mime-message->sxml in headers))
+ (vars+files (extract-form-data sxml))
+ (vars (append (request-params request) (car vars+files))))
+ (request-body-set! request sxml)
+ (request-params-set! request vars)
+ (request-uploads-set! request (cdr vars+files))))
+ ((and (pair? ctype) (eq? 'application/x-www-form-urlencoded (car ctype)))
+ (let ((line (read-line in)))
+ (request-body-set! request line)
+ (if (not (eof-object? line))
+ (request-params-set! request
+ (append (request-params request)
+ (uri-query->alist line)))))))))
+
+(define (make-status-servlet status msg . o)
+ (lambda (cfg request next restart)
+ (apply servlet-respond request status msg o)))
+
+(define servlet-bad-request
+ (make-status-servlet 400 "Bad request"))
+
+;; Generic interface.
+
+(define servlet-handler (make-parameter #f))
+
+(define (servlet-run servlet)
+ (let ((handler (servlet-handler)))
+ (cond
+ ((procedure? handler)
+ ;; A servlet handler has been set, so we're in a persistent server.
+ (handler servlet))
+ (else
+ ;; Otherwise this is basic CGI.
+ (let ((cfg (make-conf '() #f #f #f)))
+ (let restart ((request (make-cgi-request)))
+ (servlet cfg request servlet-bad-request restart)))))))
diff --git a/lib/chibi/net/servlet.sld b/lib/chibi/net/servlet.sld
new file mode 100644
index 00000000..584a23ec
--- /dev/null
+++ b/lib/chibi/net/servlet.sld
@@ -0,0 +1,26 @@
+
+(define-library (chibi net servlet)
+ (export
+ ;; uploads
+ upload? upload-name upload-filename
+ upload-headers upload->string upload-input-port upload-save
+ ;; requests
+ request? request-method request-host
+ request-uri request-version request-headers request-body request-params
+ request-in request-out request-sock request-addr request-param
+ request-method-set! request-host-set! request-uri-set!
+ request-version-set! request-headers-set! request-body-set!
+ request-params-set! request-in-set! request-out-set!
+ request-sock-set! request-addr-set!
+ request-param request-param-list request-upload request-upload-list
+ request-uri-string request-with-uri request-path
+ copy-request make-request make-cgi-request
+ ;; servlets
+ servlet-write servlet-respond servlet-parse-body!
+ make-status-servlet servlet-handler servlet-run
+ servlet-bad-request)
+ (import
+ (chibi) (srfi 9) (srfi 39) (srfi 69) (srfi 98)
+ (chibi ast) (chibi io) (chibi uri) (chibi mime) (chibi log) (chibi config)
+ (chibi filesystem) (chibi net) (chibi net server-util))
+ (include "servlet.scm"))