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 write-chunk $session-destroy!)

(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
                               (cond ((string? path) path)
                                     ((uri-reference? path) (uri->string 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 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 (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)
  (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)
  (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)))

)