Initial.

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

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

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