8sync/systems/websocket/client.scm

   1 ;;; guile-websocket --- WebSocket client/server
   2 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2020 Rutger van Beusekom <rutger.van.beusekom@gmail.com>
   6 ;;;
   7 ;;; This file is part of guile-websocket.
   8 ;;;
   9 ;;; Guile-websocket is free software; you can redistribute it and/or modify
  10 ;;; it under the terms of the GNU Lesser General Public License as
  11 ;;; published by the Free Software Foundation; either version 3 of the
  12 ;;; License, or (at your option) any later version.
  13 ;;;
  14 ;;; Guile-websocket is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;;; Lesser General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General Public
  20 ;;; License along with guile-websocket.  If not, see
  21 ;;; <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; WebSocket client.
  26 ;;
  27 ;;; Code:
  28
  29 (define-module (8sync systems websocket client)
  30   #:use-module (ice-9 match)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (rnrs io ports)
  34   #:use-module (web request)
  35   #:use-module (web response)
  36   #:use-module (web uri)
  37   #:use-module (oop goops)
  38   #:use-module (8sync)
  39   #:use-module (8sync ports)
  40   #:use-module (8sync contrib base64)
  41   #:use-module (8sync systems websocket frame)
  42   #:use-module (8sync systems websocket utils)
  43   #:export (<websocket>
  44             .on-close
  45             .on-error
  46             .on-message
  47             .on-open
  48             .socket
  49             .state
  50             .url
  51
  52             websocket-closed?
  53             websocket-closing?
  54             websocket-connect
  55             websocket-connecting?
  56             websocket-open?
  57
  58             websocket-close
  59             websocket-loop
  60             websocket-send))
  61
  62 (define no-op (const #f))
  63
  64 (define-actor <websocket> (<actor>)
  65   ((*init* websocket-init)
  66    (close websocket-close)
  67    (open websocket-open)
  68    (send websocket-send))
  69
  70   (state #:accessor .state #:init-value 'closed #:init-keyword #:state)
  71   (socket #:accessor .socket #:init-value #f #:init-keyword #:socket)
  72   (url #:getter .url #:init-value #f #:init-keyword #:url)
  73   (uri #:accessor .uri #:init-value #f #:init-keyword #:uri)
  74   (entropy-port #:accessor .entropy-port #:init-form (open-entropy-port))
  75   (frames #:accessor .frames #:init-value '())
  76
  77   (on-close #:init-keyword #:on-close
  78                  #:init-value no-op
  79                  #:accessor .on-close)
  80   (on-error #:init-keyword #:on-error
  81             #:init-value no-op
  82             #:accessor .on-error)
  83   (on-message #:init-keyword #:on-message
  84               #:accessor .on-message)
  85   (on-open #:init-keyword #:on-open
  86                 #:init-value no-op
  87                 #:accessor .on-open))
  88
  89 (define-method (websocket-close (websocket <websocket>) message)
  90   (when (websocket-open? websocket)
  91     (false-if-exception (close-port (.socket websocket)))
  92     (set! (.state websocket) 'closed)
  93     (false-if-exception ((.on-close websocket) websocket))
  94     (set! (.socket websocket) #f)))
  95
  96 (define-method (websocket-open (websocket <websocket>) message uri-or-string)
  97   (if (websocket-closed? websocket)
  98       (let ((uri (match uri-or-string
  99                    ((? uri? uri) uri)
 100                    ((? string? str) (string->uri str)))))
 101         (if (websocket-uri? uri)
 102             (catch 'system-error
 103               (lambda _
 104                 (set! (.uri websocket) uri)
 105                 (let ((sock (make-client-socket uri)))
 106                   (set! (.socket websocket) sock)
 107                   (handshake websocket)
 108                   (websocket-loop websocket message)))
 109               (lambda (key . args)
 110                 ((.on-error websocket) websocket (format #f "open failed: ~s: ~s" uri-or-string args))))
 111             ((.on-error websocket) websocket (format #f "not a websocket uri: ~s" uri-or-string))))
 112       ((.on-error websocket) websocket (format #f "cannot open websocket in state: ~s" (.state websocket)))))
 113
 114 (define (subbytevector bv start end)
 115   (if (= (bytevector-length bv) end) bv
 116       (let* ((length (- end start))
 117              (sub (make-bytevector length)))
 118         (bytevector-copy! bv start sub 0 length)
 119         sub)))
 120
 121 (define* (make-fragmented-frames data #:key (fragment-size (expt 2 15)))
 122   (let ((length (if (string? data) (string-length data)
 123                     (bytevector-length data))))
 124     (let loop ((offset 0))
 125       (let* ((size (min fragment-size (- length offset)))
 126              (end (+ offset size))
 127              (final? (= end length))
 128              (continuation? (not (zero? offset)))
 129              (frame (if (string? data) (make-text-frame (substring data offset end) #:final? final? #:continuation? continuation?)
 130                         (make-binary-frame (subbytevector data offset end) #:final? final? #:continuation? continuation?))))
 131         (if final? (list frame)
 132             (cons frame (loop end)))))))
 133
 134 (define-method (websocket-send (websocket <websocket>) message data)
 135   (catch #t         ; expect: wrong-type-arg (open port), system-error
 136     (lambda _
 137       (let* ((frames (make-fragmented-frames data))
 138              (frames? (pair? (.frames websocket))))
 139         (set! (.frames websocket) (append (.frames websocket) frames))
 140         (unless frames?
 141           (let loop ()
 142             (let ((frames (.frames websocket)))
 143               (when (pair? frames)
 144                 (write-frame (car frames) (.socket websocket))
 145                 (set! (.frames websocket) (cdr (.frames websocket)))
 146                 (loop)))))))
 147     (lambda (key . args)
 148       (unless (and (memq key '(system-error wrong-type-arg))
 149                    (match args
 150                      (((or "put-u8" "put-bytevector") arg ...) #t)
 151                      (_ #f)))
 152         (apply throw key args))
 153       (let ((message (format #f "~a: ~s" key args)))
 154         ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
 155         (websocket-close websocket message)))))
 156
 157 (define-method (websocket-init (websocket <websocket>) message)
 158   (and=> (.url websocket) (cut websocket-open websocket message <>)))
 159
 160 (define-method (websocket-socket-open? (websocket <websocket>))
 161   "Return #t if .SOCKET of WEBSOCKET is open."
 162   (not (port-closed? (.socket websocket))))
 163
 164 (define-method (websocket-loop (websocket <websocket>) message)
 165
 166   (define (handle-data-frame type data)
 167     ((.on-message websocket)
 168      websocket
 169      (match type
 170        ('text   (utf8->string data))
 171        ('binary data))))
 172
 173   (define (read-frame-maybe)
 174     (and (not (eof-object? (lookahead-u8 (.socket websocket))))
 175          (read-frame (.socket websocket))))
 176
 177   (define (close-down)
 178     (websocket-close websocket message))
 179
 180   ((.on-open websocket) websocket)
 181
 182   (let loop ((fragments '())
 183              (type #f))
 184     (catch #t          ;expect: wrong-type-arg (open port), system-error
 185       (lambda _
 186         (let* ((socket (.socket websocket))
 187                (frame (and (websocket-open? websocket)
 188                            (read-frame-maybe))))
 189           (cond
 190            ;; EOF - port is closed.
 191            ;; @@: Sometimes the eof object appears here as opposed to
 192            ;;   at lookahead, but I'm not sure why
 193            ((or (not frame) (eof-object? frame))
 194             (close-down))
 195            ;; Per section 5.4, control frames may appear interspersed
 196            ;; along with a fragmented message.
 197            ((close-frame? frame)
 198             ;; Per section 5.5.1, echo the close frame back to the
 199             ;; socket before closing the socket.  The socket may no
 200             ;; longer be listening.
 201             (false-if-exception
 202              (write-frame (make-close-frame (frame-data frame)) socket))
 203             (close-down))
 204            ((ping-frame? frame)
 205             ;; Per section 5.5.3, a pong frame must include the exact
 206             ;; same data as the ping frame.
 207             (write-frame (make-pong-frame (frame-data frame)) socket)
 208             (loop fragments type))
 209            ((pong-frame? frame)         ; silently ignore pongs
 210             (loop fragments type))
 211            ((first-fragment-frame? frame) ; begin accumulating fragments
 212             (loop (list frame) (frame-type frame)))
 213            ((final-fragment-frame? frame) ; concatenate all fragments
 214             (handle-data-frame type (frame-concatenate
 215                                      (reverse (cons frame fragments))))
 216             (loop '() #f))
 217            ((fragment-frame? frame)     ; add a fragment
 218             (loop (cons frame fragments) type))
 219            ((data-frame? frame)         ; unfragmented data frame
 220             (handle-data-frame (frame-type frame) (frame-data frame))
 221             (loop '() #f)))))
 222       (lambda (key . args)
 223         (unless (and
 224                  (memq key '(system-error wrong-type-arg))
 225                  (match args
 226                    (((or "get-u8" "get-bytevector-n" "lookahead-u8") arg ...)
 227                     #t)
 228                    (_ #f)))
 229           (apply throw key args))
 230         (let ((message (format #f "~a: ~s" key args)))
 231           ((.on-error websocket) websocket (format #f "read failed: ~s\n" websocket))
 232           (if (websocket-socket-open? websocket) (loop '() #f)
 233               (websocket-close websocket message)))))))
 234
 235 ;; See Section 3 - WebSocket URIs
 236 (define (encrypted-websocket-scheme? uri)
 237   "Return #t if the scheme for URI is 'wss', the secure WebSocket
 238 scheme."
 239   (eq? (uri-scheme uri) 'wss))
 240
 241 (define (unencrypted-websocket-scheme? uri)
 242   "Return #t if the scheme for URI is 'ws', the insecure WebSocket
 243 scheme."
 244   (eq? (uri-scheme uri) 'ws))
 245
 246 (define (websocket-uri? uri)
 247   "Return #t if URI is a valid WebSocket URI."
 248   (and (or (encrypted-websocket-scheme? uri)
 249            (unencrypted-websocket-scheme? uri))
 250        (not (uri-fragment uri))))
 251
 252 (define (set-nonblocking! port)
 253   (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
 254   (setvbuf port 'block 1024))
 255
 256 (define (make-client-socket uri)
 257   "Connect a socket to the remote resource described by URI."
 258   (let* ((port (uri-port uri))
 259          (info (car (getaddrinfo (uri-host uri)
 260                                  (if port
 261                                      (number->string port)
 262                                      (symbol->string (uri-scheme uri)))
 263                                  (if port
 264                                      AI_NUMERICSERV
 265                                      0))))
 266          (sock (with-fluids ((%default-port-encoding #f))
 267                  (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
 268
 269     (set-nonblocking! sock)
 270     ;; Disable buffering for websockets
 271     (setvbuf sock 'none)
 272
 273     ;; TODO: Configure I/O buffering?
 274     (connect sock (addrinfo:addr info))
 275     sock))
 276
 277 (define-method (write (o <websocket>) port)
 278    (format port "#<websocket ~a ~a>"
 279            (.url o)
 280            (.state o)))
 281
 282 (define-method (websocket-connecting? (websocket <websocket>))
 283   "Return #t if WEBSOCKET is in the connecting state."
 284   (eq? (.state websocket) 'connecting))
 285
 286 (define-method (websocket-open? (websocket <websocket>))
 287   "Return #t if WEBSOCKET is in the open state."
 288   (eq? (.state websocket) 'open))
 289
 290 (define-method (websocket-closing? (websocket <websocket>))
 291   "Return #t if WEBSOCKET is in the closing state."
 292   (eq? (.state websocket) 'closing))
 293
 294 (define-method (websocket-closed? (websocket <websocket>))
 295   "Return #t if WEBSOCKET is in the closed state."
 296   (eq? (.state websocket) 'closed))
 297
 298 (define-method (generate-client-key (websocket <websocket>))
 299   "Return a random, base64 encoded nonce using the entropy source of
 300 WEBSOCKET."
 301   (base64-encode
 302    (get-bytevector-n (.entropy-port websocket) 16)))
 303
 304 ;; See Section 4.1 - Client Requirements
 305 (define (make-handshake-request uri key)
 306   "Create an HTTP request for initiating a WebSocket connection with
 307 the remote resource described by URI, using a randomly generated nonce
 308 KEY."
 309   (let ((headers `((host . (,(uri-host uri) . #f))
 310                    (upgrade . ("WebSocket"))
 311                    (connection . (upgrade))
 312                    (sec-websocket-key . ,key)
 313                    (sec-websocket-version . "13"))))
 314     (build-request uri #:method 'GET #:headers headers)))
 315
 316 (define-method (handshake (websocket <websocket>))
 317   "Perform the WebSocket handshake for the client WEBSOCKET."
 318   (let ((key (generate-client-key websocket)))
 319     (write-request (make-handshake-request (.uri websocket) key)
 320                    (.socket websocket))
 321     (let* ((response (read-response (.socket websocket)))
 322            (headers (response-headers response))
 323            (upgrade (assoc-ref headers 'upgrade))
 324            (connection (assoc-ref headers 'connection))
 325            (accept (assoc-ref headers 'sec-websocket-accept)))
 326       ;; Validate the handshake.
 327       (if (and (= (response-code response) 101)
 328                (string-ci=? (car upgrade) "websocket")
 329                (equal? connection '(upgrade))
 330                (string=? (string-trim-both accept) (make-accept-key key)))
 331           (set! (.state websocket) 'open)
 332           (begin
 333             (websocket-close websocket)
 334             ((.on-error websocket) websocket
 335              (format #f "websocket handshake failed: ~s"
 336                      (uri->string (.uri websocket)))))))))
 337
 338 (define (open-entropy-port)
 339   "Return an open input port to a reliable source of entropy for the
 340 current system."
 341   (if (file-exists? "/dev/urandom")
 342       (open-input-file "/dev/urandom")
 343       ;; XXX: This works as a fall back but this isn't exactly a
 344       ;; reliable source of entropy.
 345       (make-soft-port (vector (const #f) (const #f) (const #f)
 346                               (lambda _ (let ((r (random 256))) (integer->char r)))
 347                               (const #f)
 348                               (const #t)) "r")))
 349
 350 (define-method (websocket-close (websocket <websocket>))
 351   "Close the WebSocket connection for the client WEBSOCKET."
 352   (let ((socket (.socket websocket)))
 353     (set! (.state websocket) 'closing)
 354     (write-frame (make-close-frame (make-bytevector 0)) socket)
 355     ;; Per section 5.5.1 , wait for the server to close the connection
 356     ;; for a reasonable amount of time.
 357     (let loop ()
 358       (match (select #() (vector socket) #() 1) ; 1 second timeout
 359         ((#() #(socket) #()) ; there is output to read
 360          (unless (port-eof? socket)
 361            (read-frame socket) ; throw it away
 362            (loop)))))
 363     (close-port socket)
 364     (close-port (.entropy-port websocket))
 365     (set! (.state websocket) 'closed)))