;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2016, 2025 David Thompson <dthompson2@worcester.edu>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2023 Andrew Whatson <whatson@tailcall.au>
;;;
;;; This file is part of guile-websocket.
;;;
;;; Guile-websocket is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Guile-websocket 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with guile-websocket.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; WebSocket client.
;;
;;; Code:

(define-module (web socket client)
  #:use-module (gnutls)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (web client)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web socket frame)
  #:use-module (web socket utils)
  #:export (open-websocket-for-uri
            close-websocket
            websocket-send
            websocket-receive
            default-entropy-port))

;; The following chunk of code was snarfed from Guile's (web client)
;; module, available under the same license as the rest of
;; guile-websocket: LGPLv3+.
;;
;; Unfortunately, Guile's open-socket-for-uri doesn't play nicely with
;; nonblocking I/O when TLS encryption is used.  The underlying socket
;; is wrapped by a TLS port and user code cannot access that socket to
;; set the O_NONBLOCK flag.  So, we resort to copying a large chunk of
;; the code that deals with TLS.  Hopefully we can resolve this
;; upstream at some point.
;;
;; Copyright (C) 2011-2018, 2020-2022 Free Software Foundation, Inc.
(define (set-certificate-credentials-x509-trust-file!* cred file format)
  "Like 'set-certificate-credentials-x509-trust-file!', but without the file
name decoding bug described at
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
  (let ((data (call-with-input-file file get-bytevector-all)))
    (set-certificate-credentials-x509-trust-data! cred data format)))

