Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-19 10:47:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding initial web server.

Browse source
This commit is contained in:
Alex Shinn 2014-03-16 21:13:34 +09:00
parent d945e744e1
commit cd1af42e49
6 changed files with 921 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

511
lib/chibi/net/http-server.scm Normal file
View file

@ -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 "<html><body bgcolor=white><pre>\n" out)
(for-each
(lambda (file)
(display "<a href=\"/" out)
(display (path-normalize (make-path path file)) out)
(display "\">" out)
(display file out)
(display "</a>\n" out))
(sort (directory-files path)))
(display "</pre></body></html>\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 -- [<cfg-file-or-directory>]
;;
;; 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 [<cfg-file-or-directory>]"))
((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))

17
lib/chibi/net/http-server.sld Normal file
View file

@ -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"))

119
lib/chibi/net/server-util.scm Normal file
View file

@ -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)))))))))

8
lib/chibi/net/server-util.sld Normal file
View file

@ -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"))

240
lib/chibi/net/servlet.scm Normal file
View file

@ -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)))))))

26
lib/chibi/net/servlet.sld Normal file
View file

@ -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"))