simple/simple.scm

(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 $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"))
(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 *post-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 (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)
  (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* ((method (request-method (current-request)))
              (uri (request-uri (current-request)))
              (proc (resource-ref uri method)))
         (if proc
             (run-resource proc uri)
             (old-handler _)))))))

(define (run-resource proc path)
  (reset-per-request-parameters)
  (let ((handler
         (lambda (path proc)
           (proc))))
    (call/cc (lambda (continue)
               (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*))
    (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 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))))
    (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
                               (cond ((string? path) (uri-path (uri-reference path)))
                                     ((uri-reference? path) (uri-path path))
                                     (else (abort "unknown path type")))
                               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 (request-uri (current-request))
                            (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 (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
               ;; TODO is this a duplicate of the above?
               (maybe-create/refresh-session! use-session)
               (send-response
                body:
                (with-output-to-string
                  (lambda ()
                    (apply contents (cdr args))))))
             ((page-access-denied-message) 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)
  (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")))

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

(define ($session-destroy!)
  (session-destroy! (sid)))

)