PageRenderTime 6ms CodeModel.GetById 5ms app.highlight 29ms RepoModel.GetById 1ms app.codeStats 0ms

/src/sockets/socket-methods.lisp

https://bitbucket.org/sionescu/iolib
Lisp | 589 lines | 453 code | 86 blank | 50 comment | 1 complexity | c3880e03df145e31cebb9e8763b2613e MD5 | raw file
  1;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
  2;;;
  3;;; --- Various socket methods.
  4;;;
  5
  6(in-package :iolib/sockets)
  7
  8;;;-------------------------------------------------------------------------
  9;;; Shared Initialization
 10;;;-------------------------------------------------------------------------
 11
 12(defun translate-make-socket-keywords-to-constants (address-family type protocol)
 13  (let ((sf (ecase address-family
 14              (:ipv4  af-inet)
 15              (:ipv6  af-inet6)
 16              (:local af-local)
 17              #+linux
 18              (:netlink af-netlink)))
 19        (st (ecase type
 20              (:stream   sock-stream)
 21              (:datagram sock-dgram)
 22              (:raw      sock-raw)))
 23        (sp (etypecase protocol
 24              ((eql :default) 0)
 25              (integer        protocol))))
 26    (values sf st sp)))
 27
 28(defmethod socket-os-fd ((socket socket))
 29  (fd-of socket))
 30
 31(defmethod shared-initialize :after
 32    ((socket socket) slot-names
 33     &key file-descriptor (dup t) address-family type protocol)
 34  (declare (ignore slot-names))
 35  (with-accessors ((fd fd-of) (fam socket-address-family) (proto socket-protocol))
 36      socket
 37    (setf fd (or (and file-descriptor (if dup
 38                                          (isys:dup file-descriptor)
 39                                          file-descriptor))
 40                 (multiple-value-call #'%socket
 41                   (translate-make-socket-keywords-to-constants
 42                    address-family type protocol))))
 43    (setf fam address-family
 44          proto protocol)))
 45
 46(defmethod (setf external-format-of) (external-format (socket passive-socket))
 47  (setf (slot-value socket 'external-format)
 48        (babel:ensure-external-format (or external-format :default))))
 49
 50(defmethod shared-initialize :after ((socket passive-socket) slot-names
 51                                     &key external-format
 52                                     input-buffer-size output-buffer-size)
 53  ;; Makes CREATE-SOCKET simpler
 54  (declare (ignore slot-names input-buffer-size output-buffer-size))
 55  (setf (external-format-of socket) (or external-format :default)))
 56
 57
 58;;;-------------------------------------------------------------------------
 59;;; Misc
 60;;;-------------------------------------------------------------------------
 61
 62(defmethod socket-type ((socket stream-socket))
 63  :stream)
 64
 65(defmethod socket-type ((socket datagram-socket))
 66  :datagram)
 67
 68(defun socket-ipv6-p (socket)
 69  "Return T if SOCKET is an AF_INET6 socket."
 70  (eql :ipv6 (socket-address-family socket)))
 71
 72(defun ipv6-socket-p (&rest args)
 73  (apply #'socket-ipv6-p args))
 74
 75(defobsolete ipv6-socket-p socket-ipv6-p)
 76
 77
 78;;;-------------------------------------------------------------------------
 79;;; PRINT-OBJECT
 80;;;-------------------------------------------------------------------------
 81
 82(defun sock-fam (socket)
 83  (ecase (socket-address-family socket)
 84    (:ipv4 "IPv4")
 85    (:ipv6 "IPv6")))
 86
 87(defmethod print-object ((socket socket-stream-internet-active) stream)
 88  (print-unreadable-object (socket stream :identity t)
 89    (format stream "active ~A stream socket" (sock-fam socket))
 90    (if (socket-connected-p socket)
 91        (multiple-value-bind (host port) (remote-name socket)
 92          (format stream " connected to ~A/~A"
 93                  (address-to-string host) port))
 94        (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 95
 96(defmethod print-object ((socket socket-stream-internet-passive) stream)
 97  (print-unreadable-object (socket stream :identity t)
 98    (format stream "passive ~A stream socket" (sock-fam socket))
 99    (if (socket-bound-p socket)
100        (multiple-value-bind (host port) (local-name socket)
101          (format stream " ~:[bound to~;waiting @~] ~A/~A"
102                  (socket-listening-p socket)
103                  (address-to-string host) port))
104        (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
105
106(defmethod print-object ((socket socket-stream-local-active) stream)
107  (print-unreadable-object (socket stream :identity t)
108    (format stream "active local stream socket")
109    (if (socket-connected-p socket)
110        (format stream " connected to ~S"
111                (address-to-string (remote-filename socket)))
112        (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
113
114(defmethod print-object ((socket socket-stream-local-passive) stream)
115  (print-unreadable-object (socket stream :identity t)
116    (format stream "passive local stream socket")
117    (if (socket-bound-p socket)
118        (format stream " ~:[bound to~;waiting @~] ~A"
119                  (socket-listening-p socket)
120                  (address-to-string (local-filename socket)))
121        (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
122
123(defmethod print-object ((socket socket-datagram-local) stream)
124  (print-unreadable-object (socket stream :identity t)
125    (format stream "local datagram socket")
126    (if (socket-connected-p socket)
127        (format stream " connected to ~S"
128                (address-to-string (remote-filename socket)))
129        (if (fd-of socket)
130            (format stream " waiting @ ~S" (address-to-string (local-filename socket)))
131            (format stream ", closed" )))))
132
133(defmethod print-object ((socket socket-datagram-internet) stream)
134  (print-unreadable-object (socket stream :identity t)
135    (format stream "~A datagram socket" (sock-fam socket))
136    (if (socket-connected-p socket)
137        (multiple-value-bind (host port) (remote-name socket)
138          (format stream " connected to ~A/~A"
139                  (address-to-string host) port))
140        (if (fd-of socket)
141            (multiple-value-bind (host port) (local-name socket)
142              (format stream " waiting @ ~A/~A"
143                      (address-to-string host) port))
144            (format stream ", closed" )))))
145
146#+linux
147(defmethod print-object ((socket socket-raw-netlink) stream)
148  (print-unreadable-object (socket stream :identity t)
149    (format stream "netlink socket")
150    (if (socket-bound-p socket)
151        (multiple-value-bind (address port)
152            (local-name socket)
153          (format stream " bound to ~A@~A"
154                  port (address-to-string address)))
155        (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
156
157
158;;;-------------------------------------------------------------------------
159;;; CLOSE
160;;;-------------------------------------------------------------------------
161
162(defmethod close :before ((socket socket) &key abort)
163  (declare (ignore abort))
164  (setf (slot-value socket 'bound) nil))
165
166(defmethod close ((socket socket) &key abort)
167  (declare (ignore abort))
168  (when (next-method-p)
169    (call-next-method))
170  (socket-open-p socket))
171
172(defmethod close :before ((socket passive-socket) &key abort)
173  (declare (ignore abort))
174  (setf (slot-value socket 'listening) nil))
175
176(defmethod socket-open-p ((socket socket))
177  (if (null (fd-of socket))
178      nil
179      (with-sockaddr-storage-and-socklen (ss size)
180        (handler-case
181            (%getsockname (fd-of socket) ss size)
182          (isys:ebadf () nil)
183          (socket-connection-reset-error () nil)
184          (:no-error (_) (declare (ignore _)) t)))))
185
186
187;;;-------------------------------------------------------------------------
188;;; GETSOCKNAME
189;;;-------------------------------------------------------------------------
190
191(defun %local-name (socket)
192  (with-sockaddr-storage-and-socklen (ss size)
193    (%getsockname (fd-of socket) ss size)
194    (sockaddr-storage->sockaddr ss)))
195
196(defmethod local-name ((socket socket))
197  (%local-name socket))
198
199(defmethod local-host ((socket internet-socket))
200  (nth-value 0 (%local-name socket)))
201
202(defmethod local-port ((socket internet-socket))
203  (nth-value 1 (%local-name socket)))
204
205#+linux
206(defmethod local-port ((socket netlink-socket))
207  (nth-value 1 (%local-name socket)))
208
209(defmethod local-filename ((socket local-socket))
210  (%local-name socket))
211
212
213;;;-------------------------------------------------------------------------
214;;; GETPEERNAME
215;;;-------------------------------------------------------------------------
216
217(defun %remote-name (socket)
218  (with-sockaddr-storage-and-socklen (ss size)
219    (%getpeername (fd-of socket) ss size)
220    (sockaddr-storage->sockaddr ss)))
221
222(defmethod remote-name ((socket socket))
223  (%remote-name socket))
224
225(defmethod remote-host ((socket internet-socket))
226  (nth-value 0 (%remote-name socket)))
227
228(defmethod remote-port ((socket internet-socket))
229  (nth-value 1 (%remote-name socket)))
230
231(defmethod remote-filename ((socket local-socket))
232  (%remote-name socket))
233
234
235;;;-------------------------------------------------------------------------
236;;; BIND
237;;;-------------------------------------------------------------------------
238
239(defmethod bind-address :before ((socket internet-socket) address
240                                 &key (reuse-address t))
241  (declare (ignore address))
242  (when reuse-address
243    (setf (socket-option socket :reuse-address) t)))
244
245(defun bind-ipv4-address (fd address port)
246  (with-sockaddr-in (sin address port)
247    (%bind fd sin (isys:sizeof 'sockaddr-in))))
248
249(defun bind-ipv6-address (fd address port)
250  (with-sockaddr-in6 (sin6 address port)
251    (%bind fd sin6 (isys:sizeof 'sockaddr-in6))))
252
253(defmethod bind-address ((socket internet-socket) (address ipv4-address)
254                         &key (port 0))
255  (let ((port (ensure-numerical-service port)))
256    (if (socket-ipv6-p socket)
257        (bind-ipv6-address (fd-of socket)
258                           (map-ipv4-vector-to-ipv6 (address-name address))
259                           port)
260        (bind-ipv4-address (fd-of socket) (address-name address) port)))
261  (values socket))
262
263(defmethod bind-address ((socket internet-socket) (address ipv6-address)
264                         &key (port 0))
265  (bind-ipv6-address (fd-of socket)
266                     (address-name address)
267                     (ensure-numerical-service port))
268  (values socket))
269
270(defmethod bind-address ((socket local-socket) (address local-address) &key)
271  (with-sockaddr-un (sun (address-name address) (abstract-address-p address))
272    (%bind (fd-of socket) sun (actual-size-of-sockaddr-un sun)))
273  (values socket))
274
275#+linux
276(defmethod bind-address ((socket netlink-socket) (address netlink-address)
277                         &key (port 0))
278  (with-sockaddr-nl (snl (netlink-address-multicast-groups address) port)
279    (%bind (fd-of socket) snl (isys:sizeof 'sockaddr-nl)))
280  (values socket))
281
282(defmethod bind-address :after ((socket socket) (address address) &key)
283  (setf (slot-value socket 'bound) t))
284
285
286;;;-------------------------------------------------------------------------
287;;; LISTEN
288;;;-------------------------------------------------------------------------
289
290(defmethod listen-on ((socket socket) &key backlog)
291  (unless backlog (setf backlog (min *default-backlog-size*
292                                     +max-backlog-size+)))
293  (check-type backlog unsigned-byte "a non-negative integer")
294  (%listen (fd-of socket) backlog)
295  (setf (slot-value socket 'listening) t)
296  (values socket))
297
298
299;;;-------------------------------------------------------------------------
300;;; ACCEPT
301;;;-------------------------------------------------------------------------
302
303(defmethod accept-connection ((socket passive-socket) &key external-format
304                              input-buffer-size output-buffer-size (wait t))
305  (check-type wait timeout-designator)
306  (flet ((make-client-socket (fd)
307           (make-instance (active-class socket)
308                          :address-family (socket-address-family socket)
309                          :file-descriptor fd :dup nil
310                          :external-format (or external-format
311                                               (external-format-of socket))
312                          :input-buffer-size input-buffer-size
313                          :output-buffer-size output-buffer-size)))
314    (ignore-some-conditions (isys:ewouldblock iomux:poll-timeout)
315      (iomux:wait-until-fd-ready (fd-of socket) :input (wait->timeout wait) t)
316      (with-sockaddr-storage-and-socklen (ss size)
317        (multiple-value-call #'values
318          (make-client-socket (%accept (fd-of socket) ss size))
319          (sockaddr-storage->sockaddr ss))))))
320
321
322;;;-------------------------------------------------------------------------
323;;; CONNECT
324;;;-------------------------------------------------------------------------
325
326(defun ipv4-connect (fd address port)
327  (with-sockaddr-in (sin address port)
328    (%connect fd sin (isys:sizeof 'sockaddr-in))))
329
330(defun ipv6-connect (fd address port)
331  (with-sockaddr-in6 (sin6 address port)
332    (%connect fd sin6 (isys:sizeof 'sockaddr-in6))))
333
334(defun call-with-socket-to-wait-connect (socket thunk wait)
335  (check-type wait timeout-designator)
336  (let ((timeout (wait->timeout wait)))
337    (flet
338        ((wait-connect ()
339           (when (or (null  timeout)
340                     (plusp timeout))
341             (handler-case
342                 (iomux:wait-until-fd-ready (fd-of socket) :output timeout t)
343               (iomux:poll-error ()
344                 (let ((errcode (socket-option socket :error)))
345                   (if (zerop errcode)
346                       (bug "Polling socket signalled an error but SO_ERROR is 0")
347                       (signal-socket-error errcode "connect" (fd-of socket)))))))))
348      (ignore-some-conditions (iomux:poll-timeout)
349        (handler-case
350            (funcall thunk)
351          ((or isys:ewouldblock
352               isys:einprogress) ()
353            (wait-connect)))))))
354
355(defmacro with-socket-to-wait-connect ((socket wait) &body body)
356  `(call-with-socket-to-wait-connect ,socket (lambda () ,@body) ,wait))
357
358(defmethod connect ((socket internet-socket) (address inet-address)
359                    &key (port 0) (wait t))
360  (let ((name (address-name address))
361        (port (ensure-numerical-service port)))
362    (with-socket-to-wait-connect (socket wait)
363      (cond
364        ((socket-ipv6-p socket)
365         (when (ipv4-address-p address)
366           (setf name (map-ipv4-vector-to-ipv6 name)))
367         (ipv6-connect (fd-of socket) name port))
368        (t (ipv4-connect (fd-of socket) name port)))))
369  (values socket))
370
371(defmethod connect ((socket local-socket) (address local-address) &key (wait t))
372  (with-socket-to-wait-connect (socket wait)
373    (with-sockaddr-un (sun (address-name address) (abstract-address-p address))
374        (%connect (fd-of socket) sun (actual-size-of-sockaddr-un sun))))
375  (values socket))
376
377(defmethod socket-connected-p ((socket socket))
378  (if (fd-of socket)
379      (with-sockaddr-storage-and-socklen (ss size)
380        (handler-case
381            (%getpeername (fd-of socket) ss size)
382          ((or isys:enotconn isys:einval) ()  nil)
383          (:no-error (_) (declare (ignore _)) t)))
384      nil))
385
386
387;;;-------------------------------------------------------------------------
388;;; DISCONNECT
389;;;-------------------------------------------------------------------------
390
391(defmethod disconnect ((socket datagram-socket))
392  (with-foreign-object (sin 'sockaddr-in)
393    (isys:bzero sin (isys:sizeof 'sockaddr-in))
394    (setf (foreign-slot-value sin 'sockaddr-in 'addr) af-unspec)
395    (%connect (fd-of socket) sin (isys:sizeof 'sockaddr-in))
396    (values socket)))
397
398
399;;;-------------------------------------------------------------------------
400;;; SHUTDOWN
401;;;-------------------------------------------------------------------------
402
403(defmethod shutdown ((socket socket) &key read write)
404  (assert (or read write) (read write)
405          "You must select at least one direction to shut down.")
406  (%shutdown (fd-of socket)
407             (multiple-value-case ((read write))
408               ((*   nil) shut-rd)
409               ((nil *)   shut-wr)
410               (t         shut-rdwr)))
411  (values socket))
412
413
414;;;-------------------------------------------------------------------------
415;;; Socket flag definition
416;;;-------------------------------------------------------------------------
417
418(defmacro define-socket-flag (place name value platform)
419  (let ((val (cond ((or (not platform)
420                        (featurep platform)) value)
421                   ((not (featurep platform)) 0))))
422    `(pushnew (cons ,name ,val) ,place)))
423
424(defmacro define-socket-flags (place &body definitions)
425  (flet ((dflag (form)
426           (destructuring-bind (name value &optional platform) form
427             `(define-socket-flag ,place ,name ,value ,platform))))
428    `(progn
429       ,@(mapcar #'dflag definitions))))
430
431
432;;;-------------------------------------------------------------------------
433;;; SENDTO
434;;;-------------------------------------------------------------------------
435
436(defvar *sendto-flags* ())
437
438(define-socket-flags *sendto-flags*
439  (:dont-route    msg-dontroute)
440  (:dont-wait     msg-dontwait  (:not :windows))
441  (:out-of-band   msg-oob)
442  (:more          msg-more      :linux)
443  (:confirm       msg-confirm   :linux))
444
445(defun %%send-to (fd ss got-peer buff-sap start length flags)
446  (incf-pointer buff-sap start)
447  (loop
448    (restart-case
449        (return*
450         (%sendto fd buff-sap length flags
451                  (if got-peer ss (null-pointer))
452                  (if got-peer (sockaddr-size ss) 0)))
453      (ignore-syscall-error ()
454        :report "Ignore this socket condition"
455        :test isys:syscall-error-p
456        (return* 0))
457      (retry-syscall (&optional (timeout 15.0d0))
458        :report "Try to send data again"
459        :test isys:syscall-error-p
460        (when (plusp timeout)
461          (iomux:wait-until-fd-ready fd :output timeout nil))))))
462
463(defun %send-to (fd ss got-peer buffer start end flags)
464  (etypecase buffer
465    (ub8-sarray
466     (check-bounds buffer start end)
467     (with-pointer-to-vector-data (buff-sap buffer)
468       (%%send-to fd ss got-peer buff-sap start (- end start) flags)))
469    ((or ub8-vector (vector t))
470     (check-bounds buffer start end)
471     (with-pointer-to-vector-data (buff-sap (coerce buffer 'ub8-sarray))
472       (%%send-to fd ss got-peer buff-sap start (- end start) flags)))
473    (foreign-pointer
474     (check-type start unsigned-byte)
475     (check-type end   unsigned-byte)
476     (%%send-to fd ss got-peer buffer start (- end start) flags))))
477
478(defmethod send-to ((socket internet-socket) buffer &rest args
479                    &key (start 0) end remote-host (remote-port 0) flags (ipv6 *ipv6*))
480  (let ((*ipv6* ipv6))
481    (with-sockaddr-storage (ss)
482      (when remote-host
483        (sockaddr->sockaddr-storage ss (ensure-hostname remote-host)
484                                    (ensure-numerical-service remote-port)))
485      (%send-to (fd-of socket) ss (if remote-host t) buffer start end
486                (or flags (compute-flags *sendto-flags* args))))))
487
488(defmethod send-to ((socket local-socket) buffer &rest args
489                    &key (start 0) end remote-filename flags)
490  (with-sockaddr-storage (ss)
491    (when remote-filename
492      (sockaddr->sockaddr-storage ss (ensure-address remote-filename :family :local) 0))
493    (%send-to (fd-of socket) ss (if remote-filename t) buffer start end
494              (or flags (compute-flags *sendto-flags* args)))))
495
496(define-compiler-macro send-to (&whole form &environment env socket buffer &rest args
497                                &key (start 0) end (remote-host nil host-p) (remote-port 0 port-p)
498                                (remote-filename nil file-p) flags (ipv6 '*ipv6* ipv6-p) &allow-other-keys)
499  (let ((flags-val (compute-flags *sendto-flags* args env)))
500    (cond
501      ((and (not flags) flags-val)
502       (append
503        `(send-to ,socket ,buffer :start ,start :end ,end :flags ,flags-val)
504        (when host-p `(:remote-host ,remote-host))
505        (when port-p `(:remote-port ,remote-port))
506        (when ipv6-p `(:ipv6 ,ipv6))
507        (when file-p `(:remote-filename ,remote-filename))))
508      (t
509       form))))
510
511
512;;;-------------------------------------------------------------------------
513;;; RECVFROM
514;;;-------------------------------------------------------------------------
515
516(defvar *recvfrom-flags* ())
517
518(define-socket-flags *recvfrom-flags*
519  (:out-of-band msg-oob)
520  (:peek        msg-peek)
521  (:wait-all    msg-waitall  (:not :windows))
522  (:dont-wait   msg-dontwait (:not :windows)))
523
524(defun %%receive-from (fd ss size buffer start length flags)
525  (with-pointer-to-vector-data (buff-sap buffer)
526    (incf-pointer buff-sap start)
527    (loop
528       (restart-case
529           (return* (%recvfrom fd buff-sap length flags ss size))
530         (ignore-syscall-error ()
531           :report "Ignore this socket condition"
532           :test isys:syscall-error-p
533           (return* 0))
534         (retry-syscall (&optional (timeout 15.0d0))
535           :report "Try to receive data again"
536           :test isys:syscall-error-p
537           (when (plusp timeout)
538             (iomux:wait-until-fd-ready fd :input timeout nil)))))))
539
540(defun %receive-from (fd ss size buffer start end flags)
541  (check-bounds buffer start end)
542  (flet ((%do-recvfrom (buff start length)
543           (%%receive-from fd ss size buff start length flags)))
544    (let (nbytes)
545      (etypecase buffer
546        (ub8-sarray
547         (setf nbytes (%do-recvfrom buffer start (- end start))))
548        ((or ub8-vector (vector t))
549         (let ((tmpbuff (make-array (- end start) :element-type 'ub8)))
550           (setf nbytes (%do-recvfrom tmpbuff 0 (- end start)))
551           (replace buffer tmpbuff :start1 start :end1 end :start2 0 :end2 nbytes))))
552      (values nbytes))))
553
554(defmethod receive-from :around ((socket socket) &rest args
555                                 &key buffer size (start 0) end flags &allow-other-keys)
556  (let ((flags-val (or flags (compute-flags *recvfrom-flags* args))))
557    (cond
558      (buffer
559       (call-next-method socket :buffer buffer :start start :end end :flags flags-val))
560      (t
561       (check-type size unsigned-byte "a non-negative integer")
562       (call-next-method socket :buffer (make-array size :element-type 'ub8)
563                         :start 0 :end size :flags flags-val)))))
564
565(defmethod receive-from ((socket stream-socket) &key buffer start end flags)
566  (with-sockaddr-storage-and-socklen (ss size)
567    (let ((nbytes (%receive-from (fd-of socket) ss size buffer start end flags)))
568      (values buffer nbytes))))
569
570(defmethod receive-from ((socket raw-socket) &key buffer start end flags)
571  (with-sockaddr-storage-and-socklen (ss size)
572    (let ((nbytes (%receive-from (fd-of socket) ss size buffer start end flags)))
573      (values buffer nbytes))))
574
575(defmethod receive-from ((socket datagram-socket) &key buffer start end flags)
576  (with-sockaddr-storage-and-socklen (ss size)
577    (let ((nbytes (%receive-from (fd-of socket) ss size buffer start end flags)))
578      (multiple-value-call #'values buffer nbytes
579                           (sockaddr-storage->sockaddr ss)))))
580
581(define-compiler-macro receive-from (&whole form &environment env socket &rest args
582                                     &key buffer size (start 0) end flags &allow-other-keys)
583  (let ((flags-val (compute-flags *recvfrom-flags* args env)))
584    (cond
585      ((and (not flags) flags-val)
586       `(receive-from ,socket :buffer ,buffer :start ,start :end ,end
587                      :size ,size :flags ,flags-val))
588      (t
589       form))))