PageRenderTime 53ms CodeModel.GetById 2ms app.highlight 45ms RepoModel.GetById 1ms app.codeStats 1ms

/src/zmq.lisp

https://github.com/nubgames/lisp-zmq
Lisp | 481 lines | 428 code | 53 blank | 0 comment | 11 complexity | 102ebbf98446415351bb1f90e1dc516a MD5 | raw file
  1
  2(in-package :zmq)
  3
  4(defvar *errors* (make-hash-table)
  5  "A table mapping error numbers to their condition class")
  6
  7(define-condition zmq-error (error)
  8  ((code
  9    :initarg :code
 10    :reader zmq-error-code
 11    :documentation "The numeric error code.")
 12   (description
 13    :initarg :description
 14    :reader zmq-error-description
 15    :documentation "The description of the error."))
 16  (:report (lambda (condition stream)
 17             (with-slots (code description) condition
 18               (format stream "ZMQ error ~A: ~A." code description))))
 19  (:documentation "A ZMQ error."))
 20
 21(defmacro define-error (name error-value)
 22  `(progn
 23     (define-condition ,name (zmq-error)
 24       ()
 25       (:report (lambda (condition stream)
 26                  (with-slots (description) condition
 27                    (format stream "ZMQ error: ~A." description))))
 28       (:documentation ,(concatenate 'string
 29                                     "The error associated to the "
 30                                     (symbol-name error-value)
 31                                     " error code.")))
 32     (setf (gethash ,error-value *errors*) ',name)))
 33
 34(define-error einval-error :einval)
 35(define-error enodev-error :enodev)
 36(define-error eintr-error :eintr)
 37(define-error efault-error :efault)
 38(define-error enomem-error :enomem)
 39(define-error eagain-error :eagain)
 40(define-error emfile-error :emfile)
 41(define-error enotsup-error :enotsup)
 42(define-error eprotonosupport-error :eprotonosupport)
 43(define-error enobufs-error :enobufs)
 44(define-error enetdown-error :enetdown)
 45(define-error eaddrinuse-error :eaddrinuse)
 46(define-error eaddrnotavail-error :eaddrnotavail)
 47(define-error econnrefused-error :econnrefused)
 48(define-error einprogress-error :einprogress)
 49(define-error enotsock-error :enotsock)
 50(define-error efsm-error :efsm)
 51(define-error enocompatproto-error :enocompatproto)
 52(define-error eterm-error :eterm)
 53(define-error emthread-error :emthread)
 54
 55(defun call-ffi (invalid-value function &rest args)
 56  "Call a low-level function and check its return value. If the return value
 57is equal to INVALID-VALUE, a suitable error is signaled. When the error code
 58tells that the function was interrupted by a signal (EINTR), the function is
 59called until it succeeds. In any case, the return value of the low-level
 60function is returned."
 61  (tagbody retry
 62     (let ((value (apply function args)))
 63       (if (eq value invalid-value)
 64           (let* ((error-code (%errno))
 65                  (description (%strerror error-code))
 66                  (keyword (foreign-enum-keyword 'error-code error-code
 67                                                 :errorp nil))
 68                  (condition (gethash keyword *errors* 'zmq-error)))
 69             (case keyword
 70               (:eintr (go retry))
 71               (t (error condition :code (or keyword error-code)
 72                                   :description description))))
 73           (return-from call-ffi value)))))
 74
 75(defun version ()
 76  "Return the version of the ZMQ library, a list of three integers (major,
 77  minor and patch version)."
 78  (with-foreign-objects ((%major :int) (%minor :int) (%patch :int))
 79    (%version %major %minor %patch)
 80    (list (mem-ref %major :int) (mem-ref %minor :int) (mem-ref %patch :int))))
 81
 82(defun init (io-threads)
 83  "Create and return a new context."
 84  (call-ffi (null-pointer) '%init io-threads))
 85
 86(defun term (context)
 87  "Terminate and release a context"
 88  (call-ffi -1 '%term context))
 89
 90(defmacro with-context ((var io-threads) &body body)
 91  "Evaluate BODY in an environment where VAR is bound to a context created
 92with IO-THREADS threads."
 93  `(let ((,var (init ,io-threads)))
 94     (unwind-protect
 95          (progn ,@body)
 96       (term ,var))))
 97
 98(defclass socket ()
 99  ((%socket
100    :accessor socket-%socket
101    :initarg :%socket
102    :documentation "A foreign pointer to the underlying zeromq socket.")
103   (lock
104    :accessor socket-lock
105    :initarg :lock
106    :initform nil
107    :documentation "A lock used for thread-safe sockets, or NIL if the socket
108    isn't thread-safe."))
109  (:documentation "A zeromq socket."))
110
111(defun socket (context type &key thread-safe)
112  "Create and return a new socket. If THREAD-SAFE is not NIL, the socket will
113be protected against concurrent access."
114  (make-instance 'socket
115                 :%socket (call-ffi (null-pointer)
116                                    '%socket context
117                                    (foreign-enum-value 'socket-type type))
118                 :lock (when thread-safe
119                         (bordeaux-threads:make-recursive-lock))))
120
121(defmacro with-socket-locked ((socket) &body body)
122  "Evaluate BODY in an environment where SOCKET is protected against
123  concurrent access."
124  `(if (socket-lock ,socket)
125       (bordeaux-threads:with-recursive-lock-held ((socket-lock ,socket))
126         ,@body)
127       (progn
128         ,@body)))
129
130(defun close (socket)
131  "Close and release a socket."
132  (with-socket-locked (socket)
133    (call-ffi -1 '%close (socket-%socket socket))))
134
135(defmacro with-socket ((var context type &key thread-safe) &body body)
136  "Evaluate BODY in an environment where VAR is bound to a socket created in
137context CONTEXT with type TYPE. Key arguments are the same as the arguments of
138SOCKET."
139  `(let ((,var (socket ,context ,type :thread-safe ,thread-safe)))
140     (unwind-protect
141          (progn ,@body)
142       (close ,var))))
143
144(defmacro with-sockets (bindings &body body)
145  (if bindings
146      `(with-socket ,(car bindings)
147         (with-sockets ,(cdr bindings)
148           ,@body))
149      `(progn ,@body)))
150
151(defun bind (socket endpoint)
152  "Bind SOCKET to the address ENDPOINT."
153  (with-foreign-string (%endpoint endpoint)
154    (with-socket-locked (socket)
155      (call-ffi -1 '%bind (socket-%socket socket) %endpoint))))
156
157(defun connect (socket endpoint)
158  "Connect SOCKET to the address ENDPOINT."
159  (with-foreign-string (%endpoint endpoint)
160    (with-socket-locked (socket)
161      (call-ffi -1 '%connect (socket-%socket socket) %endpoint))))
162
163(defvar *socket-options-type* (make-hash-table)
164  "A table to store the foreign type of each socket option.")
165
166(defun define-sockopt-type (option type &optional (length (foreign-type-size type)))
167  (setf (gethash option *socket-options-type*) (list type length)))
168
169(define-sockopt-type :hwm :uint64)
170(define-sockopt-type :swap :int64)
171(define-sockopt-type :affinity :uint64)
172(define-sockopt-type :identity :char 255)
173(define-sockopt-type :subscribe :char)
174(define-sockopt-type :unsubscribe :char)
175(define-sockopt-type :rate :int64)
176(define-sockopt-type :recovery-ivl :int64)
177(define-sockopt-type :recovery-ivl-msec :int64)
178(define-sockopt-type :mcast-loop :int64)
179(define-sockopt-type :sndbuf :uint64)
180(define-sockopt-type :rcvbuf :uint64)
181(define-sockopt-type :rcvmore :int64)
182(define-sockopt-type :fd #+win32 win32-socket
183                         #-win32 :int)
184(define-sockopt-type :events :uint32)
185(define-sockopt-type :type :int)
186(define-sockopt-type :linger :int)
187(define-sockopt-type :reconnect-ivl :int)
188(define-sockopt-type :backlog :int)
189(define-sockopt-type :reconnect-ivl-max :int)
190
191(defun getsockopt (socket option)
192  "Get the value currently associated to a socket option."
193  (when (member option '(:subscribe :unsubscribe))
194    (error "Socket option ~A is write only." option))
195  (let ((info (gethash option *socket-options-type*)))
196    (unless info
197      (error "Unknown socket option ~A." option))
198    (destructuring-bind (type length) info
199      (with-foreign-objects ((%value type length) (%size 'size-t))
200        (with-socket-locked (socket)
201          (setf (mem-ref %size 'size-t) length)
202          (call-ffi -1 '%getsockopt (socket-%socket socket) option %value %size))
203        (case option
204          (:identity
205           (let ((size (mem-ref %size 'size-t)))
206             (when (> size 0)
207               (foreign-string-to-lisp %value :count size))))
208          (:events
209           (foreign-bitfield-symbols 'event-types (mem-ref %value type)))
210          (t
211           (mem-ref %value type)))))))
212
213(defun setsockopt (socket option value)
214  "Set the value associated to a socket option."
215  (let ((info (gethash option *socket-options-type*)))
216    (unless info
217      (error "Unknown socket option: ~A." option))
218    (destructuring-bind (type length) info
219      (case option
220        ((:subscribe :unsubscribe :identity)
221         (let ((length (length value)))
222           (with-foreign-object (%value :char (+ length 1))
223             (lisp-string-to-foreign value %value (+ length 1))
224             (with-socket-locked (socket)
225               (call-ffi -1 '%setsockopt (socket-%socket socket) option
226                         %value length)))))
227        (t
228         (with-foreign-object (%value type length)
229           (setf (mem-ref %value type) (case option
230                                         (:events (foreign-bitfield-value
231                                                   'event-types value))
232                                         (t value)))
233           (with-socket-locked (socket)
234             (call-ffi -1 '%setsockopt (socket-%socket socket) option
235                       %value length))))))))
236
237(defun socket-fd (socket)
238  "Return the file descriptor associated with SOCKET. This file descriptor can
239  be used to integrate SOCKET into an existing event loop. Look at the
240  official documentation of ZMQ_FD for getsockopt() for more information."
241  (getsockopt socket :fd))
242
243(defun socket-events (socket)
244  "Return a list of events representing the current event state of
245  SOCKET. Look at the official documentation of ZMQ_EVENTS for getsockopt()
246  for more information."
247  (getsockopt socket :events))
248
249(defun device (type frontend backend)
250  "Connect a frontend socket to a backend socket. This function always returns
251-1."
252  (with-socket-locked (frontend)
253    (with-socket-locked (backend)
254      (call-ffi 0 '%device (foreign-enum-value 'device-type type)
255                (socket-%socket frontend) (socket-%socket backend)))))
256
257(defun msg-init-fill (message data &key (encoding *default-foreign-encoding*))
258  "Initialize, fill and return a message. If DATA is a string, convert it to a
259byte array."
260  (etypecase data
261    (string
262     (with-foreign-string ((%string length) data :encoding encoding)
263       (call-ffi -1 '%msg-init-size message (- length 1))
264       (%memcpy (%msg-data message) %string (- length 1))))
265    ((simple-array (unsigned-byte 8))
266     (with-pointer-to-vector-data (ptr data)
267       (let ((length (length data)))
268         (call-ffi -1 '%msg-init-size message length)
269         (%memcpy (%msg-data message) ptr length))))
270    (vector
271     (let ((length (length data)))
272       (call-ffi -1 '%msg-init-size message length)
273       (let ((%data (%msg-data message)))
274         (do ((i 0 (1+ i)))
275             ((= i length))
276           (setf (mem-aref %data :uchar i) (aref data i))))))))
277
278(defun msg-init ()
279  "Create and return a new empty message."
280  (let ((%message (foreign-alloc '(:struct msg))))
281    (handler-case
282        (progn
283          (call-ffi -1 '%msg-init %message)
284          %message)
285      (error (cond)
286        (foreign-free %message)
287        (error cond)))))
288
289(defun msg-init-size (size)
290  "Create and return a new message initialized to a fixed size SIZE."
291  (let ((%message (foreign-alloc '(:struct msg))))
292    (handler-case
293        (progn
294          (call-ffi -1 '%msg-init-size %message size)
295          %message)
296      (error (cond)
297        (foreign-free %message)
298        (error cond)))))
299
300(defun msg-init-data (data &key (encoding *default-foreign-encoding*))
301  "Create and return a new message initialized and filled with DATA. If DATA
302is a string, it is encoded using the character coding schema ENCODING."
303  (let ((%message (foreign-alloc '(:struct msg))))
304    (handler-case
305        (progn
306          (msg-init-fill %message data :encoding encoding)
307          %message)
308      (error (cond)
309        (foreign-free %message)
310        (error cond)))))
311
312(defun msg-close (message)
313  "Release a message, freeing any memory allocated for the message."
314  (unwind-protect
315       (call-ffi -1 '%msg-close message)
316    (foreign-free message)))
317
318(defmacro with-msg-init ((var) &body body)
319  "Evaluate BODY in an environment where VAR is bound to a new empty message."
320  `(with-foreign-object (,var '(:struct msg))
321     (call-ffi -1 '%msg-init ,var)
322     (unwind-protect
323          (progn ,@body)
324       (ignore-errors (call-ffi -1 '%msg-close ,var)))))
325
326(defmacro with-msg-init-size ((var size) &body body)
327  "Evaluate BODY in an environment where VAR is bound to a new message of size
328SIZE."
329  `(with-foreign-object (,var '(:struct msg))
330     (call-ffi -1 '%msg-init-size ,var ,size)
331     (unwind-protect
332          (progn ,@body)
333       (ignore-errors (call-ffi -1 '%msg-close ,var)))))
334
335(defmacro with-msg-init-data ((var data
336                               &key (encoding *default-foreign-encoding*))
337                              &body body)
338  "Evaluate BODY in an environment where VAR is bound to a new message filled
339with DATA. If DATA is a string, it is encoded using the character coding
340schema ENCODING."
341  `(with-foreign-object (,var '(:struct msg))
342     (msg-init-fill ,var ,data :encoding ,encoding)
343     (unwind-protect
344          (progn ,@body)
345       (ignore-errors (call-ffi -1 '%msg-close ,var)))))
346
347(defun msg-size (message)
348  "Return the size in byte of the content of MESSAGE."
349  (%msg-size message))
350
351(defun msg-data (message)
352  "Get a foreign pointer on the content of MESSAGE."
353  (%msg-data message))
354
355(defun msg-data-array (message)
356  "Get the content of MESSAGE as an unsigned byte array."
357  (let ((data (%msg-data message)))
358    (unless (null-pointer-p data)
359      (let* ((length (msg-size message))
360             (array (make-array length :element-type '(unsigned-byte 8))))
361        (with-pointer-to-vector-data (%array array)
362          (%memcpy %array data length))
363        array))))
364
365(defun msg-data-string (message &key (encoding *default-foreign-encoding*))
366  "Get the content of MESSAGE as a character string. The string is decoded
367using the character coding schema ENCODING."
368  (let ((data (%msg-data message)))
369    (unless (null-pointer-p data)
370      (foreign-string-to-lisp data
371                              :count (%msg-size message)
372                              :encoding encoding))))
373
374(defun msg-copy (destination source)
375  "Copy the content of the message SOURCE to the message DESTINATION."
376  (call-ffi -1 '%msg-copy destination source))
377
378(defun msg-move (destination source)
379  "Move the content of the message SOURCE to the message DESTINATION. After
380the call, SOURCE is an empty message."
381  (call-ffi -1 '%msg-move destination source))
382
383(defun send (socket message &optional flags)
384  "Queue MESSAGE to be sent on SOCKET."
385  (with-socket-locked (socket)
386    (call-ffi -1 '%send (socket-%socket socket) message
387              (foreign-bitfield-value 'send-options flags))))
388
389(defun recv (socket message &optional flags)
390  "Receive a message from SOCKET and store it in MESSAGE."
391  (with-socket-locked (socket)
392    (call-ffi -1 '%recv (socket-%socket socket) message
393              (foreign-bitfield-value 'recv-options flags))))
394
395(defmacro with-poll-items ((items-var size-var) items &body body)
396  "Evaluate BODY in an environment where ITEMS-VAR is bound to a foreign array
397  of poll items, and SIZE-VAR is bound to the number of polled items. Poll
398  items are filled according to ITEMS. ITEMS is a list where each element
399  describe a poll item. Each description is a list where the first element is
400  a socket instance, a foreign pointer to a zeromq socket, or a file
401  descriptor, and other elements are the events to watch
402  for, :POLLIN, :POLLOUT or :POLLERR."
403  (let ((i 0)
404        (pollitem-size (foreign-type-size '(:struct pollitem))))
405    `(with-foreign-object (,items-var '(:struct pollitem) ,(length items))
406       ,@(mapcar (lambda (item)
407                   (prog1
408                       `(with-foreign-slots ((socket fd events revents)
409                                             (inc-pointer ,items-var
410                                                          ,(* i pollitem-size))
411                                             (:struct pollitem))
412                          (destructuring-bind (handle &rest event-list)
413                              (list ,@item)
414                            (cond
415                              ((typep handle 'socket)
416                               (setf socket (socket-%socket handle)))
417                              ((pointerp handle)
418                               (setf socket handle))
419                              (t
420                               (setf socket (null-pointer))
421                               (setf fd handle)))
422                            (setf events (foreign-bitfield-value
423                                          'event-types event-list)
424                                  revents 0)))
425                     (incf i)))
426                 items)
427       (let ((,size-var ,(length items)))
428         ,@body))))
429
430(defmacro poll-items-aref (items i)
431  "Return a foreign pointer on the poll item of indice I in the foreign array
432ITEMS."
433  `(mem-aptr ,items '(:struct pollitem) ,i))
434
435(defmacro do-poll-items ((var items nb-items) &body body)
436  "For each poll item in ITEMS, evaluate BODY in an environment where VAR is
437  bound to the poll item."
438  (let ((i (gensym)))
439    `(do ((,i 0 (1+ ,i)))
440         ((= ,i ,nb-items))
441       (let ((,var (poll-items-aref ,items ,i)))
442         ,@body))))
443
444(defun poll-item-events-signaled-p (poll-item &rest events)
445  "Return T if POLL-ITEM indicates that one or more of the listed EVENTS types was
446   detected for the underlying socket or file descriptor or NIL if no event occurred."
447  (/= (logand (foreign-slot-value poll-item '(:struct pollitem) 'revents)
448              (foreign-bitfield-value 'event-types events)) 0))
449
450(defun poll-item-socket (poll-item)
451  "Return a foreign pointer to the zeromq socket of the poll item POLL-ITEM."
452  (foreign-slot-value poll-item '(:struct pollitem) 'socket))
453
454(defun poll-item-fd (poll-item)
455  "Return the file descriptor of the poll item POLL-ITEM."
456  (foreign-slot-value poll-item '(:struct pollitem) 'fd))
457
458(defun poll (items nb-items timeout)
459  "Poll ITEMS with a timeout of TIMEOUT microseconds, -1 meaning no time
460  limit. Return the number of items with signaled events."
461  (call-ffi -1 '%poll items nb-items timeout))
462
463(defun stopwatch-start ()
464  "Start a timer, and return a handle."
465  (call-ffi (null-pointer) '%stopwatch-start))
466
467(defun stopwatch-stop (handle)
468  "Stop the timer referenced by HANDLE, and return the number of microseconds
469  elapsed since the timer was started."
470  (%stopwatch-stop handle))
471
472(defmacro with-stopwatch (&body body)
473  "Start a timer, evaluate BODY, stop the timer, and return the elapsed time."
474  (let ((handle (gensym)))
475    `(let ((,handle (stopwatch-start)))
476       ,@body
477       (stopwatch-stop ,handle))))
478
479(defun sleep (seconds)
480  "Sleep for SECONDS seconds."
481  (%sleep seconds))