summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThomas Hintz <t@thintz.com>2015-04-03 10:21:47 -0700
committerThomas Hintz <t@thintz.com>2015-04-03 10:21:47 -0700
commit1dfd420bac3487d1f57f65d5344ae418d196ddad (patch)
tree25239d0181a118157198d5479a55891d477d0d31
downloadsimple-1dfd420bac3487d1f57f65d5344ae418d196ddad.tar.gz
Initial.
-rw-r--r--simple.meta10
-rw-r--r--simple.scm278
-rw-r--r--simple.setup9
3 files changed, 297 insertions, 0 deletions
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)
+ '(<h3> "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) '(<h3> "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")))