From 1dfd420bac3487d1f57f65d5344ae418d196ddad Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Fri, 3 Apr 2015 10:21:47 -0700 Subject: [PATCH] Initial. --- simple.meta | 10 ++ simple.scm | 278 +++++++++++++++++++++++++++++++++++++++++++++++++++ simple.setup | 9 ++ 3 files changed, 297 insertions(+) create mode 100644 simple.meta create mode 100644 simple.scm create mode 100644 simple.setup diff --git a/simple.meta b/simple.meta new file mode 100644 index 0000000..81fc294 --- /dev/null +++ b/simple.meta @@ -0,0 +1,10 @@ +;;; simple.meta -*- scheme -*- + +((egg "simple.egg") + (synopsis "") + (license "BSD") + (category web) + (author "Thomas Hintz") + (depends intarweb spiffy spiffy-request-vars uri-common + http-session spiffy-cookies sxml-transforms) + (files "simple.setup" "simple.meta")) diff --git a/simple.scm b/simple.scm new file mode 100644 index 0000000..dad662f --- /dev/null +++ b/simple.scm @@ -0,0 +1,278 @@ +(module simple + (server-response-headers sid page-exception-message enable-session + add-request-handler-hook! remove-request-handler-hook! + define-page redirect-to enable-session-cookie session-cookie-setter + session-cookie-name $session $session-set! $ page-access-denied-message + debug-file page-access-control server-start write-chunk) + +(import scheme chicken data-structures utils extras ports srfi-69 files srfi-1) +(use posix srfi-13 tcp) +(use intarweb spiffy spiffy-request-vars uri-common + http-session spiffy-cookies sxml-transforms) + +(define debug-file (make-parameter #f)) +(define server-response-headers (make-parameter #f)) +(define sid (make-parameter #f)) +(define page-exception-message + (make-parameter + (lambda (exn) + '(

"An error has occurred while processing your request.")))) +(define enable-session (make-parameter #f)) +(define enable-session-cookie (make-parameter #t)) +(define session-cookie-name (make-parameter "awful-cookie")) +(define session-cookie-setter (make-parameter + (lambda (sid) + (set-cookie! (session-cookie-name) sid)))) +(define page-access-denied-message (make-parameter (lambda (path) '(

"Access denied.")))) +(define page-access-control (make-parameter (lambda (path) #t))) + +(define http-request-variables (make-parameter #f)) + +(define awful-listen (make-parameter tcp-listen)) +(define awful-accept (make-parameter tcp-accept)) +(define awful-backlog (make-parameter 100)) +(define awful-listener (make-parameter + (let ((listener #f)) + (lambda () + (unless listener + (set! listener + ((awful-listen) + (server-port) + (awful-backlog) + (server-bind-address)))) + listener)))) + +(define %redirect (make-parameter #f)) +(define %error (make-parameter #f)) +(define %page-title (make-parameter #f)) +(define *request-handler-hooks* '()) + +(define *static-resources* (make-hash-table equal?)) +(define *proc-resources* '()) + +(define sxml->html + (make-parameter + (let ((rules `((literal *preorder* . ,(lambda (t b) b)) + . ,universal-conversion-rules*))) + (lambda (sxml) + (SRV:send-reply (pre-post-order* sxml rules)))))) + +(define (concat args #!optional (sep "")) + (string-intersperse (map ->string args) sep)) + +(define (string->symbol* str) + (if (string? str) + (string->symbol str) + str)) + +(define (add-request-handler-hook! name proc) + (set! *request-handler-hooks* + (alist-update! name proc *request-handler-hooks*))) + +(define (remove-request-handler-hook! name) + (set! *request-handler-hooks* + (alist-delete! name *request-handler-hooks*))) + +(define (reset-per-request-parameters) ;; to cope with spiffy's thread reuse + (http-request-variables #f) + (server-response-headers #f) + (sid #f) + (%redirect #f) + (%error #f) + (%page-title #f)) + +(define (debug . args) + (when (debug-file) + (with-output-to-file (debug-file) + (lambda () + (print (concat args))) + append:))) + +(define-inline (use-session? use-session) + (or (not (enable-session)) + use-session + (and (enable-session) (session-valid? (sid))))) + +(define-inline (render-exception exn) + (%error exn) + (debug (with-output-to-string + (lambda () + (print-call-chain) + (print-error-message exn)))) + ((page-exception-message) exn)) + +(define-inline (maybe-create/refresh-session! use-session) + (when use-session + (if (session-valid? (sid)) + (server-refresh-session!) + (begin + (sid (session-create)) + ((session-cookie-setter) (sid)))))) + +(define (register-dispatcher) + (handle-not-found + (let ((old-handler (handle-not-found))) + (lambda (_) + (let* ((path-list (uri-path (request-uri (current-request)))) + (method (request-method (current-request))) + (dir? (equal? (last path-list) "")) + (path (if (null? (cdr path-list)) + (car path-list) + (string-append "/" (concat (cdr path-list) "/")))) + (proc (resource-ref path method))) + (if proc + (run-resource proc path) + (if dir? ;; try to find a procedure with the trailing slash removed + (let ((proc (resource-ref (string-chomp path "/") method))) + (if proc + (run-resource proc path) + (old-handler _))) + (old-handler _)))))))) + +(define (run-resource proc path) + (reset-per-request-parameters) + (let ((handler + (lambda (path proc) + (with-headers + (or (server-response-headers) + `((content-type text/html) (transfer-encoding chunked))) + (lambda () + (write-logged-response) + (proc) + (unless (eq? 'HEAD (request-method (current-request))) + (if (%error) + (send-response code: 500 + reason: "Internal server error" + body: ((sxml->html) ((page-exception-message) + (%error))) + headers: '((content-type text/html))) + (if (%redirect) ;; redirection + (let ((new-uri (if (string? (%redirect)) + (uri-reference (%redirect)) + (%redirect)))) + (with-headers `((location ,new-uri)) + (lambda () + (send-status 302 "Found")))))))))))) + (call/cc (lambda (continue) + (for-each (lambda (hook) + ((cdr hook) path + (lambda () + (handler path proc) + (continue #f)))) + *request-handler-hooks*) + (handler path proc))))) + +(define (resource-match/procedure path method) + (let loop ((resources *proc-resources*)) + (if (null? resources) + #f + (let* ((current-path/proc (caar resources)) + (current-method (cadar resources)) + (current-proc (caddar resources))) + (if (eq? current-method method) + ;; the arg to be given to the page handler + (let ((result (current-path/proc path))) + (if (list? result) + (lambda () (apply current-proc (cons path result))) + (loop (cdr resources)))) + (loop (cdr resources))))))) + +(define (resource-ref path method) + (if (hash-table-exists? *static-resources* (list path method)) + (let ((proc (hash-table-ref *static-resources* (list path method)))) + (lambda () (proc path))) + (resource-match/procedure path method))) + +(define (add-resource! path proc method) + (let ((methods (if (list? method) method (list method)))) + (for-each + (lambda (method) + (let ((upcase-method + (string->symbol (string-upcase (symbol->string method))))) + (if (procedure? path) + (set! *proc-resources* (cons (list path upcase-method proc) *proc-resources*)) + (hash-table-set! *static-resources* + (list path upcase-method) proc)))) + methods))) + +(define (reset-resources!) + (set! *static-resources* (make-hash-table equal?))) + +;;; Root dir +(define (register-root-dir-handler) + (handle-directory + (let ((old-handler (handle-directory))) + (lambda (path) + (cond ((resource-ref path (request-method (current-request))) + => (cut run-resource <> path)) + (else (old-handler path))))))) + +(define (server-refresh-session!) + (when (and (enable-session) (session-valid? (sid))) + (session-refresh! (sid)))) + +(define (write-chunk contents) + (printf "~X" (string-length contents)) + (display "\n") + (display contents) + (display "\n")) + +(define (define-page path contents #!key css title doctype headers charset + (method 'GET) use-session) ;; for define-session-page + (##sys#check-closure contents 'define-page) + (add-resource! + path + ;; args is path + any procedure match args + (lambda args + (sid (get-sid use-session)) + (server-refresh-session!) + (if (use-session? use-session) + (if ((page-access-control) (car args)) + (begin + (maybe-create/refresh-session! use-session) + (with-output-to-port (response-port (current-response)) + (lambda () + (apply contents (cdr args)) + (display "0\r\n\r\n"))) + (finish-response-body (current-response)) + ;; (handle-exceptions exn + ;; (render-exception exn) + ;; ;; TODO render-page + ;; ) + ) + ((page-access-denied-message) path))) + ;; TODO what is this? (redirect-to-login-page + ;; (or given-path path) + ) + method)) + +(define (server-start) + (let ((listener ((awful-listener)))) + (register-root-dir-handler) + (register-dispatcher) + (accept-loop listener (awful-accept)))) + +(define (get-sid #!optional force-read-sid) + (and (or (enable-session) force-read-sid) + (if (enable-session-cookie) + (or (read-cookie (session-cookie-name)) ($ 'sid)) + ($ 'sid)))) + +(define (redirect-to new-uri) + ;; Just set the `%redirect' internal parameter, so `run-resource' is + ;; able to know where to redirect. + (%redirect new-uri) + "") + +(define ($ var #!optional default/converter) + (unless (http-request-variables) + (http-request-variables (request-vars))) + ((http-request-variables) var default/converter)) + +(define ($session var #!optional default) + (session-ref (sid) var default)) + +(define ($session-set! var val) + (session-set! (sid) var val)) + +) diff --git a/simple.setup b/simple.setup new file mode 100644 index 0000000..eeefd3d --- /dev/null +++ b/simple.setup @@ -0,0 +1,9 @@ +;;; simple.setup -*- scheme -*- + +;; Compile the extension +(compile -s -O3 -d1 -j simple simple.scm) +(compile -s -O3 -d1 simple.import.scm) + +(install-extension 'simple + '("simple.so" "simple.import.so") + `((version "0.1.0")))