-
Notifications
You must be signed in to change notification settings - Fork 30
/
posix-socket.lisp
130 lines (110 loc) · 3.69 KB
/
posix-socket.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
(in-package #:tpd2.io)
(defmacro socket-io-syscall (call)
#+never `(handler-bind
((syscall-failed #'(lambda(e)
(when (not (member (syscall-failed-errno e)
'(+EINVAL+ +EBADF+)))
(error 'socket-closed)))))
,call)
call)
(defmethod socket-read ((fd integer) buf offset)
(declare (type simple-byte-vector buf))
(declare (type fixnum offset))
(debug-assert (not (zerop (length buf))) (fd buf offset))
(let ((s
(with-pointer-to-vector-data (ptr buf)
(socket-io-syscall (syscall-read fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
(case-= s
(-1 nil)
(t s))))
(defmethod socket-write ((fd integer) buf offset)
(declare (type simple-byte-vector buf))
(declare (type fixnum offset))
(let ((s
(with-pointer-to-vector-data (ptr buf)
(socket-io-syscall (syscall-write fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
(case-= s
(-1 nil)
(t s))))
(defmethod socket-writev ((fd integer) iovec count)
(declare (optimize speed))
(let ((s
(socket-io-syscall (syscall-writev fd iovec count))))
(case-= s
(-1 nil)
(t s))))
(eval-always
(defun accept4-supported ()
(cffi:foreign-symbol-pointer "accept4")))
(defmethod socket-accept ((fd integer))
(cffi:with-foreign-object (sa 'sockaddr_in)
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(let ((s
(socket-io-syscall
#. (progn
(if (accept4-supported)
`(syscall-accept4 fd sa len
(logior
0
#-tpd2-untransformed-io +SOCK_NONBLOCK+
)
)
`(syscall-accept fd sa len)
)))))
(case-= s
(-1 nil)
(t
; (socket-set-tcp-nodelay s)
; (socket-cork s)
#.(unless (accept4-supported)
#-tpd2-untransformed-io
`(set-fd-nonblock s))
(make-con
:socket s
:peer-info (sockaddr-address-bv sa))))))))
(defmethod socket-close ((fd integer))
(declare (optimize speed))
(syscall-close fd)
(deregister-fd fd)
(values))
(defmethod socket-register ((fd integer) events con)
(debug-assert (eql fd (con-socket con)) (fd con))
(register-fd fd events con))
(defmethod socket-supports-writev ( (fd integer))
(declare (ignore fd))
#+tpd2-byte-vectors-do-not-move-arbitrarily
t)
(defmethod socket-recvfrom ( (fd integer) buf)
(cffi:with-foreign-object (sa 'sockaddr_in)
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(with-pointer-to-vector-data (ptr buf)
(let ((s (socket-io-syscall (syscall-recvfrom fd ptr (length buf) 0 sa len))))
(case-= s
(-1 (values nil nil))
(0 (error 'socket-closed))
(t
(let ((sa-out (make-byte-vector (cffi:mem-aref len :int))))
(loop for i from 0 below (length sa-out) do
(setf (aref sa-out i) (cffi:mem-ref sa :unsigned-char i)))
(values s sa-out)))))))))
#+broken
(defmethod socket-sendto ((fd integer) sa buf)
(let ((s
(with-pointer-to-vector-data (ptr buf)
(with-pointer-to-vector-data (sa-ptr sa)
(socket-io-syscall (syscall-sendto fd ptr (length buf) 0 sa-ptr (length sa)))))))
(case-= s
(-1 nil)
(t s))))
(defmethod socket-peer ((fd integer))
(cffi:with-foreign-object (sa 'sockaddr_in)
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(when (zerop (getpeername fd sa len))
(sockaddr-address-string sa)))))
(defmethod socket-shutdown-write ((fd integer))
(syscall-shutdown fd +SHUT_WR+))
(defmethod socket-only-accept-if-data-ready ((fd integer) timeout)
(setsockopt-int fd +IPPROTO_TCP+ +TCP_DEFER_ACCEPT+ (round timeout)))