summaryrefslogtreecommitdiff
path: root/toot
diff options
context:
space:
mode:
Diffstat (limited to 'toot')
-rw-r--r--toot/web-socket.scm124
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..6cb3e0b
--- /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" 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"))))))