awful-sse/awful.sse.scm

77 lines
3.4 KiB
Scheme
Raw Permalink Normal View History

2014-07-08 02:13:58 +00:00
;; Copyright (c) 2010-2014, Arthur Maciel
2014-07-08 02:01:53 +00:00
;; 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.
2020-12-29 02:29:22 +00:00
(module (awful sse)
2014-07-08 02:01:53 +00:00
(define-page/sse send-sse-data send-sse-retry)
2020-12-29 02:29:22 +00:00
(import scheme
(chicken base)
(chicken keyword)
(chicken string)
;;data-structures extras posix
awful spiffy intarweb)
2014-07-08 02:37:35 +00:00
(define (add-sse-resource! sse-path sse-proc vhost-root-path client-path)
(add-resource! sse-path
2020-12-29 02:29:22 +00:00
(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'.
2014-07-08 02:37:35 +00:00
(lambda ()
2020-12-29 02:29:22 +00:00
(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))
2014-07-08 02:37:35 +00:00
(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))
2014-07-08 02:01:53 +00:00
(define (write-body data)
(display data (response-port (current-response)))
(finish-response-body (current-response)))
2020-12-29 02:29:22 +00:00
2014-07-08 02:01:53 +00:00
(define (send-sse-data data #!key event id)
(let ((msg (conc (if id (conc "id: " id "\n") "")
2014-07-08 02:37:35 +00:00
(if event (conc "event: " event "\n") "")
"data: " data "\n\n")))
2014-07-08 02:01:53 +00:00
(write-body msg)))
2020-12-29 02:29:22 +00:00
2014-07-08 02:01:53 +00:00
(define (send-sse-retry retry)
(write-body (conc "retry: " retry "\n\n")))
2014-08-10 04:55:30 +00:00
2014-07-08 02:01:53 +00:00
) ; End of module