PageRenderTime 49ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 1ms

/socket.scm

https://bitbucket.org/ursetto/rfc2553
Scheme | 1340 lines | 1038 code | 105 blank | 197 comment | 13 complexity | 80541bfb732657d98db8edfb590ef9d4 MD5 | raw file
  1. ;;; socket extension
  2. ;;; License
  3. ;; Some code was derived from Chicken core tcp.scm.
  4. ;; Copyright (c) 2011-2012, Jim Ursetto
  5. ;; Copyright (c) 2008-2011, The Chicken Team
  6. ;; Copyright (c) 2000-2007, Felix L. Winkelmann
  7. ;; All rights reserved.
  8. ;; Redistribution and use in source and binary forms, with or without
  9. ;; modification, are permitted provided that the following conditions
  10. ;; are met:
  11. ;; - Redistributions of source code must retain the above copyright
  12. ;; notice, this list of conditions and the following disclaimer.
  13. ;; - Redistributions in binary form must reproduce the above copyright
  14. ;; notice, this list of conditions and the following disclaimer in
  15. ;; the documentation and/or other materials provided with the
  16. ;; distribution.
  17. ;; - Neither the name of the author nor the names of its contributors
  18. ;; may be used to endorse or promote products derived from this
  19. ;; software without specific prior written permission.
  20. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  21. ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  22. ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  23. ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  24. ;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  25. ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  26. ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  27. ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28. ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  29. ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  30. ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  31. ;; OF THE POSSIBILITY OF SUCH DAMAGE.
  32. (import scheme (except chicken errno) foreign)
  33. (use foreigners)
  34. (use srfi-4 extras ports)
  35. (use (only srfi-13 string-index))
  36. ;; Pull TCP in w/o importing so ##sys#tcp-port->fileno is defined
  37. ;; and network is started up.
  38. (require-library tcp)
  39. #> #include "socket.h" <#
  40. ;;; error handling
  41. (define-foreign-variable errno int "errno")
  42. (define strerror (foreign-lambda c-string "skt_strerror" int))
  43. (define-inline (type-error where msg . args)
  44. (apply ##sys#signal-hook #:type-error where msg args))
  45. (define-inline (domain-error where msg . args)
  46. (apply ##sys#signal-hook #:domain-error where msg args))
  47. (define-inline (network-error where msg . args)
  48. (apply ##sys#signal-hook #:network-error where msg args))
  49. (define-inline (network-error/errno where msg . args)
  50. (let ((err errno))
  51. (##sys#update-errno) ;; Note that this may cause context switch, and wipe out errno
  52. (apply ##sys#signal-hook #:network-error where
  53. (string-append msg " - " (strerror err))
  54. args)))
  55. (define-inline (network-error/errno* where err msg . args)
  56. ;;(##sys#update-errno)
  57. (apply ##sys#signal-hook #:network-error where
  58. (string-append msg " - " (strerror err))
  59. args))
  60. (define-inline (transient-network-error/errno* where err msg . args)
  61. (abort
  62. (make-composite-condition
  63. (make-property-condition 'exn 'location where
  64. 'message (string-append msg " - " (strerror err))
  65. 'arguments args)
  66. (make-property-condition 'i/o)
  67. (make-property-condition 'net 'errno err)
  68. (make-property-condition 'transient))))
  69. (define-inline (unsupported-error where msg . args)
  70. (abort
  71. (make-composite-condition
  72. (make-property-condition 'exn 'location where
  73. 'message msg
  74. 'arguments args)
  75. (make-property-condition 'i/o)
  76. (make-property-condition 'net)
  77. (make-property-condition 'unsupported))))
  78. ;;; constants
  79. ;; (define-foreign-flag AI_NUMERICSERV) =>
  80. ;; (begin (foreign-declare "#ifndef AI_NUMERICSERV\n#define AI_NUMERICSERV 0\n#endif\n")
  81. ;; (define-foreign-variable AI_NUMERICSERV int "AI_NUMERICSERV")
  82. ;; (define-for-syntax (c-name sym)
  83. ;; (string-translate (string-upcase (symbol->string sym)) "/" "_"))
  84. (define-syntax define-foreign-flag
  85. (lambda (e r c)
  86. (let ((name (cadr e)))
  87. `(,(r 'begin)
  88. (,(r 'foreign-declare)
  89. ,(sprintf "#ifndef ~A\n#define ~A 0\n#endif\n" name name))
  90. (,(r 'define-foreign-variable) ,name ,(r 'int) ,(symbol->string name))))))
  91. (define-foreign-enum-type (address-family int)
  92. (address-family->integer integer->address-family)
  93. ((af/unspec AF_UNSPEC) AF_UNSPEC)
  94. ((af/inet AF_INET) AF_INET)
  95. ((af/inet6 AF_INET6) AF_INET6)
  96. ;; #+AF_UNIX ((af/unix AF_UNIX) AF_UNIX)
  97. )
  98. #+AF_UNIX (define-foreign-variable AF_UNIX int AF_UNIX)
  99. (define af/unspec AF_UNSPEC)
  100. (define af/inet AF_INET)
  101. (define af/inet6 AF_INET6)
  102. (define af/unix #? (AF_UNIX AF_UNIX #f))
  103. (define-foreign-enum-type (socket-type int)
  104. (socket-type->integer integer->socket-type)
  105. ((sock/stream SOCK_STREAM) SOCK_STREAM)
  106. ((sock/dgram SOCK_DGRAM) SOCK_DGRAM)
  107. ((sock/raw SOCK_RAW) SOCK_RAW))
  108. (define sock/stream SOCK_STREAM)
  109. (define sock/dgram SOCK_DGRAM)
  110. (define sock/raw SOCK_RAW)
  111. ;; These are for address-information, not socket options -- so TCP and UDP only.
  112. (define-foreign-enum-type (protocol-type int)
  113. (protocol-type->integer integer->protocol-type)
  114. ((ipproto/tcp IPPROTO_TCP) IPPROTO_TCP)
  115. ((ipproto/udp IPPROTO_UDP) IPPROTO_UDP))
  116. (define ipproto/tcp IPPROTO_TCP)
  117. (define ipproto/udp IPPROTO_UDP)
  118. (define-foreign-variable AI_CANONNAME int "AI_CANONNAME")
  119. (define ai/canonname AI_CANONNAME)
  120. (define-foreign-variable AI_NUMERICHOST int "AI_NUMERICHOST")
  121. (define ai/numerichost AI_NUMERICHOST)
  122. (define-foreign-variable AI_PASSIVE int "AI_PASSIVE")
  123. (define ai/passive AI_PASSIVE)
  124. ;; These flags will be set to 0 if undefined. The ones above
  125. ;; will throw a compilation error since they are required.
  126. (define-foreign-flag AI_NUMERICSERV)
  127. (define ai/numericserv AI_NUMERICSERV)
  128. (define-foreign-flag AI_ALL)
  129. (define ai/all AI_ALL)
  130. (define-foreign-flag AI_V4MAPPED)
  131. (define ai/v4mapped AI_V4MAPPED)
  132. (define-foreign-flag AI_ADDRCONFIG)
  133. (define ai/addrconfig AI_ADDRCONFIG)
  134. (define-foreign-flag AI_MASK)
  135. (define ai/mask AI_MASK)
  136. (define-foreign-flag AI_DEFAULT)
  137. (define ai/default AI_DEFAULT)
  138. (define-foreign-variable NI_MAXHOST int "NI_MAXHOST")
  139. (define-foreign-variable NI_MAXSERV int "NI_MAXSERV")
  140. (define-foreign-variable NI_NUMERICHOST int "NI_NUMERICHOST")
  141. (define-foreign-variable NI_NUMERICSERV int "NI_NUMERICSERV")
  142. (define-foreign-variable NI_DGRAM int "NI_DGRAM")
  143. (define-foreign-variable NI_NAMEREQD int "NI_NAMEREQD")
  144. (define-foreign-variable NI_NOFQDN int "NI_NOFQDN")
  145. (define ni/numerichost NI_NUMERICHOST)
  146. (define ni/numericserv NI_NUMERICSERV)
  147. (define ni/dgram NI_DGRAM)
  148. (define ni/namereqd NI_NAMEREQD)
  149. (define ni/nofqdn NI_NOFQDN)
  150. ;;;
  151. (define-foreign-record-type (sa "struct sockaddr")
  152. (int sa_family sa-family))
  153. (define-foreign-variable _sockaddr_storage_size int "sizeof(struct sockaddr_storage)")
  154. (define-record sockaddr family blob)
  155. (define (sa->sockaddr sa len) ;; sa -- c-pointer; len -- length of sockaddr struct
  156. (if (= len 0) ;; for example, socket-receive-from! returns 0 len on connection-oriented socket
  157. #f
  158. (make-sockaddr (sa-family sa) ;; Assume when len > 0, it at least includes the family.
  159. (let ((b (make-blob len)))
  160. ((foreign-lambda void C_memcpy scheme-pointer c-pointer int)
  161. b sa len)
  162. b))))
  163. (define (sockaddr-len A)
  164. (blob-size (sockaddr-blob A)))
  165. (define (sockaddr-address A)
  166. (let ((af (sockaddr-family A)))
  167. (cond ((or (= af AF_INET)
  168. (= af AF_INET6))
  169. (car (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV))))
  170. #? (AF_UNIX
  171. ((= af AF_UNIX) (sockaddr-path A))
  172. (#f #f))
  173. (else #f))))
  174. ;; Port and path will return #f if called on the wrong sockaddr type.
  175. ;; Maybe throw an error instead?
  176. (define (sockaddr-port A)
  177. (or
  178. ((foreign-lambda* scheme-object ((scheme-pointer sa))
  179. "switch (((struct sockaddr*)sa)->sa_family) {"
  180. "case AF_INET: C_return(C_fix(ntohs(((struct sockaddr_in*)sa)->sin_port)));"
  181. "case AF_INET6: C_return(C_fix(ntohs(((struct sockaddr_in6*)sa)->sin6_port)));"
  182. "default: C_return(C_SCHEME_FALSE); }")
  183. (sockaddr-blob A))
  184. (network-error 'sockaddr-port "unable to obtain port for socket address" A)))
  185. (define (sockaddr-path A)
  186. #? (AF_UNIX
  187. (or
  188. ((foreign-lambda* c-string ((scheme-pointer sa))
  189. "switch (((struct sockaddr*)sa)->sa_family) {"
  190. "case AF_UNIX: C_return(((struct sockaddr_un*)sa)->sun_path);"
  191. "default: C_return(NULL); }"
  192. )
  193. (sockaddr-blob A))
  194. (network-error 'sockaddr-path "unable to obtain path for socket address" A))
  195. (error 'sockaddr-path "UNIX sockets are not supported")))
  196. (define-record-printer (sockaddr A out)
  197. (fprintf out "#<sockaddr ~S>"
  198. (sockaddr->string A)
  199. ;; (integer->address-family (sockaddr-family A))
  200. ))
  201. ;; Convert socket address/path to a compact string, mainly for display purposes.
  202. (define (sockaddr->string A)
  203. (let ((af (sockaddr-family A)))
  204. (cond ((or (= af AF_INET)
  205. (= af AF_INET6))
  206. (let* ((ni (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV)))
  207. (h (car ni))
  208. (p (cdr ni)))
  209. (if (string=? p "0")
  210. h
  211. (if (= af AF_INET6)
  212. (string-append "[" h "]" ":" p)
  213. (string-append h ":" p)))))
  214. #?(AF_UNIX
  215. ((= af AF_UNIX)
  216. (sockaddr-path A)) ;; or reach directly into blob here
  217. (#f #f))
  218. (else
  219. #f))))
  220. ;; Intent of this is a direct call to getnameinfo ala inet_ntop, returning
  221. ;; a plain string; however, error handling is hard.
  222. ;; (define (sockaddr->ip-string A)
  223. ;; (foreign-lambda* c-string ((scheme-pointer sa))
  224. ;; ""
  225. ;; ))
  226. (define-foreign-record-type (ai "struct addrinfo")
  227. (constructor: alloc-ai)
  228. (destructor: free-ai) ; similar name!
  229. (int ai_flags ai-flags set-ai-flags!)
  230. (int ai_family ai-family set-ai-family!)
  231. (int ai_socktype ai-socktype set-ai-socktype!)
  232. (int ai_protocol ai-protocol set-ai-protocol!)
  233. (int ai_addrlen ai-addrlen)
  234. ((c-pointer sa) ai_addr ai-addr) ;; non-null?
  235. (c-string ai_canonname ai-canonname)
  236. ((c-pointer ai) ai_next ai-next))
  237. (define-syntax non-nil
  238. (syntax-rules ()
  239. ((_ a)
  240. (let ((x a))
  241. (if (or (not x) (null? x)) #f x)))
  242. ((_ a . rest)
  243. (let ((x a))
  244. (if (or (not x) (null? x))
  245. (non-nil . rest)
  246. x)))))
  247. (define-record addrinfo
  248. flags family socktype protocol address canonname)
  249. (define-record-printer (addrinfo a out)
  250. (fprintf out "#<addrinfo ~S ~S ~S ~S~A>"
  251. (sockaddr->string (addrinfo-address a))
  252. (non-nil (integer->address-family (addrinfo-family a)) (addrinfo-family a))
  253. (non-nil (integer->socket-type (addrinfo-socktype a)) (addrinfo-socktype a))
  254. (non-nil (integer->protocol-type (addrinfo-protocol a)) (addrinfo-protocol a))
  255. (cond ((addrinfo-canonname a)
  256. => (lambda (cn) (sprintf " canonical: ~S" cn)))
  257. (else ""))
  258. ;; (addrinfo-flags a) ;; flag display isn't that interesting
  259. ))
  260. (define (ai->addrinfo ai) ;; construct addrinfo obj from ai ptr, with embedded sockaddr obj
  261. (make-addrinfo
  262. (ai-flags ai)
  263. (ai-family ai)
  264. (ai-socktype ai)
  265. (ai-protocol ai)
  266. (ai->sockaddr ai)
  267. (ai-canonname ai)))
  268. (define (ai->sockaddr ai) ;; direct construction of sockaddr object from ai pointer
  269. (and-let* ((addr (ai-addr ai)))
  270. (sa->sockaddr addr (ai-addrlen ai))))
  271. (define (ai-list->addrinfo ai) ;; construct addrinfo object list from ai linked list
  272. (let loop ((ai ai)
  273. (L '()))
  274. (if ai
  275. (loop (ai-next ai)
  276. (cons (ai->addrinfo ai) L))
  277. (reverse L))))
  278. (define (alloc-null-ai)
  279. (let ((null! (foreign-lambda* void ((ai ai))
  280. "memset(ai,0,sizeof(*ai));"
  281. ))
  282. (ai (alloc-ai)))
  283. (null! ai)
  284. ai))
  285. (define _getaddrinfo
  286. (foreign-lambda int getaddrinfo c-string c-string ai (c-pointer ai)))
  287. (define freeaddrinfo
  288. (foreign-lambda void freeaddrinfo ai))
  289. (define _getnameinfo
  290. (foreign-lambda int skt_getnameinfo scheme-pointer int scheme-pointer
  291. int scheme-pointer int int))
  292. (define gai_strerror (foreign-lambda c-string "gai_strerror" int))
  293. (define-foreign-variable eai/noname int "EAI_NONAME")
  294. ;; FIXME: hints constructor is craaaap
  295. ;; Returns a c-pointer; must call freeaddrinfo on result once used.
  296. (define (getaddrinfo/ai node service family socktype protocol flags)
  297. (let-location ((res c-pointer))
  298. (let ((hints #f))
  299. (define hints (alloc-null-ai))
  300. (when family (set-ai-family! hints family))
  301. (when socktype (set-ai-socktype! hints socktype))
  302. (when flags (set-ai-flags! hints flags))
  303. (when protocol (set-ai-protocol! hints protocol))
  304. (let ((rc (_getaddrinfo node service hints #$res)))
  305. (when hints (free-ai hints))
  306. (cond ((= 0 rc)
  307. res)
  308. ((= eai/noname rc) ;; save exceptions for real errors
  309. #f)
  310. (else
  311. (when res (freeaddrinfo res)) ;; correct??
  312. (network-error 'getaddrinfo (gai_strerror rc) node)))))))
  313. (define (getaddrinfo node service family socktype protocol flags)
  314. (let* ((ai (getaddrinfo/ai node service family socktype protocol flags))
  315. (addrinfo (ai-list->addrinfo ai)))
  316. (when ai (freeaddrinfo ai))
  317. addrinfo))
  318. (define (address-information node service #!key family (type sock/stream) protocol flags)
  319. (let ((service (if (integer? service) (number->string service) service)))
  320. (getaddrinfo node service family type protocol flags)))
  321. ;; Constructor for socket address object from IP address string & SERVICE number.
  322. ;; The usual way to create such an address is via address-information; this is
  323. ;; a more efficient shortcut.
  324. ;; When ip is #f, the socket is considered intended for passive use (bind) and
  325. ;; the unspecified address will be returned. (Implicitly affects name-information.)
  326. ;; However, the unspecified address may not be useful, as it will return either
  327. ;; an inet or inet6 address (which may not match the socket family). To avoid
  328. ;; this, specify "::" or "0.0.0.0" explicitly.
  329. ;; TODO: Port range should probably be checked.
  330. (define (inet-address ip port)
  331. (let ((port (and port
  332. (cond ((and (exact? port) (number->string port)))
  333. (else (domain-error 'inet-address
  334. "port must be a numeric value or #f" port)))))
  335. (passive (if ip 0 AI_PASSIVE)))
  336. (let ((ai (getaddrinfo/ai ip port #f #f #f
  337. (+ AI_NUMERICHOST passive AI_NUMERICSERV))))
  338. (unless ai
  339. (network-error 'inet-address "invalid internet address" ip port))
  340. (let ((saddr (ai->sockaddr ai)))
  341. (freeaddrinfo ai)
  342. saddr))))
  343. ;; ADDR is either a SOCKADDR object, or an IPv4 or IPv6 string.
  344. ;; Converts returned port to numeric if possible. Does not convert 0 to #f though.
  345. ;; Note: Should add AI_NUMERICSERV to getaddrinfo call, but it may not be portable.
  346. ;; Note: (car (name-information addr flags: ni/numerichost)) ==
  347. ;; (sockaddr-address (inet-address addr 0)), so there is some redundancy.
  348. ;; (name-information (inet-address "::1" 0))
  349. (define (name-information saddr #!optional (flags 0))
  350. (define (massage ni)
  351. (cond ((string->number (cdr ni))
  352. => (lambda (p) (cons (car ni) p)))
  353. (else ni)))
  354. (massage (getnameinfo (if (string? saddr) (inet-address saddr #f) saddr)
  355. flags)))
  356. (define (getnameinfo saddr flags)
  357. (let* ((sa (sockaddr-blob saddr))
  358. (salen (sockaddr-len saddr)))
  359. (let ((node (make-string NI_MAXHOST))
  360. (serv (make-string NI_MAXSERV)))
  361. (let ((rc (_getnameinfo sa salen
  362. node NI_MAXHOST
  363. serv NI_MAXSERV flags)))
  364. (cond ((= rc 0)
  365. (cons (substring node 0 (string-index node #\nul))
  366. (substring serv 0 (string-index serv #\nul))))
  367. (else
  368. (network-error 'getnameinfo (gai_strerror rc))))))))
  369. ;;; socket operations
  370. (define socket-connect-timeout)
  371. (define socket-receive-timeout)
  372. (define socket-send-timeout)
  373. (define socket-accept-timeout)
  374. (let ()
  375. (define ((check loc) x)
  376. (when x (##sys#check-exact x loc))
  377. x)
  378. (define minute (fx* 60 1000))
  379. (set! socket-receive-timeout (make-parameter minute (check 'socket-receive-timeout)))
  380. (set! socket-send-timeout (make-parameter minute (check 'socket-send-timeout)))
  381. (set! socket-connect-timeout (make-parameter #f (check 'socket-connect-timeout)))
  382. (set! socket-accept-timeout (make-parameter #f (check 'socket-accept-timeout))))
  383. (define-foreign-variable _invalid_socket int "INVALID_SOCKET")
  384. (define-foreign-variable _ewouldblock int "EWOULDBLOCK")
  385. (define-foreign-variable _einprogress int "EINPROGRESS")
  386. (define-foreign-variable _econnrefused int "ECONNREFUSED")
  387. (define-foreign-variable _etimedout int "ETIMEDOUT")
  388. (define-foreign-variable _enetunreach int "ENETUNREACH")
  389. (define-foreign-variable _ehostunreach int "EHOSTUNREACH")
  390. (define-foreign-variable _enotconn int "ENOTCONN")
  391. (define-foreign-variable _einval int "EINVAL")
  392. (define-foreign-variable _enoprotoopt int "ENOPROTOOPT")
  393. (define-foreign-variable SHUT_RD int "SHUT_RD")
  394. (define-foreign-variable SHUT_WR int "SHUT_WR")
  395. (define-foreign-variable SHUT_RDWR int "SHUT_RDWR")
  396. (define shut/rd SHUT_RD)
  397. (define shut/wr SHUT_WR)
  398. (define shut/rdwr SHUT_RDWR)
  399. (define _close_socket (foreign-lambda int "closesocket" int))
  400. (define _make_socket_nonblocking
  401. (foreign-lambda* bool ((int fd))
  402. "#ifdef _WIN32\n"
  403. "unsigned long val = 1; C_return(ioctlsocket(fd, FIONBIO, &val) == 0);\n"
  404. "#else\n"
  405. "int val = fcntl(fd, F_GETFL, 0);"
  406. "if(val == -1) C_return(0);"
  407. "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);\n"
  408. "#endif\n"))
  409. (define select-for-read
  410. (foreign-lambda* int ((int fd))
  411. "fd_set in;
  412. struct timeval tm;
  413. int rv;
  414. FD_ZERO(&in);
  415. FD_SET(fd, &in);
  416. tm.tv_sec = tm.tv_usec = 0;
  417. rv = select(fd + 1, &in, NULL, NULL, &tm);
  418. if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
  419. C_return(rv);") )
  420. (define select-for-write
  421. (foreign-lambda* int ((int fd))
  422. "fd_set out;
  423. struct timeval tm;
  424. int rv;
  425. FD_ZERO(&out);
  426. FD_SET(fd, &out);
  427. tm.tv_sec = tm.tv_usec = 0;
  428. rv = select(fd + 1, NULL, &out, NULL, &tm);
  429. if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
  430. C_return(rv);") )
  431. ;; On Windows, non-blocking connection errors show up in except fds.
  432. (define select-for-write-or-except
  433. (foreign-lambda* int ((int fd))
  434. "fd_set out, exc;
  435. struct timeval tm;
  436. int rv;
  437. FD_ZERO(&out); FD_ZERO(&exc);
  438. FD_SET(fd, &out); FD_SET(fd, &exc);
  439. tm.tv_sec = tm.tv_usec = 0;
  440. rv = select(fd + 1, NULL, &out, &exc, &tm);
  441. if(rv > 0) { rv = (FD_ISSET(fd, &out) || FD_ISSET(fd, &exc)) ? 1 : 0; }
  442. C_return(rv);") )
  443. (define-inline (socket-timeout-error where timeout so)
  444. (##sys#signal-hook
  445. #:network-timeout-error
  446. where "operation timed out" timeout so))
  447. (define (block-for-timeout! where timeout fd type #!optional cleanup) ;; #f permitted for WHERE
  448. ;; No exported way to simultaneously wait on either an FD or a timeout event.
  449. (when timeout
  450. (##sys#thread-block-for-timeout!
  451. ##sys#current-thread
  452. (+ (current-milliseconds) timeout)))
  453. (##sys#thread-block-for-i/o! ##sys#current-thread fd type)
  454. (##sys#thread-yield!)
  455. (when (##sys#slot ##sys#current-thread 13)
  456. (if cleanup (cleanup))
  457. (##sys#signal-hook
  458. #:network-timeout-error
  459. where "operation timed out" timeout fd)))
  460. (define (get-socket-error s)
  461. ;; http://cr.yp.to/docs/connect.html describes alternative ways to retrieve
  462. ;; non-blocking socket errors.
  463. (define _getsockerr
  464. (foreign-lambda* int ((int socket))
  465. "int err;"
  466. "int optlen = sizeof(err);"
  467. "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
  468. "C_return(-1);"
  469. "C_return(err);"))
  470. (let ((err (_getsockerr s)))
  471. (cond ((fx= err 0) #f)
  472. ((fx> err 0) err)
  473. (else
  474. (_close_socket s)
  475. (network-error/errno 'get-socket-error "unable to obtain socket error code")))))
  476. ;; Silly parsing of inet address string into host and port.
  477. ;; Note: if unparsable into host/port, return full string as hostname, and let caller deal with it.
  478. ;; If host or port is empty, returns #f for that field.
  479. (define (parse-inet-address str)
  480. (let ((len (string-length str)))
  481. (if (= len 0)
  482. (values "" #f)
  483. (if (char=? (string-ref str 0) #\[)
  484. (let ((j (string-index str #\] 1)))
  485. (if j
  486. (let* ((host (substring str 1 j))
  487. (host (if (string=? host "") #f host)))
  488. (if (= (fx+ j 1) len)
  489. (values host #f) ;; bracketed address w/o port
  490. (if (char=? (string-ref str (fx+ j 1)) #\:)
  491. (let* ((port (substring str (fx+ j 2)))
  492. (port (if (string=? port "") #f port)))
  493. (values host port)) ;; bracketed address w/ port
  494. (values str #f))))
  495. (values str #f)))
  496. (let ((j (string-index str #\:)))
  497. (if j
  498. (let ((k (string-index str #\: (fx+ j 1))))
  499. (if k
  500. (values str #f) ;; a bare IPv6 address
  501. (let* ((host (substring str 0 j))
  502. (host (if (string=? host "") #f host))
  503. (port (substring str (fx+ j 1)))
  504. (port (if (string=? port "") #f port)))
  505. (values host port)))) ;; IPv4 address w/port
  506. (values str #f)) ;; an IPv4 address sans port
  507. )))))
  508. (define-record socket fileno family type protocol) ;; NB socket? conflicts with Unit posix
  509. (define-inline (%socket-fileno so)
  510. (##sys#slot so 1))
  511. (define-inline (check-socket so loc)
  512. (unless (socket? so)
  513. (type-error loc "argument is not a socket" so)))
  514. (define-record-printer (socket s out)
  515. (fprintf out "#<socket fd:~S ~S ~S>"
  516. (socket-fileno s)
  517. (non-nil (integer->address-family (socket-family s)) (socket-family s))
  518. (non-nil (integer->socket-type (socket-type s)) (socket-type s))
  519. #;(non-nil (integer->protocol-type (socket-protocol s)) (socket-protocol s))
  520. ))
  521. (define (socket family socktype #!optional (protocol 0))
  522. (define _socket (foreign-lambda int "socket" int int int))
  523. (let ((s (_socket family socktype protocol)))
  524. (when (eq? _invalid_socket s)
  525. (network-error/errno 'socket "cannot create socket"
  526. (non-nil (integer->address-family family) family)
  527. (non-nil (integer->socket-type socktype) socktype)
  528. (non-nil (integer->protocol-type protocol) protocol)))
  529. (let ((so (make-socket s family socktype protocol)))
  530. ;; Immediately set all sockets in non-blocking mode, even UDP.
  531. ;; See http://lists.nongnu.org/archive/html/chicken-users/2013-06/msg00062.html
  532. (unless (_make_socket_nonblocking s)
  533. (network-error/errno 'socket "unable to set socket to non-blocking" so))
  534. so)))
  535. (use srfi-18)
  536. ;; Stolen from sql-de-lite (itself stolen from sqlite), but modified to respect
  537. ;; actual elapsed time instead of estimated elapsed time (to mostly avoid scheduling jitter).
  538. ;; The polling intervals are not altered, only the total elapsed time.
  539. (define busy-timeout
  540. (let* ((delays '#(1 2 5 10 15 20 25 25 25 50 50 100))
  541. (ndelay (vector-length delays)))
  542. (lambda (ms)
  543. (cond
  544. ((< ms 0) (domain-error 'busy-timeout "timeout must be non-negative" ms))
  545. ((= ms 0) #f)
  546. (else
  547. (let ((start (current-milliseconds)))
  548. (lambda (so count)
  549. (let* ((delay (vector-ref delays (min count (- ndelay 1))))
  550. (prior (- (current-milliseconds) start)))
  551. (let ((delay (if (> (+ prior delay) ms)
  552. (- ms prior)
  553. delay)))
  554. (cond ((<= delay 0) #f)
  555. (else
  556. (thread-sleep! (/ delay 1000)) ;; silly division
  557. #t)))))))))))
  558. (define-constant +largest-fixnum+ (##sys#fudge 21))
  559. ;; Returns a special "transient" error (exn i/o net transient) if connection failure
  560. ;; was due to refusal, network down, etc.; in which case, the same or another
  561. ;; address could be tried later. (The socket is still closed, though.)
  562. (define (socket-connect so saddr)
  563. (define _connect (foreign-lambda int "connect" int scheme-pointer int))
  564. (define (refused? err)
  565. (or (eq? err _econnrefused) (eq? err _etimedout)
  566. (eq? err _enetunreach) (eq? err _ehostunreach)))
  567. (let ((s (socket-fileno so))
  568. (timeout (socket-connect-timeout)))
  569. (when (eq? -1 (_connect s (sockaddr-blob saddr) (sockaddr-len saddr)))
  570. (let ((err errno))
  571. (if (or (eq? err _einprogress)
  572. (eq? err _ewouldblock))
  573. (begin
  574. (cond-expand
  575. (windows ;; WINSOCK--connect failure returned in exceptfds; manually schedule
  576. (let ((wait (busy-timeout (or timeout +largest-fixnum+)))) ;; 12.4 days on 32bit
  577. (let loop ((n 0))
  578. (let ((f (select-for-write-or-except s)))
  579. (cond ((eq? f -1)
  580. (network-error/errno 'socket-connect "select failed" so))
  581. ((eq? f 0)
  582. (if (wait so n)
  583. (loop (+ n 1))
  584. (socket-timeout-error 'socket-connect timeout so)))
  585. ;; else f=1, fall through
  586. )))))
  587. (else ;; POSIX--connect failure returned in writefds
  588. (let ((f (select-for-write s))) ;; May be ready immediately; don't reschedule.
  589. (cond ((eq? f -1)
  590. (network-error/errno 'socket-connect "select failed" so))
  591. ((eq? f 0)
  592. (block-for-timeout! 'socket-connect timeout s #:output
  593. (lambda () (_close_socket s))))
  594. ;; else f=1, fall through
  595. ))))
  596. (cond ((get-socket-error s)
  597. => (lambda (err)
  598. (_close_socket s)
  599. ((if (refused? err)
  600. transient-network-error/errno*
  601. network-error/errno*)
  602. 'socket-connect err "cannot initiate connection"
  603. so saddr)))))
  604. (begin
  605. (_close_socket s)
  606. ((if (refused? err)
  607. transient-network-error/errno*
  608. network-error/errno*)
  609. 'socket-connect err "cannot initiate connection" so saddr)))))
  610. ;; perhaps socket address should be stored in socket object
  611. (void)))
  612. ;; Sequentially connect to all addrinfo objects until one succeeds, as long
  613. ;; as the connection is retryable (e.g. refused, no route, or timeout).
  614. ;; Otherwise it will error out on non-recoverable errors.
  615. ;; Returns: fresh socket associated with the succeeding connection, or throws
  616. ;; an error corresponding to the last failed connection attempt.
  617. ;; Example: (socket-connect/ai (address-information "localhost" 22 type: sock/stream))
  618. ;; NB: Connection to sock/dgram will generally succeed, so to ensure TCP connection,
  619. ;; make sure to specify sock/stream.
  620. ;; NB: On Windows XP, a 0 value for socket type will default to TCP (no matter the
  621. ;; value of protocol). address-information returns 0 for type and protocol when
  622. ;; not specified. For safety, you should always provide "type:" or specify a
  623. ;; service name (not port).
  624. (define (socket-connect/ai ais)
  625. (when (null? ais)
  626. (network-error 'socket-connect/ai "no addresses to connect to"))
  627. (let loop ((ais ais))
  628. (let* ((ai (car ais))
  629. (addr (addrinfo-address ai))
  630. (so (socket (addrinfo-family ai) (addrinfo-socktype ai) 0)))
  631. (if (null? (cdr ais))
  632. (begin (socket-connect so addr) so)
  633. (condition-case
  634. (begin (socket-connect so addr) so)
  635. (e (exn i/o net timeout)
  636. (loop (cdr ais)))
  637. (e (exn i/o net transient)
  638. (loop (cdr ais))))))))
  639. ;; (socket-bind s (addrinfo-address (car (address-information "127.0.0.1" 9112 socktype: sock/stream flags: ai/passive))))
  640. ;; ... is verbose.
  641. ;; Normal usage is (socket-bind s (inet-address "127.0.0.1" 9112)).
  642. ;; Using (inet-address #f nnn) will bind to the unspecified address, although that
  643. ;; may not match the socket type.
  644. (define (socket-bind so saddr)
  645. (define _bind (foreign-lambda int "bind" int scheme-pointer int))
  646. (let ((b (_bind (socket-fileno so) (sockaddr-blob saddr) (sockaddr-len saddr))))
  647. (if (eq? -1 b)
  648. (network-error/errno 'socket-bind "cannot bind to socket" so saddr)
  649. (void))))
  650. ;; Listening on datagram socket throws an OS error.
  651. (define (socket-listen so backlog)
  652. (define _listen (foreign-lambda int "listen" int int))
  653. (let ((l (_listen (socket-fileno so) backlog)))
  654. (when (eq? -1 l)
  655. (network-error/errno 'socket-listen "cannot listen on socket" so))))
  656. (define (socket-close so)
  657. (let ((s (socket-fileno so)))
  658. (when (fx= -1 (_close_socket s))
  659. (network-error/errno 'socket-close "could not close socket" so))))
  660. (define (socket-close* so) ;; Close socket, ignoring any error.
  661. (_close_socket (socket-fileno so))
  662. (void))
  663. ;; Returns a socket object representing the accepted connection.
  664. ;; Does not currently return the socket address of the remote, although it could;
  665. ;; alternatively you can get it from getpeername.
  666. (define (socket-accept so)
  667. (define _accept (foreign-lambda int "accept" int c-pointer c-pointer))
  668. (let ((s (socket-fileno so))
  669. (to (socket-accept-timeout)))
  670. (let restart ()
  671. (let ((f (select-for-read s)))
  672. (cond
  673. ((eq? f -1)
  674. (network-error/errno 'socket-accept "select failed" so))
  675. ((eq? f 1)
  676. (let ((s (_accept s #f #f)))
  677. (when (eq? -1 s)
  678. (network-error/errno 'socket-accept "could not accept from listener" so))
  679. (let ((so (make-socket s (socket-family so) (socket-type so) (socket-protocol so))))
  680. (unless (_make_socket_nonblocking s)
  681. (network-error/errno 'socket-accept "unable to set socket to non-blocking" so))
  682. so)))
  683. (else
  684. (block-for-timeout! 'socket-accept to s #:input)
  685. (restart)))))))
  686. ;; Returns number of bytes received. If 0, and socket is sock/stream, peer has shut down his side.
  687. (define (socket-receive! so buf #!optional (start 0) (end #f) (flags 0))
  688. (let* ((buflen (cond ((string? buf) (string-length buf))
  689. ((blob? buf) (blob-size buf))
  690. (else
  691. (network-error 'socket-receive!
  692. "receive buffer must be a blob or a string" so))))
  693. (end (or end buflen)))
  694. (check-socket so 'socket-receive!)
  695. (##sys#check-exact start)
  696. (##sys#check-exact end)
  697. (##sys#check-exact flags)
  698. (when (or (fx< start 0)
  699. (fx> end buflen)
  700. (fx< end start))
  701. (network-error 'socket-receive! "receive buffer offsets out of range" start end))
  702. (%socket-receive! so buf start (fx- end start) flags (socket-receive-timeout))))
  703. ;; Variant of socket-receive! which does not check so, buf, start, or len and which takes
  704. ;; read timeout as parameter. Basically for use in socket ports.
  705. (define (%socket-receive! so buf start len flags timeout)
  706. (define _recv_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
  707. (int len) (int flags))
  708. "C_return(recv(s,((char*)buf)+start,len,flags));"))
  709. (let ((s (%socket-fileno so)))
  710. (let restart ()
  711. (let ((n (_recv_offset s buf start len flags)))
  712. (cond ((eq? -1 n)
  713. (let ((err errno))
  714. (cond ((eq? err _ewouldblock)
  715. (block-for-timeout! 'socket-receive! timeout s #:input)
  716. (restart))
  717. (else
  718. (network-error/errno* 'socket-receive! err "cannot read from socket" so)))))
  719. (else n))))))
  720. ;; Receive up to LEN bytes from socket and return as a string.
  721. ;; TODO: Each socket or perhaps thread should have a dedicated input buffer which is
  722. ;; equal to the largest LEN ever given here, to avoid excessive allocation.
  723. ;; TODO: Should LEN default to socket-receive-buffer-size ?
  724. (define (socket-receive so len #!optional (flags 0))
  725. (let ((buf (make-string len))) ; checks len exact
  726. (check-socket so 'socket-receive)
  727. (##sys#check-exact flags)
  728. (let ((n (%socket-receive! so buf 0 len flags (socket-receive-timeout))))
  729. (if (= len n)
  730. buf
  731. (substring buf 0 n)))))
  732. ;; Returns 2 values: number of bytes received, and socket address from which they were
  733. ;; received.
  734. ;; NB Cut-and-paste from socket-receive! -- not clear whether we can safely
  735. ;; use recvfrom with NULL socket address to simulate recv() on all platforms.
  736. (define (socket-receive-from! so buf #!optional (start 0) (end #f) (flags 0))
  737. (let* ((buflen (cond ((string? buf) (string-length buf))
  738. ((blob? buf) (blob-size buf))
  739. (else
  740. (network-error 'socket-receive-from!
  741. "receive buffer must be a blob or a string" so))))
  742. (end (or end buflen)))
  743. (check-socket so 'socket-receive-from!)
  744. (##sys#check-exact start)
  745. (##sys#check-exact end)
  746. (##sys#check-exact flags)
  747. (when (or (fx< start 0)
  748. (fx> end buflen)
  749. (fx< end start))
  750. (network-error 'socket-receive-from! "receive buffer offsets out of range" start end))
  751. (let ((R (%socket-receive-from! so buf start (fx- end start) flags (socket-receive-timeout))))
  752. (values (car R) (cdr R)))))
  753. (define (%socket-receive-from! so buf start len flags timeout)
  754. (define _recvfrom_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
  755. (int len) (int flags)
  756. (scheme-pointer addr) ((c-pointer int) addrlen))
  757. "C_return(recvfrom(s,((char*)buf)+start,len,flags,addr,addrlen));"))
  758. (let-location ((addrlen int _sockaddr_storage_size))
  759. (let ((s (%socket-fileno so))
  760. (addr (make-blob _sockaddr_storage_size)))
  761. (let restart ()
  762. (let ((n (_recvfrom_offset s buf start len flags addr (location addrlen))))
  763. (cond ((eq? -1 n)
  764. (let ((err errno))
  765. (cond ((eq? err _ewouldblock)
  766. (block-for-timeout! 'socket-receive! timeout s #:input)
  767. (restart))
  768. (else
  769. (network-error/errno* 'socket-receive! err "cannot read from socket" so)))))
  770. (else
  771. (cons n
  772. (sa->sockaddr (location addr) addrlen)))))))))
  773. (define (unix-address path)
  774. (cond-expand
  775. (AF_UNIX
  776. (define _make_unix_sa
  777. (foreign-lambda* c-pointer ((nonnull-c-string path))
  778. "struct sockaddr_un *addr; "
  779. "addr = C_malloc(sizeof *addr);"
  780. "memset(addr,0,sizeof *addr);"
  781. "addr->sun_family = AF_UNIX;"
  782. "strncpy(addr->sun_path, path, sizeof addr->sun_path - 1);"
  783. "addr->sun_path[sizeof addr->sun_path - 1] = '\\0';"
  784. "C_return(addr);"))
  785. (define _free (foreign-lambda void "C_free" c-pointer))
  786. (let ((sa (_make_unix_sa path)))
  787. (let ((addr (sa->sockaddr sa (foreign-value "sizeof(struct sockaddr_un)" int))))
  788. (_free sa)
  789. addr)))
  790. (else
  791. (error 'unix-address "unix sockets are not supported on this platform"))))
  792. ;; Receive up to LEN bytes from unconnected socket and return 2 values:
  793. ;; the received string and the socket address from whence it came.
  794. ;; See TODOs at socket-receive.
  795. (define (socket-receive-from so len #!optional (flags 0))
  796. (let ((buf (make-string len))) ; checks len exact
  797. (check-socket so 'socket-receive-from)
  798. (##sys#check-exact flags)
  799. (let ((R (%socket-receive-from! so buf 0 len flags (socket-receive-timeout))))
  800. (let ((n (car R)))
  801. (values (if (= len n) buf (substring buf 0 n))
  802. (cdr R))))))
  803. (define (socket-receive-ready? so)
  804. (let ((f (select-for-read (socket-fileno so))))
  805. (when (eq? -1 f)
  806. (network-error/errno 'socket-receive-ready? "unable to check socket for input" so))
  807. (eq? 1 f)))
  808. (define socket-accept-ready? socket-receive-ready?)
  809. (define (socket-send so buf #!optional (start 0) (end #f) (flags 0))
  810. (let* ((buflen (cond ((string? buf) (string-length buf))
  811. ((blob? buf) (blob-size buf))
  812. (else
  813. (network-error 'socket-send
  814. "send buffer must be a blob or a string" so))))
  815. (end (or end buflen)))
  816. (check-socket so 'socket-send)
  817. (##sys#check-exact start)
  818. (##sys#check-exact end)
  819. (##sys#check-exact flags)
  820. (when (or (fx< start 0)
  821. (fx> end buflen)
  822. (fx< end start))
  823. (network-error 'socket-send "send buffer offsets out of range" start end))
  824. (%socket-send so buf start (fx- end start) flags (socket-send-timeout))))
  825. (define (%socket-send so buf start len flags timeout)
  826. (define _send_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
  827. (int len) (int flags))
  828. "C_return(send(s,((char*)buf)+start,len,flags));"))
  829. (let ((s (%socket-fileno so)))
  830. (let retry ((len len) (start start))
  831. (let ((n (_send_offset s buf start len flags)))
  832. (cond ((eq? -1 n)
  833. (let ((err errno))
  834. (cond ((eq? err _ewouldblock)
  835. (block-for-timeout! 'socket-send timeout s #:output)
  836. (retry len start))
  837. (else
  838. (network-error/errno* 'socket-send err "cannot send to socket" so)))))
  839. (else n))))))
  840. ;; Socket output chunk size for send-all. For compatibility with Unit TCP; maybe not necessary.
  841. ;; If #f, attempt to send as much as possible. Only question is whether it is safe to exceed
  842. ;; the socket send buffer size, which may (according to Microsoft pages) cause stalling until
  843. ;; delayed ACKs come back.
  844. (define socket-send-size (make-parameter 16384))
  845. (define socket-send-buffer-size (make-parameter #f))
  846. ;;(define socket-receive-size (make-parameter 1024)) ;;?
  847. (define socket-receive-buffer-size (make-parameter 4096))
  848. (define-foreign-variable +maximum-string-length+ int "C_HEADER_SIZE_MASK") ;; horrible
  849. (define (%socket-send-all so buf start slen flags timeout chunksz)
  850. (let ((chunksz (or chunksz +maximum-string-length+)))
  851. (let loop ((len slen) (start start))
  852. (let* ((count (fxmin chunksz len))
  853. (n (%socket-send so buf start count flags timeout)))
  854. (if (fx< n len)
  855. (loop (fx- len n) (fx+ start n))
  856. (void))))))
  857. (define (socket-send-all so buf #!optional (start 0) (end #f) (flags 0))
  858. (let* ((buflen (cond ((string? buf) (string-length buf))
  859. ((blob? buf) (blob-size buf))
  860. (else
  861. (network-error 'socket-send-all
  862. "send buffer must be a blob or a string" so))))
  863. (end (or end buflen)))
  864. (check-socket so 'socket-send-all)
  865. (##sys#check-exact start)
  866. (##sys#check-exact end)
  867. (##sys#check-exact flags)
  868. (when (or (fx< start 0)
  869. (fx> end buflen)
  870. (fx< end start))
  871. (network-error 'socket-send-all "send buffer offsets out of range" start end))
  872. (%socket-send-all so buf start (fx- end start) flags
  873. (socket-send-timeout)
  874. (socket-send-size))))
  875. ;; Like socket-send, but used for connectionless protocols; sends to non-connected
  876. ;; address SADDR.
  877. (define (socket-send-to so buf saddr #!optional (start 0) (end #f) (flags 0))
  878. (let* ((buflen (cond ((string? buf) (string-length buf))
  879. ((blob? buf) (blob-size buf))
  880. (else
  881. (network-error 'socket-send-to
  882. "send buffer must be a blob or a string" so))))
  883. (end (or end buflen)))
  884. (check-socket so 'socket-send-to)
  885. (##sys#check-exact start)
  886. (##sys#check-exact end)
  887. (##sys#check-exact flags)
  888. (when (or (fx< start 0)
  889. (fx> end buflen)
  890. (fx< end start))
  891. (network-error 'socket-send-to "send buffer offsets out of range" start end))
  892. (%socket-send-to so buf saddr start (fx- end start) flags (socket-send-timeout))))
  893. (define (%socket-send-to so buf saddr start len flags timeout)
  894. (define _sendto_offset (foreign-lambda* int ((int s) (scheme-pointer buf)
  895. (int start) (int len) (int flags)
  896. (scheme-pointer addr) (int addrlen))
  897. "C_return(sendto(s,((char*)buf)+start,len,flags,addr,addrlen));"))
  898. (let ((s (%socket-fileno so))
  899. (addr (sockaddr-blob saddr)) ;; maybe pull this out into caller
  900. (addrlen (sockaddr-len saddr)))
  901. (let retry ((len len) (start start))
  902. (let ((n (_sendto_offset s buf start len flags addr addrlen)))
  903. (cond ((eq? -1 n)
  904. (let ((err errno))
  905. (cond ((eq? err _ewouldblock)
  906. (block-for-timeout! 'socket-send-to timeout s #:output)
  907. (retry len start))
  908. (else
  909. (network-error/errno* 'socket-send-to err "cannot send to socket" so saddr)))))
  910. (else n))))))
  911. ;; Shutdown socket. If socket is not connected, silently ignore the error, because
  912. ;; the peer may have already initiated shutdown. That behavior should perhaps be configurable.
  913. (define (socket-shutdown so how) ;; how: shut/rd, shut/wr, shut/rdwr
  914. (define _shutdown (foreign-lambda int "shutdown" int int))
  915. (when (eq? -1 (_shutdown (socket-fileno so) how))
  916. (let ((err errno))
  917. (unless (eq? err _enotconn)
  918. (network-error/errno* 'socket-shutdown err "unable to shutdown socket" so how))))
  919. (void))
  920. ;; Return #f for unbound socket. On Windows, must test WSAEINVAL.
  921. ;; On UNIX, testing for port 0 should be sufficient.
  922. ;; UNIX sockets don't have a name; just return #f.
  923. (define (socket-name so) ;; a legacy name
  924. (define _free (foreign-lambda void "C_free" c-pointer))
  925. (cond #? (AF_UNIX
  926. ((eq? (socket-family so) AF_UNIX) #f)
  927. (#f #f))
  928. (else
  929. (let-location ((len int))
  930. (let ((sa (_getsockname (socket-fileno so) (location len))))
  931. (let ((err errno))
  932. (cond (sa
  933. (let ((addr (sa->sockaddr sa len)))
  934. (_free sa)
  935. (if (= 0 (sockaddr-port addr))
  936. #f
  937. addr)))
  938. (else
  939. (if (cond-expand (windows (eq? err _einval))
  940. (else #f))
  941. #f
  942. (network-error/errno 'socket-name "unable to get socket name" so))))))))))
  943. (define (socket-peer-name so)
  944. (define _free (foreign-lambda void "C_free" c-pointer))
  945. (let-location ((len int))
  946. (let ((sa (_getpeername (socket-fileno so) (location len))))
  947. (let ((err errno))
  948. (if sa
  949. (let ((addr (sa->sockaddr sa len)))
  950. (_free sa)
  951. addr)
  952. (if (eq? err _enotconn)
  953. #f
  954. (network-error/errno* 'socket-peer-name err
  955. "unable to get socket peer name" so)))))))
  956. (define _getsockname
  957. (foreign-lambda* c-pointer ((int s) ((c-pointer int) len))
  958. "struct sockaddr_storage *ss;"
  959. "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));"
  960. "*len = sizeof(*ss);"
  961. "if (getsockname(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);"
  962. "C_return(ss);"))
  963. (define _getpeername
  964. (foreign-lambda* c-pointer ((int s) ((c-pointer int) len))
  965. "struct sockaddr_storage *ss;"
  966. "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));"
  967. "*len = sizeof(*ss);"
  968. "if (getpeername(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);"
  969. "C_return(ss);"))
  970. ;;; socket options
  971. (include "socket-options.scm")
  972. ;;; ports
  973. ;; FIXME: port->fileno calls ##sys#tcp-port->fileno and requires the TCP
  974. ;; core unit to be loaded. Theoretically, we could define this ourselves,
  975. ;; and avoid this crap with compatible socket ports. However, this would
  976. ;; require tcp to be loaded first so it does not overwrite our export.
  977. ;; Also keep in mind it cannot be defined inside a module.
  978. ;; We unfortunately must maintain compatibility with Unit tcp ports so
  979. ;; that port->fileno works (relied on by, e.g., sendfile). Thus we
  980. ;; must have port of type 'socket and vector port data containing the
  981. ;; fileno as slot 0. So procedures in Unit TCP that take ports will
  982. ;; accept our ports and possibly crash :( However, we can avoid taking
  983. ;; TCP ports here by adding unique data to the end of the structure.
  984. (define-inline (socket-port-data p)
  985. (or (and (eq? (##sys#slot p 7) 'socket)
  986. (let ((d (##sys#port-data p)))
  987. (and (vector? d)
  988. (= (vector-length d) 7)
  989. (eq? (##sys#slot d 5) 'socket6)
  990. d)))
  991. (type-error 'socket-port-data "argument is not a socket port" p)))
  992. (define-inline (%socket-port-data-socket data) (##sys#slot data 6))
  993. (define-inline (%socket-port-data-input-abandoned? data) (##sys#slot data 1))
  994. (define-inline (%socket-port-data-output-abandoned? data) (##sys#slot data 2))
  995. (define (socket-i/o-port->socket p)
  996. (%socket-port-data-socket (socket-port-data p)))
  997. (define socket-i/o-ports
  998. (lambda (so)
  999. (let* ((fd (socket-fileno so))
  1000. (input-buffer-size (socket-receive-buffer-size))
  1001. (buf (make-string input-buffer-size))
  1002. (data (vector fd #f #f buf 0 'socket6 so))
  1003. (buflen 0)
  1004. (bufindex 0)
  1005. (iclosed #f)
  1006. (oclosed #f)
  1007. (outbufsize (socket-send-buffer-size))
  1008. (outbuf (and outbufsize (fx> outbufsize 0)
  1009. (make-string outbufsize)))
  1010. (outbufindex 0)
  1011. (tmr (socket-receive-timeout))
  1012. (tmw (socket-send-timeout))
  1013. (output-chunk-size (socket-send-size))
  1014. (read-input
  1015. (lambda ()
  1016. (let ((n (%socket-receive! so buf 0 input-buffer-size 0 tmr)))
  1017. (set! buflen n)
  1018. (##sys#setislot data 4 n)
  1019. (set! bufindex 0))))
  1020. (in
  1021. (make-input-port
  1022. (lambda ()
  1023. (when (fx>= bufindex buflen)
  1024. (read-input))
  1025. (if (fx>= bufindex buflen)
  1026. #!eof
  1027. (let ((c (##core#inline "C_subchar" buf bufindex)))
  1028. (set! bufindex (fx+ bufindex 1))
  1029. c) ) )
  1030. (lambda ()
  1031. (or (fx< bufindex buflen)
  1032. (socket-receive-ready? so)))
  1033. (lambda ()
  1034. (unless iclosed
  1035. (set! iclosed #t)
  1036. (unless (%socket-port-data-input-abandoned? data) ;; Skip this for dgram?
  1037. (socket-shutdown so shut/rd)) ;; Must not error if peer has shutdown.
  1038. (when oclosed
  1039. (socket-close so))))
  1040. (lambda ()
  1041. (when (fx>= bufindex buflen)
  1042. (read-input))
  1043. (if (fx< bufindex buflen)
  1044. (##core#inline "C_subchar" buf bufindex)
  1045. #!eof))
  1046. (lambda (p n dest start) ; read-string!
  1047. (let loop ((n n) (m 0) (start start))
  1048. (cond ((eq? n 0) m)
  1049. ((fx< bufindex buflen)
  1050. (let* ((rest (fx- buflen bufindex))
  1051. (n2 (if (fx< n rest) n rest)))
  1052. (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
  1053. (set! bufindex (fx+ bufindex n2))
  1054. (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
  1055. (else
  1056. (read-input)
  1057. (if (eq? buflen 0)
  1058. m
  1059. (loop n m start) ) ) ) ) )
  1060. #-scan-buffer-line-returns-3-vals
  1061. (lambda (p limit) ; read-line
  1062. (let loop ((str #f)
  1063. (limit (or limit (##sys#fudge 21))))
  1064. (cond ((fx< bufindex buflen)
  1065. (##sys#scan-buffer-line
  1066. buf
  1067. (fxmin buflen limit)
  1068. bufindex
  1069. (lambda (pos2 next)
  1070. (let* ((len (fx- pos2 bufindex))
  1071. (dest (##sys#make-string len)))
  1072. (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
  1073. (set! bufindex next)
  1074. (cond ((eq? pos2 limit) ; no line-terminator, hit limit
  1075. (if str (##sys#string-append str dest) dest))
  1076. ((eq? pos2 next) ; no line-terminator, hit buflen
  1077. (read-input)
  1078. (if (fx>= bufindex buflen)
  1079. (or str "")
  1080. (loop (if str (##sys#string-append str dest) dest)
  1081. (fx- limit len)) ) )
  1082. (else
  1083. (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
  1084. (if str (##sys#string-append str dest) dest)) ) ) ) ) )
  1085. (else
  1086. (read-input)
  1087. (if (fx< bufindex buflen)
  1088. (loop str limit)
  1089. #!eof) ) ) ) )
  1090. #+scan-buffer-line-returns-3-vals
  1091. (lambda (p limit) ; read-line
  1092. (when (fx>= bufindex buflen)
  1093. (read-input))
  1094. (if (fx>= bufindex buflen)
  1095. #!eof
  1096. (let ((limit (or limit (fx- (##sys#fudge 21) bufindex))))
  1097. (receive (next line full-line?)
  1098. (##sys#scan-buffer-line
  1099. buf
  1100. (fxmin buflen (fx+ bufindex limit))
  1101. bufindex
  1102. (lambda (pos)
  1103. (let ((nbytes (fx- pos bufindex)))
  1104. (cond ((fx>= nbytes limit)
  1105. (values #f pos #f))
  1106. (else (read-input)
  1107. (set! limit (fx- limit nbytes))
  1108. (if (fx< bufindex buflen)
  1109. (values buf bufindex
  1110. (fxmin buflen
  1111. (fx+ bufindex limit)))
  1112. (values #f bufindex #f))))) ) )
  1113. ;; Update row & column position
  1114. (if full-line?
  1115. (begin
  1116. (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
  1117. (##sys#setislot p 5 0))
  1118. (##sys#setislot p 5 (fx+ (##sys#slot p 5)
  1119. (##sys#size line))))
  1120. (set! bufindex next)
  1121. line) )) )
  1122. ;; (lambda (p) ; read-buffered
  1123. ;; (if (fx>= bufindex buflen)
  1124. ;; ""
  1125. ;; (let ((str (##sys#substring buf bufpos buflen)))
  1126. ;; (set! bufpos buflen)
  1127. ;; str)))
  1128. ) )
  1129. (output
  1130. (lambda (str off len)
  1131. (%socket-send-all so str off len 0 tmw output-chunk-size)))
  1132. (out
  1133. (make-output-port
  1134. (if outbuf
  1135. (lambda (s)
  1136. ;; This sends the whole existing buffer + string as soon as it exceeds
  1137. ;; the buffer size. That is useful to buffer small amounts of data
  1138. ;; (bufsz < chunksz). We could also send only in bufsz increments.
  1139. ;; That is useful when bufsz > chunksz and bufsz is a multiple (I think).
  1140. ;; Also may make sense when sending UDP to guarantee packets are always
  1141. ;; fixed size until an explicit flush. Of course if you have that requirement
  1142. ;; I suspect you will need to construct packets/strings yourself to ensure
  1143. ;; the last one is padded. (?)
  1144. ;; Modified from Unit TCP. No longer does string-appends to build buffer;
  1145. ;; instead writes into static buffer until exhausted, with a single
  1146. ;; string-append at end if exceeded buffer space.
  1147. (let ((olen (fx+ (##sys#size s) outbufindex)))
  1148. (cond ((fx= (##sys#size s) 0))
  1149. ((fx< olen outbufsize)
  1150. (##core#inline "C_substring_copy" s outbuf 0 (##sys#size s) outbufindex)
  1151. (set! outbufindex olen))
  1152. ((fx= olen outbufsize)
  1153. (##core#inline "C_substring_copy" s outbuf 0 (##sys#size s) outbufindex)
  1154. (output outbuf 0 outbufsize)
  1155. (set! outbufindex 0))
  1156. (else
  1157. ;; Optimizations: If empty buffer, no string-append required.
  1158. ;; Future opts: Can probably do smaller string appends of one
  1159. ;; chunk for chunk alignment, then write rest out. Until then,
  1160. ;; you can flush the buffer before a big write.
  1161. (let* ((slop (fxmod olen outbufsize))
  1162. (end (fx- olen slop)))
  1163. (print `(slop ,slop end ,end))
  1164. (let ((s (if (fx= outbufindex 0)
  1165. s
  1166. (##sys#string-append
  1167. (substring outbuf 0 outbufindex) s))))
  1168. (print `(s ,s))
  1169. (output s 0 end)
  1170. (when (fx> slop 0)
  1171. (print `(slopping))
  1172. (##core#inline "C_substring_copy" s outbuf end olen 0))
  1173. (set! outbufindex slop))))))
  1174. (void))
  1175. (lambda (s)
  1176. (when (fx> (##sys#size s) 0)
  1177. (output s 0 (##sys#size s))) ) )
  1178. (lambda ()
  1179. (unless oclosed
  1180. (set! oclosed #t)
  1181. (when (and outbuf (fx> outbufindex 0))
  1182. (output outbuf 0 outbufindex)
  1183. (set! outbufindex 0))
  1184. ;; Note some odd closesocket() behavior with discarded output at:
  1185. ;; http://msdn.microsoft.com/en-us/library/ms738547 (v=vs.85).aspx
  1186. (unless (%socket-port-data-output-abandoned? data)
  1187. (socket-shutdown so shut/wr))
  1188. (when iclosed
  1189. (socket-close so))))
  1190. (and outbuf
  1191. (lambda ()
  1192. (when (fx> outbufindex 0)
  1193. (output outbuf 0 outbufindex)
  1194. (set! outbufindex 0) ) ) ) ) ) )
  1195. (##sys#setslot in 3 "(socket)")
  1196. (##sys#setslot out 3 "(socket)")
  1197. (##sys#setslot in 7 'socket) ;; compatibility with core socket ports
  1198. (##sys#setslot out 7 'socket)
  1199. (##sys#set-port-data! in data)
  1200. (##sys#set-port-data! out data)
  1201. (values in out) ) ) )
  1202. (define (socket-abandon-port p)
  1203. (let ((d (socket-port-data p)))
  1204. (if (input-port? p)
  1205. (##sys#setislot d 1 #t)
  1206. (##sys#setislot d 2 #t)))) ;; Note: polarity is reversed from unit tcp
  1207. ;;; network startup
  1208. (define socket-startup
  1209. (foreign-lambda* bool () "
  1210. #ifdef _WIN32
  1211. C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
  1212. #else
  1213. signal(SIGPIPE, SIG_IGN);
  1214. C_return(1);
  1215. #endif
  1216. "))
  1217. ;; We require unit tcp above so this should already be done.
  1218. ;; (unless (socket-startup) ;; hopefully, this is safe to run multiple times
  1219. ;; (network-error 'socket-startup "cannot initialize socket code"))
  1220. ;;; Notes / TODOs
  1221. #|
  1222. UNIX sockets not supported because they do not exist on Windows (though we could test for this)
  1223. socket-accept should perhaps return connected peer address
  1224. not all errors close the socket (probably should) -- e.g., recv failure, send failure;
  1225. however, on a timeout, ports require that the socket stay open
  1226. implement socket-receive
  1227. output line buffering not implemented
  1228. socket ports work with datagrams
  1229. Socket type (slot 7) is deliberately set to "socket6" instead of "socket" to prevent
  1230. port->fileno from accessing port data (which is in a different format). This is hardcoded
  1231. in the core library.
  1232. --However this prevents the sendfile egg from using the fastpath! This is a critical bug.
  1233. |#