1;;;
2;;; srfi-106 - socket interface
3;;;
4
5;; NB: Test for srfi-106 is in ext/net.
6
7(define-module srfi-106
8  (use gauche.uvector)
9  (use gauche.net :prefix net:)
10  (export make-client-socket make-server-socket socket? call-with-socket
11          socket-input-port socket-output-port
12          socket-merge-flags socket-purge-flags
13          socket-accept socket-send socket-recv socket-shutdown socket-close
14          *af-unspec* *af-inet* *af-inet6*
15          *sock-stream* *sock-dgram*
16          *ai-canonname* *ai-numerichost*
17          *ai-v4mapped* *ai-all* *ai-addrconfig*
18          *ipproto-ip* *ipproto-tcp* *ipproto-udp*
19          *msg-none* *msg-peek* *msg-oob* *msg-waitall*
20          *shut-rd* *shut-wr* *shut-rdwr*
21          address-family socket-domain address-info
22          ip-protocol message-type shutdown-method))
23(select-module srfi-106)
24
25;;
26;; Constants and flag operations
27;;
28(define-constant *af-inet*        net:AF_INET)
29(define-constant *af-inet6*       net:AF_INET6)
30(define-constant *af-unspec*      net:AF_UNSPEC)
31
32(define-macro (address-family name)
33  (ecase (unwrap-syntax name)
34    [(inet)   *af-inet*]
35    [(inet6)  *af-inet6*]
36    [(unspec) *af-unspec*]))
37
38(define-constant *sock-stream*    net:SOCK_STREAM)
39(define-constant *sock-dgram*     net:SOCK_DGRAM)
40
41(define-macro (socket-domain name)
42  (ecase (unwrap-syntax name)
43    [(stream)   *sock-stream*]
44    [(datagram) *sock-dgram*]))
45
46(define-constant *ai-canonname*   net:AI_CANONNAME)
47(define-constant *ai-numerichost* net:AI_NUMERICHOST)
48;; NB: AI_V4MAPPED, AI_ALL and AI_ADDRCONFIG may not be defined
49;;     even if ipv6 is available (e.g. NetBSD, MinGW32).
50(define-constant *ai-v4mapped*
51  (global-variable-ref 'gauche.net 'AI_V4MAPPED 0))
52(define-constant *ai-all*
53  (global-variable-ref 'gauche.net 'AI_ALL 0))
54(define-constant *ai-addrconfig*
55  (global-variable-ref 'gauche.net 'AI_ADDRCONFIG 0))
56
57(define-macro (address-info . names)
58  (define (lookup name)
59    (ecase (unwrap-syntax name)
60      [(canoname)    *ai-canonname*]
61      [(numerichost) *ai-numerichost*]
62      [(v4mapped)    *ai-v4mapped*]
63      [(all)         *ai-all*]
64      [(addrconfig)  *ai-addrconfig*]))
65  (apply logior (map lookup names)))
66
67(define-constant *ipproto-ip*     net:IPPROTO_IP)
68(define-constant *ipproto-tcp*    net:IPPROTO_TCP)
69(define-constant *ipproto-udp*    net:IPPROTO_UDP)
70
71(define-macro (ip-protocol name)
72  (ecase (unwrap-syntax name)
73    [(ip)  *ipproto-ip*]
74    [(tcp) *ipproto-tcp*]
75    [(udp) *ipproto-udp*]))
76
77(define-constant *msg-none*       0)
78(define-constant *msg-peek*       net:MSG_PEEK)
79(define-constant *msg-oob*        net:MSG_OOB)
80;; NB: MSG_WAITALL may not be defined (e.g. MinGW32).
81(define-constant *msg-waitall*
82  (global-variable-ref 'gauche.net 'MSG_WAITALL 0))
83
84(define-macro (message-type . names)
85  (define (lookup name)
86    (ecase (unwrap-syntax name)
87      [(none)      *msg-none*]
88      [(peek)      *msg-peek*]
89      [(oob)       *msg-oob*]
90      [(wait-all)  *msg-waitall*]))
91  (apply logior (map lookup names)))
92
93(define-constant *shut-rd*       net:SHUT_RD)
94(define-constant *shut-wr*       net:SHUT_WR)
95(define-constant *shut-rdwr*     net:SHUT_RDWR)
96
97(define-macro (shutdown-method . names)
98  (define (lookup name)
99    (ecase (unwrap-syntax name)
100      [(read)      *shut-rd*]
101      [(write)     *shut-wr*]))
102  (apply logior (map lookup names)))
103
104(define (socket-merge-flags . flags) (apply logior flags))
105(define (socket-purge-flags base-flag . flags)
106  (logand base-flag (lognot (apply logior flags))))
107
108;;
109;; Constructors
110;;
111(define (make-client-socket node service
112                            :optional
113                            (ai-family *af-inet*)
114                            (ai-socktype *sock-stream*)
115                            (ai-flags (socket-merge-flags *ai-v4mapped*
116                                                          *ai-addrconfig*))
117                            (ai-protocol *ipproto-ip*))
118  (assume-type node <string>)
119  (assume-type service <string>)
120  (cond-expand
121   [gauche.net.ipv6
122    (let1 ais (net:sys-getaddrinfo node service
123                                   (make net:<sys-addrinfo>
124                                     :flags ai-flags
125                                     :family ai-family
126                                     :socktype ai-socktype
127                                     :protocol ai-protocol))
128      (or (any (^[ai] (guard (e [else #f])
129                        (net:make-client-socket (~ ai'addr))))
130               ais)
131          ;; If we're here, attempts to connect to every ais failed.
132          ;; TODO: We might want to keep one of the errors for better msg
133          (error "couldn't connect to ~a:~a" node service)))]
134   [else
135    ;; We should handle other options, but this path is rarely used,
136    ;; only for ipv6-less platforms.
137    (let1 addrs (net:make-sockaddrs node service ai-protocol)
138      (or (any (^[addr] (guard (e [else #f])
139                          (net:make-client-socket addr)))
140               addrs)
141          (error "couldn't connect to ~a:~a" node service)))]))
142
143(define (make-server-socket service
144                            :optional
145                            (ai-family *af-inet*)
146                            (ai-socktype *sock-stream*)
147                            (ai-protocol *ipproto-ip*))
148  (assume-type service <string>)
149  (cond-expand
150   [gauche.net.ipv6
151    (let1 ais (net:sys-getaddrinfo #f service
152                                   (make net:<sys-addrinfo>
153                                     :flags 0
154                                     :family ai-family
155                                     :socktype ai-socktype
156                                     :protocol ai-protocol))
157      (or (any (^[ai] (guard (e [else #f])
158                        (net:make-server-socket (~ ai'addr))))
159               ais)
160          ;; If we're here, attempts to bind every ais failed.
161          ;; TODO: We might want to keep one of the errors for better msg
162          (error "couldn't create a server socket at service `~a'" service)))]
163   [else
164     ;; We should handle other options, but this path is rarely used,
165     ;; only for ipv6-less platforms.
166     (let1 addrs (net:make-sockaddrs #f service ai-protocol)
167       (or (any (^[addr] (guard (e [else #f])
168                           (net:make-server-socket addr)))
169                addrs)
170          (error "couldn't create a server socket at service `~a'" service)))]
171   ))
172
173;;
174;; Communication
175;;
176
177(define (socket-send socket u8v :optional (flags *msg-none*))
178  (assume-type u8v <u8vector>)
179  (net:socket-send socket u8v flags))
180
181(define (socket-recv socket size :optional (flags *msg-none*))
182  (let1 buf (make-u8vector size)
183    (let1 n (net:socket-recv! socket buf flags)
184      (if (< n size)
185        (uvector-alias <u8vector> buf 0 n) ; returns #u8() when conn. closed
186        buf))))
187
188;;
189;; Miscellaneous
190;;
191
192(define (socket? x) (is-a? x net:<socket>))
193(define socket-accept net:socket-accept)
194(define socket-shutdown net:socket-shutdown)
195(define socket-input-port net:socket-input-port)
196(define socket-output-port net:socket-output-port)
197(define socket-close net:socket-close)
198
199(define (call-with-socket socket proc)
200  (unwind-protect (proc socket)
201    (socket-close socket)))
202
203
204
205