bugafriend/bugafriend/ui.scm

(define-module (bugafriend ui)
  #:use-module (bugafriend utils registry)
  #:use-module (bugafriend utils concurrent-queue)
  #:use-module (bugafriend event-loop)
  #:use-module (bugafriend ncurses stuff)
  #:use-module (bugafriend ncurses vat)
  #:use-module (bugafriend logging)
  #:use-module (ncurses curses)
  #: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)
  #:use-module (system repl coop-server)
  #:declarative? #f
  #:export (run-client))

(define %BACKSPACE 263)
(define screen (screen-setup!))

;; Can we use the goblins queue actor instead?
(define tasks (make-concurrent-queue))

(define user-vat #f)
(define ui-vat #f)
(define prompt-input '())

(define logger #f)

(define ocapn-registry #f)
(define user-actor #f)
(define setup-sref #f)
(define username #f)

(define title-win #f)
(define log-win #f)
(define prompt-win #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 (refresh-prompt)
  (define size (getmaxyx screen))
  (define height (list-ref size 0))
  (define width (list-ref size 1))
  (define prompt-str (list->string (reverse prompt-input)))
  (define prompt-str-len (string-length prompt-str))
  (define max-prompt-to-show (- width 4))
  (clear prompt-win)
  (hline prompt-win (acs-hline) width #:x 0 #:y 0)
  (addch prompt-win
         (color %YELLOW-N (bold #\>))
         #:x 1 #:y 1)
  (addstr prompt-win
          ;; cut off the length of the string shown, if the user has typed a lot
          (if (> prompt-str-len max-prompt-to-show)
              (let ((str-start (- prompt-str-len max-prompt-to-show)))
                (substring prompt-str str-start))
              prompt-str)
          #:x 3 #:y 1)
  (resize log-win (- height 2) width)
  (resize prompt-win 2 width)
  (mvwin prompt-win (- height 2) 0)
  (move prompt-win 1 (+ 3 (length prompt-input)))
  (refresh prompt-win))


(define commands
  (list
   (make-console-command
    'quit
    "- Exits the chat"
    ;; TODO
    (λ (args) #f))
   (make-console-command
    'help
    "- Prints this help"
    (λ (args)
      (print-help)))
   (make-console-command
    'create
    "- Create a new chat and join it."
    (λ (args)
      ($ user-actor 'make-room)
      (on (<- ocapn-registry 'register ($ user-actor 'room))
          (λ (id)
            (format #t "Logger: ~s\n" logger)
            (log-str logger (format #f "Room ID: ~a" (ocapn-id->string id)))))))
   (make-console-command
    'me
    "<text> - Me command, you like roleplay or whatever"
    (λ (args)
        ;; eww, maybe fix mangling the input by joining
      (say-command 'me (string-join args " "))))
   (make-console-command
    'join
    "<room-id> - Switch chats to another room"
    (λ (args)
      (if (eq? 2 (length args))
          (let* ((room-id (list-ref args 1))
                 (room-sref (string->ocapn-id room-id)))
            (if room-sref
                (if ocapn-registry
                    (on (<- ocapn-registry 'enliven room-sref)
                        (λ (r)
                          ($ user-actor 'join-room r))
                        #:catch
                        (λ (e)
                          (log-format logger "Failed: ~a" e)))
                    (log-str logger "Relay not yet connected."))
                (log-str logger "Badly formatted sturdyref!")))
          (log-str logger "Need one argument, the room sturdyref!"))))))

(define (say-command line method)
  "The implicit command"
  (let ((room ($ user-actor 'room))
        (presence ($ user-actor 'presence)))
    (if (and room presence)
        (<-np room method presence line)
        (log-str logger "Not in a room yet. Use /create or /join <sturdyref>!"))))

(define (print-help)
  (log-str logger "Command reference:")
  (map (λ (x) (log-format logger "  ~a ~a" (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 first-arg (car args))

  (define (find-matching-command)
    (and first-arg
         (is-command? first-arg)
         (find (λ (x) (equal? (symbol->string (console-command-name x)) (substring first-arg 1))) commands)))

  (with-vat user-vat
   (let ((matching-command (find-matching-command)))
     (cond
      (matching-command
       ((console-command-thunk matching-command) args))
      ((= 0 (string-length cmd) #f))
      (else (say-command cmd 'say))))))

(define (init screen)
  (define size (getmaxyx screen))
  (define height (list-ref size 0))
  (define width (list-ref size 1))
  (define prompt-height 2)
  (set! prompt-win
        (newwin prompt-height width (- height prompt-height) 0))
  (set! log-win
        (newwin (- height prompt-height)
                width 0 0))
  (scrollok! log-win #t)
  (idcok! log-win #t)
  (setscrreg! log-win 0 (- height prompt-height))
  (move log-win (getmaxy log-win) 0)

  (with-vat user-vat
   (set! logger (spawn ^logger log-win prompt-win))
   (set! user-actor (spawn ^user logger username #f))
   (log-str logger "Connecting to relay...")
   (on (prelay-sref->mycapn-registry setup-sref)
       (λ (r)
         (set! ocapn-registry r)
         (log-str logger "Connected."))
       #:catch
       (λ (e)
         (log-format logger "Failed: ~a" e))))

    (add-task! tasks refresh-prompt))

(define (handle-input screen char)
  (cond
   ;; Exit
   ((or (eqv? char #\esc) (eqv? char #\etx))
    (halt-event-loop))
   ;; Resized window
   ((eqv? char KEY_RESIZE)
    (add-task! tasks refresh-prompt))
   ;; Backspace
   ((or (eqv? char %BACKSPACE) (eqv? char #\delete))
    (set! prompt-input (match prompt-input
                         (() '())
                         ((_ chars ...) chars))))
   ;; Submit command
   ((eqv? char #\newline)
    (let ((input (string-trim-both (list->string (reverse prompt-input)))))
      (unless (string-null? input)
        (%eval-command input))
      (set! prompt-input '())))
   ;; Add a char to the command line
   ((and (char? char)                   ; some "characters" might be integers
         (char-set-contains? char-set:printing char))
    (set! prompt-input (cons char prompt-input))))
  (refresh-prompt))

(define-syntax-rule (trampoline proc args ...)
  (lambda (args ...)
    (proc args ...)))

(define (run-client setup name)
  (parameterize ((current-output-port (%make-void-port "w")))
    (set! user-vat (spawn-vat #:name "User" #:log? #t))
    (set! ui-vat (spawn-ncurses-vat tasks #:name "UI" #:log? #t)))

  (set! username name)
  (set! setup-sref setup)

  (run-event-loop
     #:init (trampoline init screen)
     #:handle-input (trampoline handle-input screen char)
     #:tasks tasks
     #:repl (false-if-exception (spawn-coop-repl-server))
     #:screen screen))