;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 server.
;;
;;; Code:

(define-module (8sync systems websocket server)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (oop goops)
  #:use-module (8sync)
  #:use-module (8sync ports)
  #:use-module (8sync systems web)
  #:use-module (8sync systems websocket client)
  #:use-module (8sync systems websocket frame)
  #:use-module (8sync systems websocket utils)
  #:export (<websocket-server>))

(define (make-handshake-response client-key)
  "Return an HTTP response object for upgrading to a WebSocket
connection for the client whose key is CLIENT-KEY, a base64 encoded
string."
  ;; See section 4.2.2.
  (let ((accept-key (make-accept-key (string-trim-both client-key))))
    (build-response #:code 101
                    #:headers `((upgrade . ("websocket"))
                                (connection . (upgrade))
                                (sec-websocket-accept . ,accept-key)))))

(define no-op (const #f))

(define-actor <websocket-server> (<web-server>)
  ()
  (upgrade-paths #:init-value `(("websocket" .
                                 ,(wrap-apply make-websocket-actor)))
                 #:allocation #:each-subclass
                 #:accessor .upgrade-paths)

  (on-ws-connection #:init-keyword #:on-ws-connection
                    #:init-value no-op
                    #:getter .on-ws-connection)

  (on-ws-close #:init-keyword #:on-ws-close
                    #:init-value no-op
                    #:getter .on-ws-close)
  (on-ws-error #:init-keyword #:on-ws-error
                    #:init-value no-op
                    #:getter .on-ws-error)
  (on-ws-message #:init-keyword #:on-ws-message
                    #:init-value no-op
                    #:getter .on-ws-message)
  (on-ws-open #:init-keyword #:on-ws-open
                    #:init-value no-op
                    #:getter .on-ws-open))

(define (make-websocket-actor websocket-server client request body)
  "Setup websocket actor connected via CLIENT by performing the HTTP
handshake."

  ;; Disable buffering for websockets
  (setvbuf client 'none)

  ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
  (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
         (response (make-handshake-response client-key)))
    (write-response response client))

  (let* ((websocket-id (create-actor websocket-server <websocket>
                                     #:socket client
                                     #:state 'open
                                     #:on-close (.on-ws-close websocket-server)
                                     #:on-error (.on-ws-error websocket-server)
                                     #:on-message (.on-ws-message websocket-server)
                                     #:on-open (.on-ws-open websocket-server)))
         (hive ((@@ (8sync actors) actor-hive) websocket-server))
         (websocket ((@@ (8sync actors) hive-resolve-local-actor) hive websocket-id)))
    ((.on-ws-connection websocket-server) websocket-id)
    (websocket-loop websocket 'message)))