diff options
| -rw-r--r-- | toot/web-socket.scm | 124 |
1 files changed, 124 insertions, 0 deletions
diff --git a/toot/web-socket.scm b/toot/web-socket.scm new file mode 100644 index 0000000..e955bb7 --- /dev/null +++ b/toot/web-socket.scm @@ -0,0 +1,124 @@ +;;; Toot --- Mastodon client. +;;; Copyright © 2020 Masaya Tojo <masaya@tojo.tokyo> +;;; +;;; This file is part of Toot. +;;; +;;; Toot is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Toot is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Toot. If not, see <http://www.gnu.org/licenses/>. + +(define-module (toot web-socket) + #:use-module (toot config) + #:use-module (ice-9 rdelim) + #:use-module (gcrypt base64) + #:use-module (gcrypt hash) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 and-let-star) + #:use-module (ice-9 receive)) + +(define tls-wrap (@@ (web client) tls-wrap)) + +(define* (connect-to-server host #:optional (https? #t)) + (let* ((ai (car (getaddrinfo host (if https? "https" "http")))) + (s (socket (addrinfo:fam ai) + (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (connect s (addrinfo:addr ai)) + (if https? + (tls-wrap s host) + s))) + +(define (generate-nonce) + (base64-encode + (call-with-bytevector-output-port + (lambda (p) + (do ((i 16 (- i 1))) + ((zero? i)) + (put-u8 p (random 256))))))) + +(define (nonce-hash nonce) + (base64-encode + (bytevector-hash + (string->utf8 + (string-append nonce + "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")) + (hash-algorithm sha1)))) + +(define (read-header-line port) + (let ((line (read-line port))) + (cond + ((eof-object? line) (eof-object)) + (else + (string-delete #\return line))))) + +(define (read-status-code port) + (and-let* ((line (read-header-line port)) + ((not (eof-object? line))) + (first-space-index (string-index line #\space)) + (second-space-index (string-index line + #\space + (1+ first-space-index))) + (status-code + (string->number + (substring line (1+ first-space-index) second-space-index)))) + (values status-code))) + +(define (read-headers port) + (let ((line (read-header-line port))) + (or (and-let* (((not (eof-object? line))) + ((not (string=? "" line))) + (index (string-index line #\:)) + (key (string->symbol + (string-downcase (substring line 0 index)))) + (value (string-trim (substring line (1+ index))))) + (cons (cons key value) + (read-headers port))) + '()))) + +(define (make-web-socket port headers) + (lambda (op . args) + (case op + ((headers) headers) + ((port) port) + ((close) (close port)) + (else + (error "invalid op"))))) + +(define* (web-socket-connect host path #:key headers) + (let ((port (connect-to-server host)) + (nonce (generate-nonce))) + (format port "GET ~a HTTP/1.1\r\n" path) + (format port "Host: ~a\r\n" host) + (format port "Upgrade: websocket\r\n") + (format port "Connection: Upgrade\r\n") + (format port "Sec-WebSocket-Key: ~a\r\n" nonce) + (for-each (lambda (header) + (format port "~a: ~a\r\n" + (string-capitalize (symbol->string (car header))) + (cadr header))) + headers) + (format port "\r\n") + (let* ((status-code (read-status-code port)) + (headers (read-headers port))) + (cond + ((not (eqv? 101 status-code)) + (error "status-code must be 101:" status-code)) + ((assoc-ref headers 'sec-websocket-accept) + => + (lambda (sec-websocket-accept) + (let ((expected (nonce-hash nonce))) + (unless (string=? sec-websocket-accept expected) + (error "sec-websocket-accpet:" sec-websocket-accept expected)) + (make-web-socket port headers)))) + (else + (error "sec-websocket-accept not found")))))) |