|
|
(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 ports)
|
|
|
(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))))
|
|
|
|
|
|
(use z3)
|
|
|
(define z (z3:encode-init))
|
|
|
(define b "")
|
|
|
(z3:encode z (lambda (s) (display s)) (with-input-from-file "news.scm"
|
|
|
(lambda () (substring (read-string) 640))))
|
|
|
(z3:encode z (lambda (s) (set! b s)) "hi, how are you?")
|
|
|
|
|
|
(z3:encode-buffer "hi, how are you?")
|
|
|
(get-output-string dest)
|
|
|
(z3:decode-buffer "<22><><EFBFBD>Q<EFBFBD><51>/WH,JU<4A><55>/<2F>\a\x00")
|
|
|
(z3:decode-buffer (z3:encode-buffer "hi, how are you?"))
|
|
|
|
|
|
(define (make-chunked-port output-port #!key (buffer-size 4094))
|
|
|
(let ((buffer (make-string buffer-size))
|
|
|
(output (make-string buffer-size))
|
|
|
(z3-handle (z3:init buffer: buffer buffer-size: buffer-size))
|
|
|
(pos 0))
|
|
|
(define (flush)
|
|
|
(fprintf output-port "~X" pos)
|
|
|
(display "\n" output-port)
|
|
|
(if (fx= pos buffer-size)
|
|
|
(display buffer output-port)
|
|
|
(display (substring buffer 0 pos) output-port))
|
|
|
(display "\n" output-port)
|
|
|
(flush-output output-port))
|
|
|
(make-output-port
|
|
|
(lambda (s)
|
|
|
(let ((len (##core#inline "C_block_size" s)))
|
|
|
(let loop ((s-pos 0))
|
|
|
(if (fx>= (fx+ len pos) buffer-size)
|
|
|
(begin (##core#inline "C_substring_copy" s buffer s-pos
|
|
|
(fx+ (fx- buffer-size pos) s-pos) pos)
|
|
|
(let ((len-written (z3:encode z3-handle
|
|
|
(lambda (s)
|
|
|
(set! output
|
|
|
(string-append output s))) s)))
|
|
|
)
|
|
|
(set! len (fx- len (fx- buffer-size pos)))
|
|
|
(set! s-pos (fx+ s-pos (fx- buffer-size pos)))
|
|
|
(set! pos buffer-size)
|
|
|
(flush)
|
|
|
(set! pos 0)
|
|
|
(loop s-pos))
|
|
|
(begin (##core#inline "C_substring_copy" s buffer s-pos (fx+ len s-pos) pos)
|
|
|
(set! pos (fx+ pos len)))))))
|
|
|
(lambda ()
|
|
|
(flush)
|
|
|
(display "0\r\n\r\n" output-port)
|
|
|
(flush-output output-port))
|
|
|
flush)))
|
|
|
|
|
|
(define (write-chunk contents)
|
|
|
(printf "~X" (string-length contents))
|
|
|
(display "\n")
|
|
|
(display contents)
|
|
|
(display "\n")
|
|
|
(flush-output (response-port (current-response))))
|
|
|
|
|
|
(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)
|
|
|
(let ((chunked-port (make-chunked-port (response-port (current-response)))))
|
|
|
(with-output-to-port chunked-port
|
|
|
(lambda ()
|
|
|
(apply contents (cdr args))))
|
|
|
(close-output-port chunked-port))
|
|
|
;; (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))
|
|
|
|
|
|
)
|