bugafriend/bugafriend/ui.scm

(define-module (bugafriend ui)
  #:use-module (bugafriend utils registry)
  #:use-module (bugafriend user)
  #:use-module (bugafriend room)
  #:use-module (goblins)
  #:use-module (goblins vat)
  #:use-module (goblins ocapn ids)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (fibers conditions)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 suspendable-ports)
  #:export (say))

;; https://www.gnu.org/software/guile/manual/guile.html#Non_002dBlocking-I_002fO
(let* ((input (current-input-port))
       (flags (fcntl input F_GETFL)))
  (fcntl input F_SETFL (logior O_NONBLOCK flags)))
  (install-suspendable-ports!)


(define ocapn-registry #f)
(define user-actor #f)

(define (is-command? str)
  (and (> (string-length str) 0) (eq? (string-ref str 0) #\/)))

(define-record-type <console-command>
  (make-console-command name help thunk)
  console-command?
  (name console-command-name)
  (help console-command-help)
  (thunk console-command-thunk))

(define (get-a-room)
  ($ user-actor 'room-data))

(define commands
  (list
   (make-console-command
    "/quit"
    "- Exits the chat"
    (λ (args) (loop! #f)))
   (make-console-command
    "/help"
    "- Prints this help"
    (λ (args)
      (print-help)
      (loop! #t)))
   (make-console-command
    "/create"
    "- Create a new chat and join it."
    (λ (args)
      ($ user-actor 'make-room)
      (loop! #t)))
   (make-console-command
    "/me"
    "<text> - Me command, you like roleplay or whatever"
    (λ (args)
      (let* ((room-data (get-a-room))
             (room (room-data-room room-data))
             (presence (room-data-presence room-data)))
        ;; eww, maybe fix mangling the input by joining
        (<- room 'me presence (string-join args " "))
        (loop! #t))))
   (make-console-command
    "/join"
    "<room-id> - Switch chats to another room"
    (λ (args)
      (unless (eq? 2 (length args))
        (error "Need one argument, the room sturdyref!"))

      (let* ((room-id (list-ref args 1))
             (room-sref (string->ocapn-id room-id)))
        (unless room-sref
          (error "Badly formatted sturdyref!"))
        (unless ocapn-registry
          (error "Relay not yet connected."))

        (on (<- ocapn-registry 'enliven room-sref)
            (λ (r)
              ($ user-actor 'join-room r)
              (loop! #t))
            #:catch
            (λ (e)
              (format #t "Failed: ~a\n" e)
              (loop! #t))))))))

(define (print-help)
  (format #t "Command reference:\n")
  (map (λ (x) (format #t "  ~a ~a\n" (console-command-name x) (console-command-help x))) commands))

(define command-names (map console-command-name commands))

(define (%eval-command cmd)
  (define args (string-split cmd char-set:whitespace))
  (define matching-command (find (λ (x) (equal? (console-command-name x) (car args))) commands))
  (if matching-command
      ((console-command-thunk matching-command) args)
      (begin
        (format #t "Don't know how to handle ~a.\n\n" cmd)
        (print-help)
        (loop! #t))))

(define loop-channel (make-channel))
(define (loop! val) (put-message loop-channel val) val)

(define (%loop vat)
  (with-exception-handler
      (λ (e)
        (format #t "Command failed: ~s\n" e)
        (loop! #t))
    (λ ()
      (let ((line (read-line (current-input-port))))
        (with-vat vat
         (cond
          ((eq? 0 (string-length line)) (loop! #t))
          ((is-command? line)
           (%eval-command line))
          (else
           (let ((room-data (get-a-room)))
             (if room-data
                 (let ((room (room-data-room room-data))
                       (presence (room-data-presence room-data)))
                   (on (<- room 'say presence line)
                       (λ (val) (loop! val))))
                 (begin
                   (format #t "Not in a room yet. Use /create or /join <sturdyref>!\n")
                   (loop! #t)))))))))
    #:unwind? #t))

(define (say setup-sref name)
  (define vat (spawn-vat #:name "Speaker Vat"))

  ;;(set-readline-prompt! " 🐞 > ")

  (with-vat
   vat
   (format #t "Connecting to relay...\n")
   (on (prelay-sref->mycapn-registry setup-sref)
       (λ (r)
         (set! ocapn-registry r)
         (format #t "Connected. Creating user actor.\n")
         (set! user-actor (spawn ^user name ocapn-registry #f))
         (loop! #t))
       #:catch
       (λ (e)
         (format #t "Failed: ~a\n" e)
         (loop! #t))))

  (while (get-message loop-channel)
    (with-vat vat
     (syscaller-free-fiber
      (λ ()
        (%loop vat))))))