(import scheme (chicken base) (chicken format) (chicken memory) (chicken blob)
        zmq  test  srfi-1 srfi-18 srfi-4)

(test-group "contexts"
  (test-assert (context? (make-context 1)))
  (test-error (make-context -1)))

(define make-bound-socket-pair
  (let ((count 0))
    (lambda (server client)
      (let ((s (make-socket server))
            (c (make-socket client))
            (e (sprintf "inproc://test~A" count)))
        (bind-socket s e)
        (connect-socket c e)
        (set! count (add1 count))
        (values s c)))))

(test-group "sockets"

  (test-group "default-context"
    (test-assert (not (zmq-default-context)))
    (make-socket 'rep)
    (test-assert (context? (zmq-default-context))))

  (test-group "options"
    (let ((s (make-socket 'pull)))
      (test 1000 (socket-option s 'rcvhwm))
      (socket-option-set! s 'rcvhwm 2000)
      (test 2000 (socket-option s 'rcvhwm))
      (socket-option-set! s 'identity "nomnom")
      (test "nomnom" (socket-option s 'identity))
      (test-assert (number? (socket-fd s)))))

  (test-group "push/pull"
    (receive (push pull) 
             (make-bound-socket-pair 'push 'pull)
      (send-message push "hey")
      (test "hey" (receive-message pull))
      (send-message push "ho")
      (test "ho" (receive-message pull))
      (test-error (receive-message push))
      (test-error (send-message pull "impossible"))))

  (test-group "pub/sub"
    (receive (pub sub)
        (make-bound-socket-pair 'pub 'sub)
      (socket-option-set! sub 'subscribe "foo")
      (send-message pub "foo bar!")
      (test "foo bar!" (receive-message sub))
      (send-message pub "bar!")
      (test-assert (not (receive-message sub non-blocking: #t)))))

  (test-group "rep/req"
    (receive (rep req)
        (make-bound-socket-pair 'rep 'req)
      (send-message req "foo")
      (test "foo" (receive-message rep))
      (send-message rep "bar")
      (test "bar" (receive-message req))
      (test-error (receive-message req))
      (test-error (send-message rep "nope"))))

  (test-group "non-blocking read"
    (receive (a b)
        (make-bound-socket-pair 'push 'pull)
      (test-assert (not (receive-message b non-blocking: #t)))
      (send-message a "foo bar!")
      (test "foo bar!" (receive-message b non-blocking: #t))))

  ;; this is to test the context finalizer; if it doesn't work, a
  ;; double-free error will be raised after the tests have finished
  (define some-socket (make-socket 'push))
  (close-socket some-socket))

(test-group "polling"
  (receive (a b)
      (make-bound-socket-pair 'push 'pull)

    (let* ((c (make-socket 'pull))
           (d (make-socket 'pull))
           (pis (map (cut make-poll-item <> in: #t) (list b c d))))

      (test 0 (poll pis #f))
      (send-message a "check")
      (test 1 (poll pis #t))
      (test 1 (length (filter poll-item-in? pis))))))

(test-group "messages"
  (receive (a b)
      (make-bound-socket-pair 'push 'pull)

    (send-message a "hey")

    (let ((c (receive-message b as: cons)))
      (test-assert (pointer? (car c)))
      (test 3 (cdr c)))

    (send-message a "ho")
    (test (string->blob "ho") (receive-message b as: 'blob))

    (send-message a (u8vector->blob (u8vector 102 111 111)))
    (test "foo" (receive-message b))))

(test-group "receiving messages blockingly without blocking the whole process"
  (receive (a b)
      (make-bound-socket-pair 'push 'pull)

    (thread-start! 
     (lambda ()
       (test "yes" (receive-message* b))))

    ;; yes that is kind of silly but I have no better idea to test it
    ;; -- patches welcome!
    (thread-sleep! 0.5)
    (send-message a "yes")
    (thread-sleep! 0.5)))

(test-exit)