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