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"))))))