;;; Web-based REPL "server"
;;; Copyright (C) 2026 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; A web-based REPL "server" of sorts that communicates over a
;;; WebSocket.  The scare quotes around "server" are because web
;;; clients cannot be servers.  So, this web REPL instead connects to
;;; the Hoot development server (see the (hoot web-server) module)
;;; which acts as a relay, shuffling bytes to/from clients (telnet,
;;; Geiser in Emacs, etc.) connected over a simple TCP socket.  Client
;;; traffic is multiplexed over a single WebSocket connection.
;;;
;;; Code:

(library (hoot web-repl)
  (export current-repl-server
          run-web-repl)
  (import (fibers)
          (fibers channels)
          (fibers promises)
          (only (guile) format)
          (hoot bytevectors)
          (hoot eq)
          (hoot errors)
          (hoot hackable)
          (hoot hashtables)
          (hoot lists)
          (hoot match)
          (hoot modules)
          (hoot numbers)
          (hoot pairs)
          (hoot parameters)
          (hoot ports)
          (hoot read)
          (hoot repl)
          (hoot strings)
          (hoot symbols)
          (hoot syntax)
          (hoot values)
          (hoot write)
          (web fetch)
          (web request)
          (web response)
          (web socket)
          (web uri))

  (define current-repl-server (make-parameter "http://localhost:8080"))

  (define (repl-uri path)
    (string->uri (string-append (current-repl-server) path)))

  (define (get path)
    (fetch (build-request (repl-uri path))))

  (define (exp->bytevector exp)
    (let ((port (open-output-bytevector)))
      (write exp port)
      (get-output-bytevector port)))

  (define (post path exp)
    (fetch
     (build-request (repl-uri path)
                    #:method 'POST
                    #:body (exp->bytevector exp))))

  (define (ok? response)
    (<= 200 (response-code response) 299))

  (define server-load-path
    (case-lambda
      (()
       (define response (get "/repl/load-path"))
       (unless (ok? response)
         (error "failed to fetch load path"))
       (read (response-body response)))
      ((dir)
       (unless (ok? (post "/repl/load-path" dir))
         (error "failed to add to server load path"))
       (values))))

  (define (load-module-from-server root modname)
    (define modpath (string-join (map symbol->string modname) "/"))
    (define response (get (string-append "/repl/load/" modpath)))
    (unless (ok? response)
      (error "failed to load module from server" modname))
    (define (read-exps port)
      ;; TODO: Somehow get file/line info into the syntax objects.
      (match (read-syntax port)
        ((? eof-object?)
         (close-port port)
         '())
        (stx (cons stx (read-exps port)))))
    (load-module root (read-exps (response-body response))))

  ;; Write to `port`, read from `ch`.
  (define (make-multiplex-port id port ch)
    (define done? #f)
    (define pos 0)
    (define chunk #f)
    (define chunk-len 0)
    (define (read! dst start count)
      (if done?
          0
          (if (eq? pos chunk-len)
              (match (get-message ch)
                (#f
                 (set! done? #t)
                 (set! chunk #f)
                 (set! chunk-len 0)
                 (set! pos 0)
                 0)
                ((? bytevector? bv)
                 (set! chunk bv)
                 (set! chunk-len (bytevector-length bv))
                 (set! pos 0)
                 (read! dst start count)))
              (let ((len (min count (- chunk-len pos))))
                (bytevector-copy! dst start chunk pos (+ start len))
                (set! pos (+ pos len))
                len))))
    (define (write! src start count)
      (let ((bv (make-bytevector count)))
        (bytevector-copy! bv 0 src start count)
        (write `(write ,id ,bv) port)
        (flush-output-port port)
        count))
    (define (close!)
      (write `(close ,id) port)
      (flush-output-port port))
    (make-port #:read read!
               #:write write!
               #:close close!
               #:repr "Multiplex"))

  (define (repl-url)
    (string-append (current-repl-server) "/repl"))

  (define (run-web-repl)
    (define-syntax-rule (log str arg ...)
      (begin
        (format #t str arg ...)
        (newline)))
    (let ((ws (websocket (repl-url))))
      (log "Connected to REPL server")
      (define repls (make-eqv-hashtable))
      (define (spawn-repl* id)
        (let* ((repl (make-repl))
               (ch (make-channel))
               (port (make-multiplex-port id ws ch)))
          (hashtable-set! repls id ch)
          (log "REPL #~a connected" id)
          (parameterize ((current-input-port port)
                         (current-output-port port)
                         (current-error-port port)
                         (current-load-path server-load-path)
                         (current-module-loader load-module-from-server))
            (run-repl repl))
          (close-port port)
          (hashtable-delete! repls id)
          (log "REPL #~a disconnected" id)))
      (let lp ()
        (match (read ws)
          ((? eof-object?)
           (hashtable-for-each (lambda (id ch)
                                 (spawn-fiber
                                  (lambda ()
                                    (put-message ch #f))))
                               repls))
          (('new id)
           (spawn-fiber (lambda () (spawn-repl* id)))
           (lp))
          (('write id bv)
           (match (hashtable-ref repls id)
             (#f (values))
             (ch
              (spawn-fiber
               (lambda ()
                 (put-message ch bv)))))
           (lp))
          (('close id)
           (match (hashtable-ref repls id)
             (#f (values))
             (ch
              (spawn-fiber
               (lambda ()
                 (put-message ch #f)))
              (hashtable-delete! repls id)))
           (lp))))
      (close-port ws)
      (log "Disconnected from REPL server"))))
