PageRenderTime 52ms CodeModel.GetById 23ms RepoModel.GetById 0ms app.codeStats 0ms

/src/zmq.lisp

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