diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..502167f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/lib diff --git a/demo.ss b/demo.ss new file mode 100644 index 0000000..b5031b1 --- /dev/null +++ b/demo.ss @@ -0,0 +1,14 @@ +(import (libra libra)) + +(get! "/" + (lambda (p) (default-make-response "GET request"))) + +(post! "/" + (lambda (p) (default-make-response "POST request"))) + +(get! "/blog/:user/:age" + (lambda (p) + (define content (string-append "p是储存所有参数(路由/请求)的关联表; " "User: " (params-ref p "user" "") ",Ages: " (params-ref p "age" ""))) + (default-make-json (cons (cons "content" content) p)))) + +(libra:run 8080) \ No newline at end of file diff --git a/libra/libra.core.ss b/libra/libra.core.ss deleted file mode 100644 index 2c7891e..0000000 --- a/libra/libra.core.ss +++ /dev/null @@ -1,359 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; web Lib -;; created by : 1481892212@qq.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(load (string-append (getenv "SCHEME_LIBRARY_PATH") "/" "chez.init")) -(import (scheme) - (except (surfage s13 strings) - string-for-each string-fill! string-copy - string->list string-copy! string-titlecase - string-upcase string-downcase string-hash) - (cffi cffi) - (net socket) - (net socket-ffi) - (irregex irregex) - (json json) - (c c-ffi) - (web mime)) -;; slib feature -(require 'http) -(require 'cgi) -(require 'array) - - -;; 定义http方法函数 -(define (get! url handler) (router! "get" url handler)) -(define (post! url handler) (router! "post" url handler)) -;; (define (put! url handler) (route! 'put url handler)) -;; (define (delete! url handler) (route! 'delete url handler)) - - -;; 定义web服务器启动函数 -(define (run listen-port) - (let [(server (make-socket AF_INET SOCK_STREAM listen-port))] - (socket:bind server) - (socket:listen server) - (printf "Listening on %d\n" listen-port) - (let loop ((port (socket:accept server))) - (if (>= port 0) - (begin - (if (and #f (threads?)) - (make-thread port) - (not-make-thread port) - ) - (loop (socket:accept server))))) - (socket:close server))) - -;; 是否多线程 -(define (threads?) - (char=? #\t (string-ref (symbol->string (machine-type)) 0)) -) - -;; 多线程 -(define (make-thread port) - (fork-thread - (lambda () - (let ((iport (make-fd-input-port port)) - (oport (make-fd-output-port port))) - ;; 指定框架入口 serve-proc - (http:serve-query - (lambda (request-line query-string header) - (serve-proc request-line query-string header iport oport port)) - iport oport) - ;(close-port iport) - ;(close-port oport) - ;(close port) - ) - ) - ) -) - -;; 单线程 -(define (not-make-thread port) - (let ((iport (make-fd-input-port port)) - (oport (make-fd-output-port port))) - ;; 指定框架入口 serve-proc - (http:serve-query - (lambda (request-line query-string header) - (serve-proc request-line query-string header iport oport port)) - iport oport) - ;(close-port iport) - ;(close-port oport) - ;(close port) - ) -) - -;; http response maker -(define (default-make-response html) - (http:content - '(("Content-Type" . "text/html") ("Connection" . "close")) - html)) - -;; 路由哈希表 -(define router-handler (make-hashtable string-hash string=?)) - -;; 定义路由函数 -(define (router! method url handler) - ;; url 转化成 regex和key-list - (define keys/reg (cons #f url)) - (if (number? (string-index url #\:)) - (set! keys/reg (url->keys/reg url))) - (hashtable-set! router-handler (string-append method " " (cdr keys/reg)) (cons (car keys/reg) handler)) -) - -;; 从 hashtable 中获取对应keys/handlder -(define (request->keys/handler request-line query-string) - (let [(method (car request-line)) (router (url->router (cadr request-line)))] - (if (eq? #f router) - (cons #f #f) - (router->keys/handler (string-append (symbol->string method) " " router) query-string))) -) - -;;从request中找到纯净的路由 -(define (url->router url) - (if (string? url) - (if (eq? #f (string-index url #\?)) - url - (substring url 0 (string-index url #\?))) - #f)) - -;; 分析url, 获取路由正则和参数名称list -(define (url->keys/reg url) - (libra-regex-path url)) - -;; 遍历路由表，获取对应的路由的keys/handler, 默认 '(#f . #f) -(define (router->keys/handler router query) - (define router-vector (hashtable-keys router-handler)) - (define router-length (vector-length router-vector)) - (define keys/handler (cons #f #f)) - (define keys (if query (libra-regex-query query) '())) - (let loop ((index 0)) - (begin - (let [(reg-router (vector-ref router-vector index))] - ;; (printf (format "~a\n" reg-router)) - (if (string-index reg-router #\?) - (begin - (let ((values (libra-regex-router reg-router router))) - (if (not (null? values)) - (begin - (let ((names/handler (hashtable-ref router-handler reg-router '(#f . #f)))) - (map (lambda (name value) (set! keys (cons (cons name value) keys))) (car names/handler) values) - (set! keys/handler (cons keys (cdr names/handler))) - ) - ) - ) - ) - ) - (if (equal? router reg-router) - (set! keys/handler (cons keys (cdr (hashtable-ref router-handler router '(#f . #f)))))))) - (if (and (< index (- router-length 1)) (equal? keys/handler '(#f . #f))) - (loop (+ 1 index)) - ) - ) - ) - keys/handler -) - -;; 匹配路由和动态里路，返回参数列表 -(define (libra-regex-router reg str) - (define match (irregex-search reg str)) - (define result '()) - (when match - (let loop ([idx 8]) - (when (vector-ref match idx) - (set! result (cons (substring str (vector-ref match idx) (vector-ref match (+ idx 2))) result)) - (loop (+ idx 4)) - ) - ) - ) - (reverse result) -) - -;; 获取动态路由的参数列表和正则表示 -(define (libra-regex-path str) - (define pattern "/:([^\\/]+)") - (define replace "/([^/?]+)") - (define len (string-length str)) - (define result '()) - (let loop ([match (irregex-search pattern str 0 len)]) - (when match - (set! result (cons (substring str (vector-ref match 8) (vector-ref match 10)) result)) - (loop (irregex-search pattern str (vector-ref match 10) len)) - ) - ) - (cons - (reverse result) - (irregex-replace/all pattern str replace) - ) -) - -;; 获取url参数关联表 -(define (libra-regex-query query) - (define pattern "([^\\/=&]+)=([^=&]*)") - (define len (string-length query)) - (define keys '()) - (let loop ([match (irregex-search pattern query 0 len)]) - (when match - (set! keys (cons (cons - (substring query (vector-ref match 8) (vector-ref match 10)) - (substring query (vector-ref match 12) (vector-ref match 14))) - keys)) - (loop (irregex-search pattern query (vector-ref match 14) len)) - ) - ) - (reverse keys) -) - -;; 读取文本文件 -(define read-file - (lambda (file-name) - (let ((p (open-input-file file-name))) - (let loop ((lst '()) (c (read-char p))) - (if (eof-object? c) - (begin - (close-input-port p) - (list->string (reverse lst))) - (loop (cons c lst) (read-char p))))))) - -;; 返回视图函数 -(define view - (lambda (file-name) - (if (eq? #f (string-index file-name #\.)) - (set! file-name (string-append - (hashtable-ref libra-options "web-path" (get-app-path)) - "/" - (hashtable-ref libra-options "view-path" "views") - "/" - file-name - ".html"))) - (default-make-response (read-file file-name)))) - -;; 默认json返回 -(define (default-make-json data) - (http:content - '(("Content-Type" . "application/json; charset=utf-8") ("Connection" . "close")) - (scm->json-string data))) - -;; 判断资源文件 -(define (resource? request) - (if (not (string-index request #\.)) - #f - (let ((type (string-downcase (substring request (+ 1 (string-index-right request #\.)) (string-length request))))) - (not (not (get-mime-type type)))))) - -;; 返回资源文件 -(define (default-make-resource request port oport) - (let ((file-path (get-file-path request))) - (if (file-exists? file-path) - (begin - (display (string-append - (http:status-line 200 "OK") - (http:header - (list - (get-content-type (substring request (+ 1 (string-index-right request #\.)) (string-length request))) - (cons "Content-Length" (number->string (get-file-length file-path))) - (cons "Connection" "close") - ) - ) - ) - oport - ) - (let ((f (c-fopen file-path "rb")) - (buf (cffi-alloc 1024))) - (let loop ((len (c-fread buf 1 1024 f))) - (if (> len 0) - (begin - (cwrite-all port buf len) - (loop (c-fread buf 1 1024 f))) - (c-fclose f))) - (cffi-free buf) - ) - '() - ) - '(404 "Bad Request") - ) - ) -) - -;; 获取文件长度 -(define (get-file-length file-path) - (define length 0) - (let ([p (open-input-file file-path)]) - (set! length (file-length p)) - (close-port p) - ) - length -) - -;; 获取执行文件文件夹地址 -(define (get-app-path) - (define script (car (command-line))) - (define index-right (string-index-right script #\\)) - (define index-left (string-index-right script #\/)) - (define path (substring script 0 (max (if (number? index-right) index-right 0) (if (number? index-left) index-left 0)))) - (if (string=? "" path) - "." - path - ) -) - - -;; 配置字典 -(define libra-options (make-hashtable string-hash string=?)) - -;; 展示字典 -(define (show-options) - (vector-map (lambda (k) (display (string-append k ": " (hashtable-ref libra-options k ""))) (newline)) (hashtable-keys libra-options)) -) - -;; web根目录 -(hashtable-set! libra-options "web-path" (get-app-path)) -;; 视图文件夹名称 -(hashtable-set! libra-options "view-path" "views") -;; 启动文件目录 -(hashtable-set! libra-options "app-path" (get-app-path)) - -;; 返回资源对应http头 -(define (get-content-type type) - (cons "Content-Type" (symbol->string (get-mime-type type 'text/html))) -) - -;; 获取web配置 -(define (get-option key . rest) - (define default (if (null? rest) #f (car rest))) - (hashtable-ref libra-options key default)) - -;; 设置配置 -(define (set-opiton! key value) - (hashtable-set! libra-options key value)) - -;; 获取文件完整路径 -(define (get-file-path file) - (string-append (hashtable-ref libra-options "web-path" (get-app-path)) file)) - -;; 文件导入 -(define (using file) - (load (string-append (hashtable-ref libra-options "app-path" (get-app-path)) (string (directory-separator)) file))) - -;; 路由函数参数解析 -(define (params-ref p key . default) - (let ((pair (assoc key p))) - (if pair - (cdr pair) - (if (null? default) #f (car default))) - ) -) - - -;; 服务器处理 入口 -(define serve-proc - (lambda (request-line query-string header iport oport port) - ;; show msg on server - (printf "HTTP=>%a\n" request-line) - (if (resource? (cadr request-line)) - (default-make-resource (cadr request-line) port oport) - (let [(keys/handler (request->keys/handler request-line query-string))] - (if (procedure? (cdr keys/handler)) - ((cdr keys/handler) (car keys/handler)) - '(404 "Bad Request")))))) - diff --git a/libra/libra.sls b/libra/libra.sls index 5fd0ed3..962bc45 100644 --- a/libra/libra.sls +++ b/libra/libra.sls @@ -1,6 +1,312 @@ -(load "libra.core.ss") +(library (libra libra) + (export + get! + post! + default-make-response + router! + libra:run) + (import + (scheme) + (except (surfage s13 strings) + string-for-each string-fill! string-copy + string->list string-copy! string-titlecase + string-upcase string-downcase string-hash) + (irregex irregex) + (json json) + (libc libc) + (libra mime) + (libra server http-cgi) + (libra server tiny)) -(library (web libra) - (export) - (import (scheme)) + ;; 定义http方法函数 + (define (get! url handler) (router! "get" url handler)) + (define (post! url handler) (router! "post" url handler)) + ;; (define (put! url handler) (route! 'put url handler)) + ;; (define (delete! url handler) (route! 'delete url handler)) + + ;; http response maker + (define (default-make-response html) + (http:content + '(("Content-Type" . "text/html") ("Connection" . "close")) + html)) + + ;; 路由哈希表 + (define router-handler (make-hashtable string-hash string=?)) + + ;; 定义路由函数 + (define (router! method url handler) + ;; url 转化成 regex和key-list + (define keys/reg (cons #f url)) + (if (number? (string-index url #\:)) + (set! keys/reg (url->keys/reg url))) + (hashtable-set! router-handler (string-append method " " (cdr keys/reg)) (cons (car keys/reg) handler)) + ) + + ;; 从 hashtable 中获取对应keys/handlder + (define (request->keys/handler request-line query-string) + (let [(method (car request-line)) (router (url->router (cadr request-line)))] + (if (eq? #f router) + (cons #f #f) + (router->keys/handler (string-append (symbol->string method) " " router) query-string))) + ) + + ;;从request中找到纯净的路由 + (define (url->router url) + (if (string? url) + (if (eq? #f (string-index url #\?)) + url + (substring url 0 (string-index url #\?))) + #f)) + + ;; 分析url, 获取路由正则和参数名称list + (define (url->keys/reg url) + (libra-regex-path url)) + + ;; 遍历路由表，获取对应的路由的keys/handler, 默认 '(#f . #f) + (define (router->keys/handler router query) + (define router-vector (hashtable-keys router-handler)) + (define router-length (vector-length router-vector)) + (define keys/handler (cons #f #f)) + (define keys (if query (libra-regex-query query) '())) + (let loop ((index 0)) + (begin + (let [(reg-router (vector-ref router-vector index))] + ;; (printf (format "~a\n" reg-router)) + (if (string-index reg-router #\?) + (begin + (let ((values (libra-regex-router reg-router router))) + (if (not (null? values)) + (begin + (let ((names/handler (hashtable-ref router-handler reg-router '(#f . #f)))) + (map (lambda (name value) (set! keys (cons (cons name value) keys))) (car names/handler) values) + (set! keys/handler (cons keys (cdr names/handler))) + ) + ) + ) + ) + ) + (if (equal? router reg-router) + (set! keys/handler (cons keys (cdr (hashtable-ref router-handler router '(#f . #f)))))))) + (if (and (< index (- router-length 1)) (equal? keys/handler '(#f . #f))) + (loop (+ 1 index)) + ) + ) + ) + keys/handler + ) + + ;; 匹配路由和动态里路，返回参数列表 + (define (libra-regex-router reg str) + (define match (irregex-search reg str)) + (define result '()) + (when match + (let loop ([idx 8]) + (when (vector-ref match idx) + (set! result (cons (substring str (vector-ref match idx) (vector-ref match (+ idx 2))) result)) + (loop (+ idx 4)) + ) + ) + ) + (reverse result) + ) + + ;; 获取动态路由的参数列表和正则表示 + (define (libra-regex-path str) + (define pattern "/:([^\\/]+)") + (define replace "/([^/?]+)") + (define len (string-length str)) + (define result '()) + (let loop ([match (irregex-search pattern str 0 len)]) + (when match + (set! result (cons (substring str (vector-ref match 8) (vector-ref match 10)) result)) + (loop (irregex-search pattern str (vector-ref match 10) len)) + ) + ) + (cons + (reverse result) + (irregex-replace/all pattern str replace) + ) + ) + + ;; 获取url参数关联表 + (define (libra-regex-query query) + (define pattern "([^\\/=&]+)=([^=&]*)") + (define len (string-length query)) + (define keys '()) + (let loop ([match (irregex-search pattern query 0 len)]) + (when match + (set! keys (cons (cons + (substring query (vector-ref match 8) (vector-ref match 10)) + (substring query (vector-ref match 12) (vector-ref match 14))) + keys)) + (loop (irregex-search pattern query (vector-ref match 14) len)) + ) + ) + (reverse keys) + ) + + ;; 读取文本文件 + (define read-file + (lambda (file-name) + (let ((p (open-input-file file-name))) + (let loop ((lst '()) (c (read-char p))) + (if (eof-object? c) + (begin + (close-input-port p) + (list->string (reverse lst))) + (loop (cons c lst) (read-char p))))))) + + ;; 返回视图函数 + (define view + (lambda (file-name) + (if (eq? #f (string-index file-name #\.)) + (set! file-name (string-append + (hashtable-ref libra-options "web-path" (get-app-path)) + "/" + (hashtable-ref libra-options "view-path" "views") + "/" + file-name + ".html"))) + (default-make-response (read-file file-name)))) + + ;; 默认json返回 + (define (default-make-json data) + (http:content + '(("Content-Type" . "application/json; charset=utf-8") ("Connection" . "close")) + (scm->json-string data))) + + ;; 判断资源文件 + (define (resource? request) + (if (not (string-index request #\.)) + #f + (let ((type (string-downcase (substring request (+ 1 (string-index-right request #\.)) (string-length request))))) + (not (not (get-mime-type type)))))) + + ;; 返回资源对应http头 + (define (get-content-type type) + (cons "Content-Type" (symbol->string (get-mime-type type 'text/html))) + ) + + ;; 返回资源文件 + (define (default-make-resource request) + 0 + ; (let ((file-path (get-file-path request))) + ; (if (file-exists? file-path) + ; (begin + ; (display (string-append + ; (http:status-line 200 "OK") + ; (http:header + ; (list + ; (get-content-type (substring request (+ 1 (string-index-right request #\.)) (string-length request))) + ; (cons "Content-Length" (number->string (get-file-length file-path))) + ; (cons "Connection" "close") + ; ) + ; ) + ; ) + ; oport + ; ) + ; (let ((f (c-fopen file-path "rb")) + ; (buf (cffi-alloc 1024))) + ; (let loop ((len (c-fread buf 1 1024 f))) + ; (if (> len 0) + ; (begin + ; (cwrite-all port buf len) + ; (loop (c-fread buf 1 1024 f))) + ; (c-fclose f))) + ; (cffi-free buf) + ; ) + ; '() + ; ) + ; '(404 "Bad Request") + ; ) + ; ) + ) + + ;; 获取文件长度 + (define (get-file-length file-path) + (define length 0) + (let ([p (open-input-file file-path)]) + (set! length (file-length p)) + (close-port p) + ) + length + ) + + ;; 获取执行文件文件夹地址 + (define (get-app-path) + (define script (car (command-line))) + (define index-right (string-index-right script #\\)) + (define index-left (string-index-right script #\/)) + (define path (substring script 0 (max (if (number? index-right) index-right 0) (if (number? index-left) index-left 0)))) + (if (string=? "" path) + "." + path + ) + ) + + + ;; 配置字典 + (define libra-options (make-hashtable string-hash string=?)) + + ;; 展示字典 + (define (show-options) + (vector-map (lambda (k) (display (string-append k ": " (hashtable-ref libra-options k ""))) (newline)) (hashtable-keys libra-options)) + ) + + ;; web根目录 + (hashtable-set! libra-options "web-path" (get-app-path)) + ;; 视图文件夹名称 + (hashtable-set! libra-options "view-path" "views") + ;; 启动文件目录 + (hashtable-set! libra-options "app-path" (get-app-path)) + + ;; 获取web配置 + (define (get-option key . rest) + (hashtable-ref libra-options key (if (null? rest) #f (car rest)))) + + ;; 设置配置 + (define (set-opiton! key value) + (hashtable-set! libra-options key value)) + + ;; 获取文件完整路径 + (define (get-file-path file) + (string-append (hashtable-ref libra-options "web-path" (get-app-path)) file)) + + ;; 文件导入 + (define (using file) + (load (string-append (hashtable-ref libra-options "app-path" (get-app-path)) (string (directory-separator)) file))) + + ;; 路由函数参数解析 + (define (params-ref p key . default) + (let ((pair (assoc key p))) + (if pair + (cdr pair) + (if (null? default) #f (car default))) + ) + ) + + + ;; 默认服务器处理 入口 + (define libra-proc + (lambda (request-line query-string header) + ;; show msg on server + (printf "HTTP=~a\n" request-line) + (printf "path=~a\n" (cadr request-line)) + (if (resource? (cadr request-line)) + (default-make-resource (cadr request-line)) + (let [(keys/handler (request->keys/handler request-line query-string))] + (if (procedure? (cdr keys/handler)) + ((cdr keys/handler) (car keys/handler)) + '(404 "Bad Request")))))) + + (define libra:run + (case-lambda + ([port] + (libra:run port "127.0.0.1")) + ([port ip] + (libra:run libra-proc port ip)) + ([proc port ip] + (libra:run tiny:run proc port ip)) + ([server proc port ip] + (server proc port ip)))) ) diff --git a/libra/mime.ss b/libra/mime.ss index 15d295b..8029d5d 100644 --- a/libra/mime.ss +++ b/libra/mime.ss @@ -1,4 +1,4 @@ -(library (web mime) +(library (libra mime) (export get-mime-type) (import (scheme)) diff --git a/libra/server/http-cgi.scm b/libra/server/http-cgi.scm new file mode 100644 index 0000000..c137b41 --- /dev/null +++ b/libra/server/http-cgi.scm @@ -0,0 +1,335 @@ +;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*- +; Copyright 1997, 1998, 2000, 2001, 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(library (libra server http-cgi) + (export + http:read-header + http:read-query-string + http:status-line + http:header + http:content + http:error-page + http:serve-query + http:read-start-line + http:read-request-line + html:head + html:body) + (import + (scheme) + (socket socket) + (irregex irregex)) + +;;@code{(require 'http)} or @code{(require 'cgi)} +;;@ftindex http +;;@ftindex cgi + +(define http:crlf (string (integer->char 13) #\newline)) + +(define (http:read-header port) + (define alist '()) + (do ((line (read-line port) (read-line port))) + ((or (zero? (string-length line)) + (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (eof-object? line)) + (if (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (set! http:crlf (string (string-ref line 0) #\newline))) + (if (eof-object? line) line alist)) + (let ((len (string-length line)) + (idx (string-index line #\:))) + (if (char-whitespace? (string-ref line (+ -1 len))) + (set! len (+ -1 len))) + (and idx + (do ((idx2 (+ idx 1) (+ idx2 1))) + ((or (>= idx2 len) + (not (char-whitespace? (string-ref line idx2)))) + (set! alist + (cons + (cons (string-ci->symbol (substring line 0 idx)) + (substring line idx2 len)) + alist))) + ) + ) + ) + ) +) + +(define (http:read-query-string request-line header port) + (case (car request-line) + ((get head) + (let* ((request-uri (cadr request-line)) + (len (string-length request-uri))) + (and + (> len 3) + (string-index request-uri #\?) + (substring request-uri + (+ 1 (string-index request-uri #\?)) + (if (eqv? #\/ (string-ref request-uri (+ -1 len))) + (+ -1 len) + len))))) + ((post put delete) + (let ((content-length (assq 'content-length header))) + (and + content-length + (set! content-length (string->number (cdr content-length)))) + (and + content-length + (let ((str (make-string content-length #\space))) + (do ((idx 0 (+ idx 1))) + ((>= idx content-length) + (if (>= idx (string-length str)) + str + (substring str 0 idx))) + (let ((chr (read-char port))) + (if (char? chr) + (string-set! str idx chr) + (set! content-length idx)))))))) + (else #f))) + +(define (http:status-line status-code reason) + (format "HTTP/1.0 ~a ~a~a" status-code reason http:crlf)) + +;;@body Returns a string containing lines for each element of @1; the +;;@code{car} of which is followed by @samp{: }, then the @code{cdr}. +(define (http:header alist) + (string-append + (apply + string-append + (map + (lambda (pair) + (format "~a: ~a~a" (car pair) (cdr pair) http:crlf)) + alist)) + http:crlf)) + +;;@body Returns the concatenation of strings @2 with the +;;@code{(http:header @1)} and the @samp{Content-Length} prepended. +(define (http:content alist . body) + (define hunk (apply string-append body)) + (string-append + (http:header + (cons + (cons + "Content-Length" + (number->string (bytevector-length (string->utf8 hunk)))) ;;(string-length hunk) + alist)) + hunk)) + +;;@body String appearing at the bottom of error pages. +(define *http:byline* #f) + +;;@body @1 and @2 should be an integer and string as specified in +;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2 +;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's +;;default at the bottom. +(define (http:error-page status-code reason-phrase . html-strings) + (define byline + (or + *http:byline* + "Libra HTTP/1.0 server" + )) + (string-append + (http:status-line status-code reason-phrase) + (http:content + '(("Content-Type" . "text/html")) + (html:head (format "~a ~a" status-code reason-phrase)) + (apply html:body + (append html-strings + (list (format "
\n~a\n" byline))))))) + + + +;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the +;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls +;;@1 with three arguments, the @var{request-line}, @var{query-string}, +;;and @var{header-alist}. Otherwise, @0 calls @1 with the +;;@var{request-line}, #f, and @var{header-alist}. +;; +;;If @1 returns a string, it is sent to @3. If @1 returns a list +;;whose first element is an integer, then an error page with the +;;status integer which is the first element of the list and strings +;;from the list. If @1 returns a list whose first element isn't an +;;number, then an error page with the status code 500 and strings from +;;the list. If @1 returns #f, then a @samp{Bad Request} (400) page is +;;sent to @3. +;; +;;Otherwise, @0 replies (to @3) with appropriate HTML describing the +;;problem. +(define (http:serve-query serve-proc client-socket) + (let* ([input-port (make-input-port (lambda x (void)) (socket:read client-socket))] + [request-line (http:read-request-line input-port)] + [header (and request-line (http:read-header input-port))] + [query-string (and header (http:read-query-string + request-line header input-port))]) + (socket:write client-socket (http:service serve-proc request-line query-string header)))) + + +(define (http:service serve-proc request-line query-string header) + (cond + ((not request-line) + (http:error-page 400 "Bad Request.")) + ((string? (car request-line)) + (http:error-page 501 "Not Implemented" (html:plain request-line))) + ((not (memq (car request-line) '(get post))) + (http:error-page 405 "Method Not Allowed" (html:plain request-line))) + ((serve-proc request-line query-string header) => + (lambda (reply) + (cond + ((string? reply) + (string-append (http:status-line 200 "OK") + reply)) + ((and (pair? reply) (list? reply)) + (if (number? (car reply)) + (apply http:error-page reply) + (apply http:error-page (cons 500 reply)))) + (else (http:error-page 500 "Internal Server Error"))))) + ((not query-string) + (http:error-page 400 "Bad Request" (html:plain request-line))) + (else + (http:error-page 500 "Internal Server Error" (html:plain header))))) + +(define (http:read-start-line port) + (do ((line (read-line port) (read-line port))) + ((or (not (equal? "" line)) (eof-object? line)) line))) + +;; @body +;; Request lines are a list of three itmes: +;; +;; @enumerate 0 +;; +;; @item Method +;; +;; A symbol (@code{options}, @code{get}, @code{head}, @code{post}, +;; @code{put}, @code{delete}, @code{trace} @dots{}). +;; +;; @item Request-URI +;; +;; A string. For direct HTTP, at the minimum it will be the string +;; @samp{"/"}. +;; +;; @item HTTP-Version +;; +;; A string. For example, @samp{HTTP/1.0}. +;; @end enumerate +(define (http:read-request-line port) + (let ((lst (request-split (http:read-start-line port)))) + (and + (list? lst) + (= 3 (length lst)) + (cons (string-ci->symbol (car lst)) (cdr lst))))) + +;; -------------------- * helper * -------------------- + +(define html:blank (string->symbol "")) + +;;@body Returns a string with character substitutions appropriate to +;;send @1 as an @dfn{plain-text}. +(define (html:plain txt) ; plain-text `Data Characters' + (cond + ((eq? html:blank txt) " ") + (else + (if (symbol? txt) (set! txt (symbol->string txt))) + (if (number? txt) + (number->string txt) + (irregex-replace + ">" + (irregex-replace + "<" + (irregex-replace + "&" + txt + "&") + "<") + ">") + )))) + +;;@args title backlink tags ... +;;@args title backlink +;;@args title +;; +;;Returns header string for an HTML page named @1. If @2 is a string, +;;it is used verbatim between the @samp{H1} tags; otherwise @1 is +;;used. If string arguments @3 ... are supplied, then they are +;;included verbatim within the @t{} section. +(define (html:head title . args) + (define backlink (if (null? args) #f (car args))) + (if (not (null? args)) (set! args (cdr args))) + (string-append + (format "\n") + (format "\n") + (format " \n ~a\n ~a\n \n" + (html:plain title) (apply string-append args)) + (if backlink + backlink + (format "

~a

\n" (html:plain title))))) + +;;@body Returns HTML string to end a page. +(define (html:body . body) + (apply string-append + (append body (list (format "\n\n"))))) + +;;@args +;;@args port +;;Returns a string of the characters up to, but not including a +;;newline or end of file, updating @var{port} to point to the +;;character following the newline. If no characters are available, an +;;end of file object is returned. The @var{port} argument may be +;;omitted, in which case it defaults to the value returned by +;;@code{current-input-port}. +(define (read-line . port) + (let* ((char (apply read-char port))) + (if (eof-object? char) + char + (do ((char char (apply read-char port)) + (clist '() (cons char clist))) + ((or (eof-object? char) (char=? #\newline char)) + (clean-line (list->string (reverse clist)))))))) + +(define (request-split line) + (define lst '()) + (define len (string-length line)) + (let loop ([beg 0] [end 0]) + (cond + ((> end len) + (reverse lst)) + ((or (= end len) (char=? #\space (string-ref line end))) + (set! lst (cons (substring line beg end) lst)) + (loop (+ end 1) (+ end 1))) + (else (loop beg (+ end 1))) + ) + ) +) + +(define string-ci->symbol + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda (str) (string->symbol (s2cis str))))) + +(define (string-index str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos)))) + +(define (clean-line str) + (define idx (- (string-length str) 1)) + (if (char=? (string-ref str idx) #\return) + (substring str 0 idx) + str)) +) diff --git a/libra/server/tiny.sc b/libra/server/tiny.sc new file mode 100644 index 0000000..9cff7c2 --- /dev/null +++ b/libra/server/tiny.sc @@ -0,0 +1,54 @@ +(library (libra server tiny) + (export tiny:run) + (import + (scheme) + (socket socket) + (libra server http-cgi)) + + ;; 是否多线程 + (define threads? + (char=? #\t (string-ref (symbol->string (machine-type)) 0))) + + (define tiny:run + (case-lambda + ([proc port] + (tiny:run proc port "127.0.0.1")) + ([proc port ip] + (let ([server (socket:socket AF_INET SOCK_STREAM IPPROTO_IP)]) + (socket:bind server AF_INET ip port) + (socket:listen server) + (let loop ([client (socket:accept server)]) + (when (>= client 0) + (if threads? + (fork-thread + (lambda () + (server-proc proc client))) + (server-proc proc client)) + (loop (socket:accept server)))) + (socket:close server) + (socket:cleanup))))) + + (define server-proc + (lambda (proc socket) + (http:serve-query proc socket) + (socket:close socket))) +) + +; (import +; (socket socket) +; (libra server http-cgi) +; (libra server tiny)) + +; (define port 8211) +; (define ip "127.0.0.1") + +; (define serve-proc +; (lambda (request-line query-string header) +; (printf "HTTP=~a\n" request-line) +; (printf "path=~a\n" (cadr request-line)) +; (string-append +; (http:content +; '(("Content-Type" . "text/html")) +; "
test
")))) + +; (tiny:run serve-proc port ip) \ No newline at end of file diff --git a/package.sc b/package.sc index cef323f..3c97095 100644 --- a/package.sc +++ b/package.sc @@ -9,5 +9,7 @@ ("private" . #f) ("scripts" ("run" . "scheme --script")) -("dependencies") +("dependencies" + ("irregex" . "0.9.6") + ("json" . "0.5.1")) ("devDependencies")) \ No newline at end of file