(define (make-credendials-with-ca-trust-files directory)
  "Return certificate credentials with X.509 authority certificates read from
DIRECTORY.  Those authority certificates are checked when
'peer-certificate-status' is later called."
  (let ((cred  (make-certificate-credentials))
        (files (match (scandir directory (cut string-suffix? ".pem" <>))
                 ((or #f ())
                  ;; Some distros provide nothing but bundles (*.crt) under
                  ;; /etc/ssl/certs, so look for them.
                  (or (scandir directory (cut string-suffix? ".crt" <>))
                      '()))
                 (pem pem))))
    (for-each (lambda (file)
                (let ((file (string-append directory "/" file)))
                  ;; Protect against dangling symlinks.
                  (when (file-exists? file)
                    (set-certificate-credentials-x509-trust-file!*
                     cred file
                     x509-certificate-format/pem))))
              files)
    cred))

(define (peer-certificate session)
  "Return the certificate of the remote peer in SESSION."
  (match (session-peer-certificate-chain session)
    ((first _ ...)
     (import-x509-certificate first x509-certificate-format/der))))

(define (assert-valid-server-certificate session server)
  "Return #t if the certificate of the remote peer for SESSION is a valid
certificate for SERVER, where SERVER is the expected host name of peer."
  (define cert
    (peer-certificate session))

  ;; First check whether the server's certificate matches SERVER.
  (unless (x509-certificate-matches-hostname? cert server)
    (throw 'tls-certificate-error 'host-mismatch cert server))

  ;; Second check its validity and reachability from the set of authority
  ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'.
  (match (peer-certificate-status session)
    (()                                           ;certificate is valid
     #t)
    ((statuses ...)
     (throw 'tls-certificate-error 'invalid-certificate cert server
            statuses))))

(define (print-tls-certificate-error port key args default-printer)
  "Print the TLS certificate error represented by ARGS in an intelligible
way."
  (match args
    (('host-mismatch cert server)
     (format port
             "X.509 server certificate for '~a' does not match: ~a~%"
             server (x509-certificate-dn cert)))
    (('invalid-certificate cert server statuses)
     (format port
             "X.509 certificate of '~a' could not be verified:~%  ~a~%"
             server
             (string-join (map certificate-status->string statuses))))))

(set-exception-printer! 'tls-certificate-error
                        print-tls-certificate-error)

(define (wrap-record-port-for-gnutls<3.7.7 record port)
  "Return a port that wraps RECORD to ensure that closing it also closes PORT,
the actual socket port, and its file descriptor.  Make sure it does not
introduce extra buffering (custom ports are buffered by default as of Guile
3.0.5).

This wrapper is unnecessary with GnuTLS >= 3.7.7, which can automatically
close SESSION's file descriptor when RECORD is closed."
  (define (read! bv start count)
    (define read
      (catch 'gnutls-error
        (lambda ()
          (get-bytevector-n! record bv start count))
        (lambda (key err proc . rest)
          ;; When responding to "Connection: close" requests, some servers
          ;; close the connection abruptly after sending the response body,
          ;; without doing a proper TLS connection termination.  Treat it as
          ;; EOF.  This is fixed in GnuTLS 3.7.7.
          (if (eq? err error/premature-termination)
              the-eof-object
              (apply throw key err proc rest)))))

    (if (eof-object? read)
        0
        read))
  (define (write! bv start count)
    (put-bytevector record bv start count)
    (force-output record)
    count)
  (define (get-position)
    (port-position record))
  (define (set-position! new-position)
    (set-port-position! record new-position))
  (define (close)
    (unless (port-closed? port)
      (close-port port))
    (unless (port-closed? record)
      (close-port record)))

  (define (unbuffered port)
    (setvbuf port 'none)
    port)

  (unbuffered
   (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
                                         get-position set-position!
                                         close)))

(define* (tls-wrap port server #:key (verify-certificate? #t))
  "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
host name without trailing dot."
  (define (log level str)
    (format (current-error-port)
            "gnutls: [~a|~a] ~a" (getpid) level str))

  (let ((session  (make-session connection-end/client))
        (ca-certs (x509-certificate-directory)))
    ;; Some servers such as 'cloud.github.com' require the client to support
    ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
    ;; not available in older GnuTLS releases.  See
    ;; <http://bugs.gnu.org/18526> for details.
    (if (module-defined? (resolve-interface '(gnutls))
                         'set-session-server-name!)
        (set-session-server-name! session server-name-type/dns server)
        (format (current-error-port)
                "warning: TLS 'SERVER NAME' extension not supported~%"))

    (set-session-transport-fd! session (fileno port))
    (set-session-default-priority! session)

    ;; The "%COMPAT" bit allows us to work around firewall issues (info
    ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
    ;; Explicitly disable SSLv3, which is insecure:
    ;; <https://tools.ietf.org/html/rfc7568>.
    (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")

    (set-session-credentials! session
                              (if verify-certificate?
                                  (make-credendials-with-ca-trust-files
                                   ca-certs)
                                  (make-certificate-credentials)))

    ;; Uncomment the following lines in case of debugging emergency.
    ;; (set-log-level! 10)
    ;; (set-log-procedure! log)

    (let loop ((retries 5))
      (catch 'gnutls-error
        (lambda ()
          (handshake session))
        (lambda (key err proc . rest)
          (cond ((eq? err error/warning-alert-received)
                 ;; Like Wget, do no stop upon non-fatal alerts such as
                 ;; 'alert-description/unrecognized-name'.
                 (format (current-error-port)
                         "warning: TLS warning alert received: ~a~%"
                         (alert-description->string (alert-get session)))
                 (handshake session))
                (else
                 (if (or (fatal-error? err) (zero? retries))
                     (apply throw key err proc rest)
                     (begin
                       ;; Added by guile-websocket: wait until port is
                       ;; readable again.
                       ((current-read-waiter) (session-record-port session))
                       (loop (- retries 1)))))))))

    ;; Verify the server's certificate if needed.
    (when verify-certificate?
      (catch 'tls-certificate-error
        (lambda ()
          (assert-valid-server-certificate session server))
        (lambda args
          (close-port port)
          (apply throw args))))

    (let ((record (session-record-port session)))
      (setvbuf record 'block)
      (if (module-defined? (resolve-interface '(gnutls))
                           'set-session-record-port-close!) ;GnuTLS >= 3.7.7
          (let ((close-wrapped-port (lambda (_) (close-port port))))
            (set-session-record-port-close! record close-wrapped-port)
            record)
          (wrap-record-port-for-gnutls<3.7.7 record port)))))

(define (setup-http-tunnel port uri)
  "Establish over PORT an HTTP tunnel to the destination server of URI."
  (define target
    (string-append (uri-host uri) ":"
                   (number->string
                    (or (uri-port uri)
                        (match (uri-scheme uri)
                          ('http 80)
                          ('https 443))))))
  (format port "CONNECT ~a HTTP/1.1\r\n" target)
  (format port "Host: ~a\r\n\r\n" target)
  (force-output port)
  (read-response port))

(define (ensure-uri-reference uri-or-string)
  (cond
   ((string? uri-or-string) (string->uri-reference uri-or-string))
   ((uri-reference? uri-or-string) uri-or-string)
   (else (error "Invalid URI-reference" uri-or-string))))

;; configure-socket flag added for guile-websocket.
(define* (open-socket-for-uri uri-or-string #:key
                              (flags SOCK_CLOEXEC)
                              (configure-socket #f) ; deprecated
                              (verify-certificate? #t))
  "Return an open input/output port for a connection to URI-OR-STRING.
When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
  (define uri
    (ensure-uri-reference uri-or-string))
  (define https?
    (eq? 'https (uri-scheme uri)))

  (define (open-socket)
    (define http-proxy
      (if https? (current-https-proxy) (current-http-proxy)))
    (define uri (ensure-uri-reference (or http-proxy uri-or-string)))
    (define addresses
      (let ((port (uri-port uri)))
        (delete-duplicates
         (getaddrinfo (uri-host uri)
                      (cond (port => number->string)
                            ((uri-scheme uri) => symbol->string)
                            (else (error "Not an absolute URI" uri)))
                      (if port
                          AI_NUMERICSERV
                          0))
         (lambda (ai1 ai2)
           (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))

    (let loop ((addresses addresses))
      (let* ((ai (car addresses))
             (sock (with-fluids ((%default-port-encoding #f))
                     ;; Restrict ourselves to TCP.
                     (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_TCP))))
        (catch 'system-error
          (lambda ()
            (fcntl sock F_SETFL flags)
            ;; Disable Nagle's algorithm.
            (setsockopt sock IPPROTO_TCP TCP_NODELAY 1)
            ;; Buffer input and output on this port.
            (setvbuf sock 'block 1024)
            (when configure-socket
              (configure-socket sock))
            (connect sock (addrinfo:addr ai))

            ;; Buffer input and output on this port.
            (setvbuf sock 'block)
            ;; If we're using a proxy, make a note of that.
            (when http-proxy (set-http-proxy-port?! sock #t))
            sock)
          (lambda args
            ;; Connection failed, so try one of the other addresses.
            (close sock)
            (if (null? (cdr addresses))
                (apply throw args)
                (loop (cdr addresses))))))))

  (let ((sock (open-socket)))
    (when (and https? (current-https-proxy))
      (setup-http-tunnel sock uri))

    (if https?
        (tls-wrap sock (uri-host uri)
                  #:verify-certificate? verify-certificate?)
        sock)))
;; End of code snarfed from Guile.

(define %entropy-port (make-parameter #f))
(define (default-entropy-port)
  (or (%entropy-port)
      ;; TODO: Make cross-platform.
      (let ((port (open-input-file "/dev/urandom")))
        (%entropy-port port)
        port)))

(define (configure-socket/deprecated sock)
  (issue-deprecation-warning
   "open-websocket-for-uri: #:configure-socket is deprecated"))

(define* (open-websocket-for-uri uri #:key
                                 (flags SOCK_CLOEXEC)
                                 (configure-socket configure-socket/deprecated)
                                 (entropy-port (default-entropy-port))
                                 (verify-certificate? #t))
  "Connect to the WebSocket server at @var{uri} (either a URI object or a
string) and return an open client socket.

@var{flags} specifies the socket flags to be set.  By default, only
@code{SOCK_CLOEXEC} is set.  For asynchronous I/O, pass @code{(logior
SOCK_CLOEXEC SOCK_NONBLOCK)}.

The WebSocket protocol requires a source of random bytes:
@var{entropy-port}.  By default, entropy is sourced from
@file{/dev/urandom}.

When @var{verify-certificate?} is @code{#t} (the default),
@code{wss://} connections will have their TLS certificates verified."
  (define (coerce-uri uri-or-string)
    (match uri-or-string
      ((? uri? uri) uri)
      ((? string? uri) (string->uri uri))
      (_ (error "not a URI" uri-or-string))))
  ;; See Section 3 - WebSocket URIs
  (define (websocket-uri? uri)
    (and (uri? uri)
         (match (uri-scheme uri)
           ((or 'ws 'wss)
            (not (uri-fragment uri)))
           (_ #f))))
  (define (websocket-uri->http-uri uri)
    (build-uri (match (uri-scheme uri)
                 ('wss 'https)
                 ('ws 'http))
               #:userinfo (uri-userinfo uri)
               #:host (uri-host uri)
               #:port (uri-port uri)
               #:path (uri-path uri)
               #:query (uri-query uri)
               #:fragment (uri-fragment uri)
               #:validate? #t))
  ;; See Section 4.1 - Client Requirements
  (define (handshake uri sock)
    (let ((key (base64-encode (get-bytevector-n entropy-port 16))))
      ;; Send handshake request.
      (let* ((headers `((host . (,(uri-host uri) . #f))
                        (upgrade . ("WebSocket"))
                        (connection . (upgrade))
                        (sec-websocket-key . ,key)
                        (sec-websocket-version . "13")))
             (request (build-request uri #:method 'GET #:headers headers)))
        (write-request request sock)
        (force-output sock))
      ;; Read handshake response.
      (let* ((response (read-response sock))
             (headers (response-headers response))
             (upgrade (assoc-ref headers 'upgrade))
             (connection (assoc-ref headers 'connection))
             (accept (assoc-ref headers 'sec-websocket-accept)))
        ;; Validate the handshake.
        (cond
         ((and (= (response-code response) 101)
               (string-ci=? (car upgrade) "websocket")
               (equal? connection '(upgrade))
               (string=? (string-trim-both accept) (make-accept-key key)))
          (values))
         (else
          (close-port sock)
          (error "WebSocket handshake failed" uri))))))
  (let ((uri (coerce-uri uri)))
    (unless (websocket-uri? uri)
      (error "not a websocket URI" uri))
    (let ((sock (open-socket-for-uri (websocket-uri->http-uri uri)
                                     #:flags flags
                                     #:configure-socket configure-socket
                                     #:verify-certificate? verify-certificate?)))
      (handshake uri sock)
      sock)))

(define* (close-websocket ws #:key
                          (wait-for-port (lambda (port) 'ready))
                          (max-attempts 1)
                          (server-side? #f))
  "Close the WebSocket connection for the client port @var{ws}.

Client sockets are expected to wait for the server to close the
connection.  If @var{ws} is the server-side client socket, then
@var{server-side?} should be set to @code{#t}.

@var{wait-for-port} and @var{max-attempts} are as specified in
@var{read-data-frame}."
  (unless (port-closed? ws)
    (write-frame (make-close-frame (make-bytevector 0)) ws)
    ;; Per section 5.5.1, wait for the server to close the connection.
    (unless server-side?
      (let lp ((attempts 0))
        (when (< attempts max-attempts)
          (match (wait-for-port ws)
            ('ready
             (match (read-frame ws)
               ((or (? eof-object?) (? close-frame?))
                (values))
               (_ (lp attempts))))
            ('timeout (lp (1+ attempts)))))))
    (close-port ws))
  (values))

(define* (websocket-send ws data #:key
                         (mask? #t)
                         (entropy-port (and mask? (default-entropy-port))))
  "Send @var{data}, a string or bytevector, as a WebSocket data frame
over client port @var{ws}.

When @var{mask?} is @code{#t} (the default) then a masking key is
generated from @var{entropy-port}.  For the server-side client socket,
@var{mask?} should be set to @code{#f}."
  ;; TODO: Send frames over some threshold in fragments.
  (let ((masking-key (and mask? (get-bytevector-n entropy-port 4))))
    (write-frame (cond
                  ((string? data)
                   (make-text-frame data masking-key))
                  ((bytevector? data)
                   (make-binary-frame data masking-key))
                  (else (error "invalid WebSocket message" data)))
                 ws)
    (force-output ws)
    (values)))

(define* (websocket-receive ws #:key
                            (wait-for-port (lambda (port) 'ready))
                            (max-attempts 1)
                            echo-close?)
  "Read a WebSocket message from client port @var{ws} and return either a
string or a bytevector upon a successful read.  If the read times out
then return @code{#f}.  If the read hits the end of the @var{ws}
stream then return the EOF object.  If the server closes the
connection during the read then return the reason as a @code{(code
. reason)} pair.

The keyword arguments are the same as for @code{read-data-frame}."
  (and (not (port-closed? ws))
       (match (read-data-frame ws
                               #:wait-for-port wait-for-port
                               #:max-attempts max-attempts
                               #:echo-close? echo-close?)
         (#f #f)
         ((? eof-object? eof) eof)
         ((? close-frame? frame) (close-frame->status frame))
         ((? text-frame? frame) (utf8->string (frame-data frame)))
         ((? binary-frame? frame) (frame-data frame)))))
