You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

336 lines
12 KiB
Scheme

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