76 lines
3.4 KiB
Scheme
76 lines
3.4 KiB
Scheme
;; Copyright (c) 2010-2014, Arthur Maciel
|
|
;; All rights reserved.
|
|
;;
|
|
;; Redistribution and use in source and binary forms, with or without
|
|
;; modification, are permitted provided that the following conditions
|
|
;; are met:
|
|
;; 1. Redistributions of source code must retain the above copyright
|
|
;; notice, this list of conditions and the following disclaimer.
|
|
;; 2. Redistributions in binary form must reproduce the above copyright
|
|
;; notice, this list of conditions and the following disclaimer in the
|
|
;; documentation and/or other materials provided with the distribution.
|
|
;; 3. The name of the authors may not be used to endorse or promote products
|
|
;; derived from this software without specific prior written permission.
|
|
;;
|
|
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
|
|
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
|
|
;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
|
;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
|
|
;; IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
|
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
(module (awful sse)
|
|
|
|
(define-page/sse send-sse-data send-sse-retry)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken keyword)
|
|
(chicken string)
|
|
;;data-structures extras posix
|
|
awful spiffy intarweb)
|
|
|
|
(define (add-sse-resource! sse-path sse-proc vhost-root-path client-path)
|
|
(add-resource! sse-path
|
|
(or vhost-root-path (root-path))
|
|
(lambda (#!optional given-path)
|
|
(let ((accept (header-values 'accept
|
|
(request-headers (current-request)))))
|
|
;; If client's EventSource (JS code) requested SSE page...
|
|
(if (memq 'text/event-stream accept)
|
|
;;...complete handshake & keep connection alive with 'sse-proc'.
|
|
(lambda ()
|
|
(with-headers '((content-type text/event-stream)
|
|
(cache-control no-cache)
|
|
(connection keep-alive))
|
|
(lambda ()
|
|
(write-logged-response)
|
|
(sse-proc))))
|
|
(redirect-to client-path))))
|
|
'GET
|
|
#f))
|
|
|
|
(define (define-page/sse path contents sse-path sse-proc #!rest rest)
|
|
(apply define-page (append (list path contents) rest))
|
|
(add-sse-resource! sse-path sse-proc (get-keyword vhost-root-path: rest) path))
|
|
|
|
(define (write-body data)
|
|
(display data (response-port (current-response)))
|
|
(finish-response-body (current-response)))
|
|
|
|
(define (send-sse-data data #!key event id)
|
|
(let ((msg (conc (if id (conc "id: " id "\n") "")
|
|
(if event (conc "event: " event "\n") "")
|
|
"data: " data "\n\n")))
|
|
(write-body msg)))
|
|
|
|
(define (send-sse-retry retry)
|
|
(write-body (conc "retry: " retry "\n\n")))
|
|
|
|
) ; End of module
|
|
|