From cd1af42e494dc767d7ef862511d115866007719d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 16 Mar 2014 21:13:34 +0900 Subject: [PATCH] Adding initial web server. --- lib/chibi/net/http-server.scm | 511 ++++++++++++++++++++++++++++++++++ lib/chibi/net/http-server.sld | 17 ++ lib/chibi/net/server-util.scm | 119 ++++++++ lib/chibi/net/server-util.sld | 8 + lib/chibi/net/servlet.scm | 240 ++++++++++++++++ lib/chibi/net/servlet.sld | 26 ++ 6 files changed, 921 insertions(+) create mode 100644 lib/chibi/net/http-server.scm create mode 100644 lib/chibi/net/http-server.sld create mode 100644 lib/chibi/net/server-util.scm create mode 100644 lib/chibi/net/server-util.sld create mode 100644 lib/chibi/net/servlet.scm create mode 100644 lib/chibi/net/servlet.sld 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"))