;;;; remote-mailbox-test.scm

;; Issues
;;
;; - should run multiple nodes; N senders M recievers

(import test)

(import (only (chicken format) format))
(include-relative "test-gloss.incl")

(import scheme
  (chicken base)
  (chicken process-context)
  (chicken process)
  (only (chicken condition) condition->list)
  (srfi 1)
  (srfi 18)
  miscmacros
  exn-condition
  mailbox
  #;remote-mailbox-adapter
  remote-mailbox-client
  remote-mailbox-server
  remote-mailbox-service)

;; Utilities

(define (remote-mailbox-service-server)
  (receive (s t) (remote-mailbox-service-info) s) )

(define (remote-mailbox-service-mailboxes)
  (server-local-mailboxes (remote-mailbox-service-server)) )

;; remote-message "type"

;Use "small" values for known types
(define-constant MESSAGE -1)
(define-constant RECIPIENT 1)
(define-constant ID 2)

(define-syntax remote-message
  (syntax-rules ()
    ;
    ((remote-message)
      '(message) )
    ;
    ((remote-message (message ?attr0 ...) ?key0 ?val0 ?rest ...)
     (remote-message (message (,?key0 . ,?val0) ?attr0 ...) ?rest ...)  )
    ;
    ((remote-message ?key0 ?val0 ?rest ...)
      (remote-message (message (,?key0 . ,?val0)) ?rest ...) )
    ;
    ((remote-message (message ?attr0 ...))
     `(,MESSAGE ?attr0 ...) ) ) )

(define-syntax remote-message?
  (syntax-rules (_obj)
    ((remote-message? ?obj)
      (let ((_obj ?obj))
        (and (pair? _obj) (eqv? MESSAGE (car _obj))) ) ) ) )

(define-syntax remote-message-attribute
  (syntax-rules (_msg _res)
    ((remote-message-attribute ?msg ?key)
      (and-let* ((_msg ?msg)
                 (_res (assv ?key (cdr _msg))) )
         (cdr _res) ) ) ) )

;;

(define ((remote-send-to rmb) msg)
  ;(glossf "Sending |~S| to ~S" msg MB-NAM)
  (remote-mailbox-send! rmb msg) )

(define (log-exn ex who)
  (format #t "~A: ~A~%" who (condition->list ex))
  (void) )

;;

; A message can be any object

;Enforces 1 mailbox, in server & client

;sender (client) can talk to many servers
(define (sender mb-nam msg-cnt rcv-nam)
  (glossf "*** Sender start")
  (define rmb (make-remote-mailbox mb-nam))
  (define sendit (remote-send-to rmb))
  (test-assert (remote-mailbox? rmb))
  (test-assert (procedure? sendit))
  ;must test in client
  ;(glossf "remote-mailboxes: ~S" (remote-mailboxes))
  (test-assert (list? (remote-mailboxes)))
  (test "only one remote-mailbox" 1 (length (remote-mailboxes)))
  ;
  (glossf "*** Sending ~A messages, then quit" msg-cnt)
  (handle-exceptions ex
    ;Should be looked into...
    (log-exn ex "Sender")
    ;
    (dotimes (n msg-cnt) (sendit (remote-message RECIPIENT rcv-nam ID n)))
    (sendit '()) )
  (glossf "*** Sender quit") )

;receiver (server) can talk to many clients
(define (receiver mb-nam msg-cnt rcv-nam)
  (glossf "*** Receiver start")
  (define mb (remote-mailbox-service mb-nam #t rcv-nam)) ;name is optional
  (test-assert (mailbox? mb))
  ;must test in server
  ;(glossf "server-local-mailboxes: ~S" (remote-mailbox-service-mailboxes))
  (test-assert (list? (remote-mailbox-service-mailboxes)))
  (test "only one remote-mailbox" 1 (length (remote-mailbox-service-mailboxes)))
  ;
  (glossf "*** Receiving messages until quit...")
  (handle-exceptions ex
    ;Should be looked into...
    (log-exn ex "Receiver")
    ;
    (let receive-loop ((n 0))
      (define msg (mailbox-receive! mb))
      ;(glossf "Received |~S| from ~S" msg mb-nam)
      (if (not (remote-message? msg))
          (begin
            (test-assert (null? msg))
            (test "received all messages" msg-cnt n) )
          (begin
            (test "recipient checks" rcv-nam (remote-message-attribute msg RECIPIENT))
            (test "message id checks" n (remote-message-attribute msg ID))
            (receive-loop (add1 n)) ) ) )
    (glossf "*** Receiver quit") ) )

;;;

(define-constant NUM-MSG 5)

(define-constant RCV-NAM "Wong Foo")
(define-constant MB-NAM 'wong-foo)

(define (perform-operation op)
  (case op
    ((sender)
      (sender MB-NAM NUM-MSG RCV-NAM) )
    ((receiver)
      (receiver MB-NAM NUM-MSG RCV-NAM)
      (glossf "*** Stopping remote-mailbox-service")
      (remote-mailbox-service-stop!) )
    (else
      (error 'perform-operation "unrecognized operation" op) ) ) )

(define (perform-test cmd)
  ;the "server" MUST be started before the client!
  (glossf "Running Receiver: ~S" cmd)
  ;csi args are ignored by this as a compiled binary - last arg is ours
  (process-run cmd `("-n" "-s" ,(program-name) "receiver"))
  ;wait for receiver to startup, since this process continuing as `sender'
  (sleep 1)
  ;then start the sender
  (glossf "Running Sender: ~S" cmd)
  (perform-operation 'sender)
  #; ;this process not continuing - doesn't require wait as above
  (process-execute cmd `("-n" "-s" ,(program-name) "sender")) )

;;;

(define *operation*
  (let ((args (command-line-arguments)))
    (and (pair? args)
         (string->symbol (last args))) ) )

(if *operation*
    ;then know what to do
    (perform-operation *operation*)
    ;else test w/ this binary
    (perform-test (executable-pathname)) )