blob: e955bb74925588d02bb0b6d561697c354a955106 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
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"))))))
|
