1;;; -*- Scheme -*-
2;;;
3;;; socket.scm - socket library
4;;;
5;;;   Copyright (c) 2010-2021  Takashi Kato  <ktakashi@ymail.com>
6;;;
7;;;   Redistribution and use in source and binary forms, with or without
8;;;   modification, are permitted provided that the following conditions
9;;;   are met:
10;;;
11;;;   1. Redistributions of source code must retain the above copyright
12;;;      notice, this list of conditions and the following disclaimer.
13;;;
14;;;   2. Redistributions in binary form must reproduce the above copyright
15;;;      notice, this list of conditions and the following disclaimer in the
16;;;      documentation and/or other materials provided with the distribution.
17;;;
18;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29;;;
30
31(library (sagittarius socket)
32    (export make-client-socket
33	    make-server-socket
34	    call-with-socket
35	    shutdown-output-port
36	    socket?
37	    socket-closed?
38	    make-socket
39	    socket-port socket-input-port socket-output-port
40	    shutdown-port shutdown-input-port shutdown-output-port
41
42	    create-socket ;; for convenience
43
44	    socket-setsockopt!
45	    socket-getsockopt
46	    socket-connect!
47	    socket-bind!
48	    socket-listen!
49	    socket-error-message
50	    socket-last-error
51
52	    socket-accept
53	    socket-send socket-sendto
54	    socket-recv socket-recv! socket-recvfrom
55	    socket-shutdown
56	    socket-close
57	    socket-fd
58	    socket-node
59	    socket-service
60
61	    ;; select
62	    socket-select
63	    socket-select!
64	    socket-read-select
65	    socket-write-select
66	    socket-error-select
67	    socket-nonblocking!
68	    socket-blocking!
69	    socket-set-read-timeout!
70	    nonblocking-socket?
71	    ;; addrinfo
72	    make-addrinfo
73
74	    AF_UNSPEC AF_INET AF_INET6
75
76	    SOCK_STREAM SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET
77
78	    AI_PASSIVE AI_CANONNAME AI_NUMERICHOST
79	    AI_V4MAPPED AI_ALL AI_ADDRCONFIG
80
81	    IPPROTO_IP IPPROTO_TCP IPPROTO_UDP IPPROTO_RAW IPPROTO_IPV6
82	    IPPROTO_ICMP IPPROTO_ICMPV6
83
84	    SHUT_RD SHUT_WR SHUT_RDWR
85
86	    MSG_OOB MSG_PEEK MSG_DONTROUTE MSG_CTRUNC
87	    MSG_PROBE MSG_TRUNC MSG_DONTWAIT MSG_EOR
88	    MSG_WAITALL MSG_FIN MSG_SYN MSG_CONFIRM
89	    MSG_RST MSG_ERRQUEUE MSG_NOSIGNAL
90	    MSG_MORE MSG_EOF
91
92	    ;;  socket options
93	    SOL_SOCKET
94	    SOMAXCONN
95	    SO_ACCEPTCONN SO_BINDTODEVICE SO_BROADCAST
96	    SO_DEBUG SO_DONTROUTE SO_ERROR
97	    SO_KEEPALIVE SO_LINGER SO_OOBINLINE
98	    SO_PASSCRED SO_PEERCRED SO_PRIORITY
99	    SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
100	    SO_REUSEADDR SO_REUSEPORT SO_SNDBUF
101	    SO_SNDLOWAT SO_SNDTIMEO SO_TIMESTAMP
102	    SO_TYPE
103
104	    SOL_TCP
105	    TCP_NODELAY TCP_MAXSEG TCP_CORK
106
107	    SOL_IP
108	    IP_OPTIONS IP_PKTINFO IP_RECVTOS
109	    IP_RECVTTL IP_RECVOPTS IP_TOS
110	    IP_TTL IP_HDRINCL IP_RECVERR
111	    IP_MTU_DISCOVER IP_MTU IP_ROUTER_ALERT
112	    IP_MULTICAST_TTL IP_MULTICAST_LOOP
113	    IP_ADD_MEMBERSHIP IP_DROP_MEMBERSHIP
114	    IP_MULTICAST_IF
115
116	    ;; errno
117	    EAGAIN EWOULDBLOCK EPIPE EINTR ETIMEDOUT EINPROGRESS
118	    ETIMEDOUT
119	    ;; addrinfo
120	    addrinfo? make-addrinfo make-hint-addrinfo get-addrinfo
121	    next-addrinfo addrinfo-sockaddr
122	    ;; sockaddr
123	    sockaddr?
124	    ;; socket-info
125	    socket-info?
126	    socket-peer
127	    socket-name
128	    socket-info
129	    socket-info-hostname
130	    socket-info-ip-address
131	    socket-info-port
132	    socket-info-values
133	    ;; ip-address
134	    ip-address?
135	    ip-address->string
136	    ip-address->bytevector
137	    ;; fdset
138	    make-fdset
139	    fdset?
140	    sockets->fdset
141	    collect-sockets
142	    fdset-set!
143	    fdset-ref
144
145	    ;; clos
146	    <socket>
147	    <addrinfo>
148	    <socket-info>
149
150	    ;; conditions
151	    &host-not-found host-not-found-error? make-host-not-found-error
152	    host-not-found-error-node host-not-found-error-service
153
154	    &socket socket-error? make-socket-error
155	    socket-error-socket
156
157	    &socket-connection socket-connection-error?
158	    make-socket-connection-error
159
160	    &socket-read-timeout socket-read-timeout-error?
161	    make-socket-read-timeout-error
162
163	    &socket-closed socket-closed-error? make-socket-closed-error
164	    &socket-port socket-port-error? make-socket-port-error
165	    socket-error-port
166	    )
167    (import (core)
168	    (core errors)
169	    (core conditions)
170	    (clos user)
171	    (sagittarius)
172	    (only (sagittarius time) time? make-time time-duration) ;; damn
173	    (sagittarius dynamic-module)
174	    )
175  (load-dynamic-module "sagittarius--socket")
176
177  (initialize-builtin-condition &host-not-found &i/o node service)
178  (initialize-builtin-condition &socket &i/o socket)
179  (initialize-builtin-condition &socket-connection &socket)
180  (initialize-builtin-condition &socket-closed &socket)
181  (initialize-builtin-condition &socket-port &socket port)
182
183  (define-condition-accessor host-not-found-error-node &host-not-found
184    &host-not-found-error-node)
185  (define-condition-accessor host-not-found-error-service &host-not-found
186    &host-not-found-error-service)
187
188  (define-condition-accessor socket-error-socket &socket &socket-error-socket)
189  (define-condition-accessor socket-error-port &socket-port &socket-error-port)
190
191  (define-condition-type &socket-read-timeout &socket
192    make-socket-read-timeout-error socket-read-timeout-error?)
193
194  (define (socket-recv! sock bv start len :optional (flags 0))
195    (let ((r (%socket-recv! sock bv start len flags)))
196      (when (and (< r 0) (not (nonblocking-socket? sock)))
197	(raise (condition (make-socket-read-timeout-error sock)
198			  (make-who-condition 'socket-recv!)
199			  (make-message-condition "Read timeout!"))))
200      r))
201  (define (socket-recv sock len :optional (flags 0))
202    (let ((r (%socket-recv sock len flags)))
203      (unless (or r (nonblocking-socket? sock))
204	(raise (condition (make-socket-read-timeout-error sock)
205			  (make-who-condition 'socket-recv)
206			  (make-message-condition "Read timeout!"))))
207      r))
208
209  (define (socket-set-read-timeout! socket read-timeout)
210    (cond ((and (integer? read-timeout) (exact? read-timeout) )
211	   ;; in micro seconds
212	   (let ((time (make-time time-duration
213				  (* (mod read-timeout 1000000) 1000)
214				  (div read-timeout 1000000))))
215	     (socket-set-read-timeout! socket time)))
216	  ((time? read-timeout)
217	   (socket-setsockopt! socket SOL_SOCKET SO_RCVTIMEO read-timeout))
218	  (else (assertion-violation 'socket-set-read-timeout!
219		  "Timeout value must be an exact integer (microseconds) or time"
220		  read-timeout))))
221
222  (define (call-with-socket socket proc)
223    (receive args (proc socket)
224      (socket-close socket)
225      (apply values args)))
226
227  (define (make-hint-addrinfo :key family socktype flags protocol)
228    (let ((info (make-addrinfo)))
229      (unless (undefined? family) (slot-set! info 'family family))
230      (unless (undefined? socktype) (slot-set! info 'socktype socktype))
231      (unless (undefined? flags) (slot-set! info 'flags flags))
232      (unless (undefined? protocol) (slot-set! info 'protocol protocol))
233      info))
234
235  (define (next-addrinfo info) (slot-ref info 'next))
236  (define (addrinfo-sockaddr info) (slot-ref info 'addr))
237
238  (define (create-socket info)
239    (make-socket (slot-ref info 'family) (slot-ref info 'socktype)
240		 (slot-ref info 'protocol)))
241
242  (define (make-client-socket node service
243			      :optional (ai-family AF_INET)
244					(ai-socktype SOCK_STREAM)
245					(ai-flags (+ (or AI_V4MAPPED 0)
246						     (or AI_ADDRCONFIG 0)))
247					(ai-protocol 0))
248    (unless (zero? (bitwise-and ai-flags AI_PASSIVE))
249      (assertion-violation 'make-client-socket
250			   "client socket must not have AI_PASSIVE"))
251    (let* ((hints (make-hint-addrinfo :family ai-family
252				      :socktype ai-socktype
253				      :flags ai-flags
254				      :protocol ai-protocol))
255	   (info (get-addrinfo node service hints)))
256      (let loop ((socket (create-socket info)) (info info))
257	(define (retry info)
258	  (let ((next (next-addrinfo info)))
259	    (if next
260		(loop (create-socket next) next)
261		(raise (condition (make-host-not-found-error node service)
262				  (make-who-condition 'make-client-socket)
263				  (make-message-condition "no next addrinfo")
264				  (make-irritants-condition
265				   (list node service)))))))
266	(or (and-let* (( socket )
267		       ( info ))
268	      (socket-connect! socket info))
269	    (and info (and socket (socket-close socket)) (retry info))
270	    (raise (condition (make-socket-error socket)
271			      (make-who-condition 'make-client-socket)
272			      (make-message-condition
273			       (if socket
274				   (socket-error-message socket)
275				   "creating a socket failed"))
276			      (make-irritants-condition
277			       (list node service))))))))
278
279  (define (make-server-socket service
280			      :optional (ai-family AF_INET)
281					(ai-socktype SOCK_STREAM)
282					(ai-protocol 0))
283    (let* ((hints (make-hint-addrinfo :family ai-family
284				      :socktype ai-socktype
285				      :flags AI_PASSIVE
286				      :protocol ai-protocol))
287	   (info (get-addrinfo #f service hints)))
288      (let loop ((socket (create-socket info)) (info info))
289	(define (retry info)
290	  (let ((next (next-addrinfo info)))
291	    (if next
292		(loop (create-socket next) next)
293		(raise (condition (make-host-not-found-error #f service)
294				  (make-who-condition 'make-client-socket)
295				  (make-message-condition "no next addrinfo")
296				  (make-irritants-condition service))))))
297
298	(or (and-let* (( socket )
299		       ( info )
300		       ( (socket-setsockopt! socket SOL_SOCKET SO_REUSEADDR 1) )
301		       ( (socket-bind! socket info) )
302		       ( (if (= ai-socktype SOCK_STREAM)
303			     (socket-listen! socket SOMAXCONN)
304			     #t) ))
305	      socket)
306	    (and info (and socket (socket-close socket)) (retry info))
307	    (raise (condition (make-socket-error socket)
308			      (make-who-condition 'make-server-socket)
309			      (make-message-condition
310			       (if socket
311				   (socket-error-message socket)
312				   "creating a socket failed"))
313			      (make-irritants-condition service)))))))
314  ;; for convenience
315  (define (socket-read-select timeout . rest)
316    (let ((rfds (sockets->fdset rest)))
317      (receive (n r w e) (socket-select! rfds #f #f timeout)
318	(collect-sockets r))))
319
320  (define (socket-write-select timeout . rest)
321    (let ((wfds (sockets->fdset rest)))
322      (receive (n r w e) (socket-select! #f wfds #f timeout)
323	(collect-sockets w))))
324
325  (define (socket-error-select timeout . rest)
326    (let ((efds (sockets->fdset rest)))
327      (receive (n r w e) (socket-select! #f #f efds timeout)
328	(collect-sockets e))))
329
330  ;; for backward compatibility
331  (define (socket-info-values socket :key (type 'peer))
332    (let ((peer (cond ((eq? type 'peer) (socket-peer socket))
333		      ((eq? type 'info) (socket-info socket))
334		      (else (error 'socket-info-values "unknown type" type)))))
335      (if peer
336	  (values (slot-ref peer 'hostname)
337		  (slot-ref peer 'ip-address)
338		  (slot-ref peer 'port))
339	  (values #f #f #f))))
340
341  (define (socket-info-hostname si) (slot-ref si 'hostname))
342  (define (socket-info-ip-address si) (slot-ref si 'ip-address))
343  (define (socket-info-port si) (slot-ref si 'port))
344)
345