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