Maybe fixing session issues.

simple.scm

@@ -1,22 +1,19 @@
 (module simple
-    (server-response-headers sid page-exception-message enable-session
+    (server-response-headers sid 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 $session-destroy!)
+     page-access-control server-start $session-destroy!
+     add-post-request-handler-hook!)
 
 (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"))
@@ -46,6 +43,7 @@
 (define %error (make-parameter #f))
 (define %page-title (make-parameter #f))
 (define *request-handler-hooks* '())
+(define *post-request-handler-hooks* '())
 
 (define *static-resources* (make-hash-table equal?))
 (define *proc-resources* '())
@@ -71,7 +69,11 @@
 
 (define (remove-request-handler-hook! name)
   (set! *request-handler-hooks*
-        (alist-delete! name *request-handler-hooks*)))
+    (alist-delete! name *request-handler-hooks*)))
+
+(define (add-post-request-handler-hook! name proc)
+  (set! *post-request-handler-hooks*
+        (alist-update! name proc *post-request-handler-hooks*)))
 
 (define (reset-per-request-parameters) ;; to cope with spiffy's thread reuse
   (http-request-variables #f)
@@ -81,26 +83,11 @@
   (%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))
@@ -113,54 +100,36 @@
   (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)))
+       (let* ((method (request-method (current-request)))
+              (uri (request-uri (current-request)))
+              (proc (resource-ref uri 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 _))))))))
+             (run-resource proc uri)
+             (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"))))))))))))
+           (proc))))
     (call/cc (lambda (continue)
-               (for-each (lambda (hook)
-                           ((cdr hook) path
-                                       (lambda ()
-                                         (handler path proc)
-                                         (continue #f))))
-                         *request-handler-hooks*)
-               (handler path proc)))))
+               (dynamic-wind
+                 (lambda ()
+                   (for-each (lambda (hook)
+                               ((cdr hook) path
+                                (lambda ()
+                                  (handler path proc)
+                                  (continue #f))))
+                             *request-handler-hooks*))
+                 (lambda ()
+                   (handler path proc))
+                 (lambda ()
+                   (for-each (lambda (hook)
+                               ((cdr hook) path
+                                (lambda ()
+                                  (handler path proc)
+                                  (continue #f))))
+                             *post-request-handler-hooks*)))))))
 
 (define (resource-match/procedure path method)
   (let loop ((resources *proc-resources*))
@@ -177,11 +146,11 @@
                     (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 (resource-ref uri method)
+  (if (hash-table-exists? *static-resources* (list (uri-path uri) method))
+      (let ((proc (hash-table-ref *static-resources* (list (uri-path uri) method))))
+        (lambda () (proc uri)))
+      (resource-match/procedure uri method)))
 
 (define (add-resource! path proc method)
   (let ((methods (if (list? method) method (list method))))
@@ -193,8 +162,8 @@
              (set! *proc-resources* (cons (list path upcase-method proc) *proc-resources*))
              (hash-table-set! *static-resources*
                               (list
-                               (cond ((string? path) path)
-                                     ((uri-reference? path) (uri->string path))
+                               (cond ((string? path) (uri-path (uri-reference path)))
+                                     ((uri-reference? path) (uri-path path))
                                      (else (abort "unknown path type")))
                                upcase-method) proc))))
      methods)))
@@ -207,7 +176,8 @@
   (handle-directory
    (let ((old-handler (handle-directory)))
      (lambda (path)
-       (cond ((resource-ref path (request-method (current-request)))
+       (cond ((resource-ref (request-uri (current-request))
+                            (request-method (current-request)))
               => (cut run-resource <> path))
              (else (old-handler path)))))))
 
@@ -215,78 +185,39 @@
   (when (and (enable-session) (session-valid? (sid)))
     (session-refresh! (sid))))
 
-(define (make-chunked-port output-port #!key (buffer-size 4094))
-  (let ((buffer (make-string 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)
-      (set! pos 0))
-    (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)
-                      (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)
+  (unless (procedure? contents) (error "contents must be a procedure"))
   (add-resource!
    path
    ;; args is path + any procedure match args
    (lambda args
-     (sid (get-sid use-session))
-     (server-refresh-session!)
+     ;; (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)
-     )
+               ;; TODO is this a duplicate of the above?
+               ;; (maybe-create/refresh-session! use-session)
+               (handle-exceptions
+                   exn
+                 (if ((condition-predicate 'redirect) exn)
+                     (let ((new-uri ((condition-property-accessor 'redirect 'uri) exn)))
+                       (send-response
+                        body:
+                        (string-append
+                         "<html><head><meta http-equiv=\"refresh\" content=\"0; URL="
+                         (cond ((string? new-uri) new-uri)
+                               ((uri-reference? new-uri) (uri->string new-uri))
+                               (else (abort "invalid URI construct")))
+                         "\"></head></html")))
+                     (abort exn))
+                 (send-response
+                  body:
+                  (with-output-to-string
+                    (lambda ()
+                      (apply contents (cdr args)))))))
+             ((page-access-denied-message) path))))
    method))
 
 (define (server-start)
@@ -298,15 +229,12 @@
 (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))
+           (or (read-cookie (session-cookie-name)) ($ 'sid)
+               (sid))
            ($ 'sid))))
 
 (define (redirect-to new-uri)
-  (display (string-append "<html><head><meta http-equiv=\"refresh\" content=\"0; URL="
-                          (cond ((string? new-uri) new-uri)
-                                ((uri-reference? new-uri) (uri->string new-uri))
-                                (else (abort "invalid URI construct")))
-                          "\"></head></html")))
+  (signal (make-property-condition 'redirect 'uri new-uri)))
 
 (define ($ var #!optional default/converter)
   (unless (http-request-variables)