8sync/systems/websocket/client.scm

   1 ;;; guile-websocket --- WebSocket client/server
   2 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
   3 ;;;
   4 ;;; This file is part of guile-websocket.
   5 ;;;
   6 ;;; Guile-websocket is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation; either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; Guile-websocket is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with guile-websocket.  If not, see
  18 ;;; <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21 ;;
  22 ;; WebSocket client.
  23 ;;
  24 ;;; Code:
  25
  26 (define-module (8sync systems websocket client)
  27   #:use-module (ice-9 match)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (rnrs io ports)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-9 gnu)
  32   #:use-module (web request)
  33   #:use-module (web response)
  34   #:use-module (web uri)
  35   #:use-module (8sync contrib base64)
  36   #:use-module (8sync systems websocket frame)
  37   #:use-module (8sync systems websocket utils)
  38   #:export (make-websocket
  39             websocket?
  40             websocket-uri
  41             websocket-state
  42             websocket-connecting?
  43             websocket-open?
  44             websocket-closing?
  45             websocket-closed?
  46             close-websocket
  47             websocket-send
  48             websocket-receive))
  49
  50 ;; See Section 3 - WebSocket URIs
  51 (define (encrypted-websocket-scheme? uri)
  52   "Return #t if the scheme for URI is 'wss', the secure WebSocket
  53 scheme."
  54   (eq? (uri-scheme uri) 'wss))
  55
  56 (define (unencrypted-websocket-scheme? uri)
  57   "Return #t if the scheme for URI is 'ws', the insecure WebSocket
  58 scheme."
  59   (eq? (uri-scheme uri) 'ws))
  60
  61 (define (websocket-uri? uri)
  62   "Return #t if URI is a valid WebSocket URI."
  63   (and (or (encrypted-websocket-scheme? uri)
  64            (unencrypted-websocket-scheme? uri))
  65        (not (uri-fragment uri))))
  66
  67 (define (make-client-socket uri)
  68   "Connect a socket to the remote resource described by URI."
  69   (let* ((port (uri-port uri))
  70          (info (car (getaddrinfo (uri-host uri)
  71                                  (if port
  72                                      (number->string port)
  73                                      (symbol->string (uri-scheme uri)))
  74                                  (if port
  75                                      AI_NUMERICSERV
  76                                      0))))
  77          (s (with-fluids ((%default-port-encoding #f))
  78               (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
  79     ;; TODO: Configure I/O buffering?
  80     (connect s (addrinfo:addr info))
  81     s))
  82
  83 (define-record-type <websocket>
  84   (%make-websocket uri socket entropy-port state)
  85   websocket?
  86   (uri websocket-uri)
  87   (socket websocket-socket)
  88   (entropy-port websocket-entropy-port)
  89   (state websocket-state set-websocket-state!))
  90
  91 (define (display-websocket ws port)
  92   (format port "#<websocket ~a ~a>"
  93           (uri->string (websocket-uri ws))
  94           (websocket-state ws)))
  95
  96 (set-record-type-printer! <websocket> display-websocket)
  97
  98 (define (websocket-connecting? ws)
  99   "Return #t if the WebSocket WS is in the connecting state."
 100   (eq? (websocket-state ws) 'connecting))
 101
 102 (define (websocket-open? ws)
 103   "Return #t if the WebSocket WS is in the open state."
 104   (eq? (websocket-state ws) 'open))
 105
 106 (define (websocket-closing? ws)
 107   "Return #t if the WebSocket WS is in the closing state."
 108   (eq? (websocket-state ws) 'closing))
 109
 110 (define (websocket-closed? ws)
 111   "Return #t if the WebSocket WS is in the closed state."
 112   (eq? (websocket-state ws) 'closed))
 113
 114 (define (generate-client-key ws)
 115   "Return a random, base64 encoded nonce using the entropy source of
 116 WS."
 117   (base64-encode
 118    (get-bytevector-n (websocket-entropy-port ws) 16)))
 119
 120 ;; See Section 4.1 - Client Requirements
 121 (define (make-handshake-request uri key)
 122   "Create an HTTP request for initiating a WebSocket connection with
 123 the remote resource described by URI, using a randomly generated nonce
 124 KEY."
 125   (let ((headers `((host . (,(uri-host uri) . #f))
 126                    (upgrade . ("WebSocket"))
 127                    (connection . (upgrade))
 128                    (sec-websocket-key . ,key)
 129                    (sec-websocket-version . "13"))))
 130     (build-request uri #:method 'GET #:headers headers)))
 131
 132 (define (handshake ws)
 133   "Perform the WebSocket handshake for the client WS."
 134   (let ((key (generate-client-key ws)))
 135     (write-request (make-handshake-request (websocket-uri ws) key)
 136                    (websocket-socket ws))
 137     (let* ((response (read-response (websocket-socket ws)))
 138            (headers (response-headers response))
 139            (upgrade (assoc-ref headers 'upgrade))
 140            (connection (assoc-ref headers 'connection))
 141            (accept (assoc-ref headers 'sec-websocket-accept)))
 142       ;; Validate the handshake.
 143       (if (and (= (response-code response) 101)
 144                (string-ci=? (car upgrade) "websocket")
 145                (equal? connection '(upgrade))
 146                (string=? (string-trim-both accept) (make-accept-key key)))
 147           (set-websocket-state! ws 'open)
 148           (begin
 149             (close-websocket ws)
 150             (error "websocket handshake failed" (websocket-uri ws)))))))
 151
 152 (define (open-entropy-port)
 153   "Return an open input port to a reliable source of entropy for the
 154 current system."
 155   ;; XXX: This works on GNU/Linux and OS X systems, but this isn't
 156   ;; exactly portable.
 157   (open-input-file "/dev/urandom"))
 158
 159 (define (make-websocket uri-or-string)
 160   "Create and establish a new WebSocket connection for the remote
 161 resource described by URI-OR-STRING."
 162   (let ((uri (match uri-or-string
 163                ((? uri? uri) uri)
 164                ((? string? str) (string->uri str)))))
 165     (if (websocket-uri? uri)
 166         (let ((ws (%make-websocket uri
 167                                    (make-client-socket uri)
 168                                    (open-entropy-port)
 169                                    'connecting)))
 170           (handshake ws)
 171           ws)
 172         (error "not a websocket uri" uri))))
 173
 174 (define (close-websocket ws)
 175   "Close the WebSocket connection for the client WS."
 176   (let ((socket (websocket-socket ws)))
 177     (set-websocket-state! ws 'closing)
 178     (write-frame (make-close-frame (make-bytevector 0)) socket)
 179     ;; Per section 5.5.1 , wait for the server to close the connection
 180     ;; for a reasonable amount of time.
 181     (let loop ()
 182       (match (select #() (vector socket) #() 1) ; 1 second timeout
 183         ((#() #(socket) #()) ; there is output to read
 184          (unless (port-eof? socket)
 185            (read-frame socket) ; throw it away
 186            (loop)))))
 187     (close-port socket)
 188     (close-port (websocket-entropy-port ws))
 189     (set-websocket-state! ws 'closed)
 190     *unspecified*))
 191
 192 (define (generate-masking-key ws)
 193   "Create a new masking key using the entropy source of WS."
 194   ;; Masking keys are 32 bits long.
 195   (get-bytevector-n (websocket-entropy-port ws) 4))
 196
 197 (define (websocket-send ws data)
 198   "Send DATA, a string or bytevector, to the server that WS is
 199 connected to."
 200   ;; TODO: Send frames over some threshold in fragments.
 201   (write-frame (make-text-frame data (generate-masking-key ws))
 202                (websocket-socket ws)))
 203
 204 (define (websocket-receive ws)
 205   "Read a response from the server that WS is connected to."
 206   ;; TODO: Handle fragmented frames and control frames.
 207   (let ((frame (read-frame (websocket-socket ws))))
 208     (if (binary-frame? frame)
 209         (frame-data frame)
 210         (text-frame->string frame))))