Implement SRFI 106.

Reference: http://srfi.schemers.org/srfi-106/

Signed-off-by: OGINO Masanori <masanori.ogino@gmail.com>

contrib/40.srfi/docs/doc.rst

@@ -36,6 +36,11 @@ SRFI libraries
 
   Sorting and Marging.
 
+- `(srfi 106)
+  <http://srfi.schemers.org/srfi-106/>`_
+
+  Basic socket interface
+
 - `(srfi 111)
   <http://srfi.schemers.org/srfi-111/>`_
 

contrib/40.srfi/examples/106/simple-echo-client.scm

@@ -0,0 +1,29 @@
+; A R7RS port of "simple echo client" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+        (srfi 106))
+
+(define echo-client-socket (make-client-socket "localhost" "5000"))
+
+(socket-send echo-client-socket (string->utf8 "hello\r\n"))
+(socket-recv echo-client-socket (string-length "hello\r\n"))

contrib/40.srfi/examples/106/simple-echo-server.scm

@@ -0,0 +1,47 @@
+; A R7RS port of "simple echo server" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+        (srfi 106))
+
+(define echo-server-socket (make-server-socket "5000"))
+
+(define (server-run)
+  (define (get-line-from-binary-port bin)
+    (utf8->string
+      (call-with-port (open-output-bytevector)
+        (lambda (out)
+          (let loop ((b (read-u8 bin)))
+            (case b
+              ((10) (get-output-bytevector out))
+              ((13) (loop (read-u8 bin)))
+              (else (write-u8 b out) (loop (read-u8 bin)))))))))
+
+  (call-with-socket (socket-accept echo-server-socket)
+    (lambda (sock)
+      (let ((in (socket-input-port sock))
+            (out (socket-output-port sock)))
+        (let loop ((r (get-line-from-binary-port in)))
+          (write-bytevector (string->utf8 (string-append r "\r\n")) out)
+          (loop (get-line-from-binary-port in)))))))
+
+(server-run)

contrib/40.srfi/nitro.mk

@@ -1,3 +1,4 @@
+CONTRIB_INITS += socket
 CONTRIB_LIBS += \
 	contrib/40.srfi/srfi/1.scm\
 	contrib/40.srfi/srfi/8.scm\
@@ -6,4 +7,12 @@ CONTRIB_LIBS += \
 	contrib/40.srfi/srfi/43.scm\
 	contrib/40.srfi/srfi/60.scm\
 	contrib/40.srfi/srfi/95.scm\
+	contrib/40.srfi/srfi/106.scm\
 	contrib/40.srfi/srfi/111.scm
+CONTRIB_SRCS += contrib/40.srfi/src/106.c
+CONTRIB_TESTS += test-srfi
+
+test-srfi: bin/picrin
+	for test in `ls contrib/40.srfi/t/*.scm`; do \
+	  bin/picrin "$$test"; \
+	done

contrib/40.srfi/src/106.c

@@ -0,0 +1,521 @@
+#include "picrin.h"
+
+#include <errno.h>
+#include <netdb.h>
+#include <netinet/in.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/param.h>
+#include <sys/socket.h>
+#include <unistd.h>
+
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK EAGAIN
+#endif
+
+struct pic_socket_t {
+  int fd;
+};
+
+PIC_INLINE void
+socket_close(struct pic_socket_t *sock)
+{
+  if (sock != NULL && sock->fd != -1) {
+    close(sock->fd);
+    sock->fd = -1;
+  }
+}
+
+PIC_INLINE void
+ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock)
+{
+  if (sock != NULL && sock->fd == -1) {
+    pic_errorf(pic, "the socket is already closed");
+  }
+}
+
+static void
+socket_dtor(pic_state *pic, void *data)
+{
+  struct pic_socket_t *sock;
+
+  sock = data;
+  socket_close(sock);
+  pic_free(pic, data);
+}
+
+static const pic_data_type socket_type = { "socket", socket_dtor, NULL };
+
+#define pic_socket_p(o) (pic_data_type_p((o), &socket_type))
+#define pic_socket_data_ptr(o) ((struct pic_socket_t *)pic_data_ptr(o)->data)
+
+PIC_INLINE void
+validate_socket_object(pic_state *pic, pic_value v)
+{
+  if (! pic_socket_p(v)) {
+    pic_errorf(pic, "~s is not a socket object", v);
+  }
+}
+
+static pic_value
+pic_socket_socket_p(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+  return pic_bool_value(pic_socket_p(obj));
+}
+
+static pic_value
+pic_socket_make_socket(pic_state *pic)
+{
+  pic_value n, s;
+  const char *node, *service;
+  int family, socktype, flags, protocol;
+  int result;
+  struct addrinfo hints, *ai, *it;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ooiiii", &n, &s, &family, &socktype, &flags, &protocol);
+
+  node = service = NULL;
+  if (pic_str_p(n)) {
+    node = pic_str_cstr(pic, pic_str_ptr(n));
+  }
+  if (pic_str_p(s)) {
+    service = pic_str_cstr(pic, pic_str_ptr(s));
+  }
+
+  sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+  sock->fd = -1;
+
+  memset(&hints, 0, sizeof(struct addrinfo));
+  hints.ai_family = family;
+  hints.ai_socktype = socktype;
+  hints.ai_flags = flags;
+  hints.ai_protocol = protocol;
+
+  errno = 0;
+
+  do {
+    result = getaddrinfo(node, service, &hints, &ai);
+  } while (result == EAI_AGAIN);
+  if (result) {
+    if (result == EAI_SYSTEM) {
+      pic_errorf(pic, "%s", strerror(errno));
+    }
+    pic_errorf(pic, "%s", gai_strerror(result));
+  }
+
+  for (it = ai; it != NULL; it = it->ai_next) {
+    int fd;
+
+    fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol);
+    if (fd == -1) {
+      continue;
+    }
+
+    if (it->ai_flags & AI_PASSIVE) {
+      int yes = 1;
+      if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) == 0 &&
+          bind(fd, it->ai_addr, it->ai_addrlen) == 0) {
+        if (it->ai_socktype == SOCK_STREAM ||
+            it->ai_socktype == SOCK_SEQPACKET) {
+          /* TODO: Backlog should be configurable. */
+          if (listen(fd, 8) == 0) {
+              sock->fd = fd;
+              break;
+          }
+        } else {
+          sock->fd = fd;
+          break;
+        }
+      }
+    } else {
+      if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) {
+        sock->fd = fd;
+        break;
+      }
+    }
+
+    close(fd);
+  }
+
+  freeaddrinfo(ai);
+
+  if (sock->fd == -1) {
+    pic_errorf(pic, "%s", strerror(errno));
+  }
+
+  return pic_obj_value(pic_data_alloc(pic, &socket_type, sock));
+}
+
+static pic_value
+pic_socket_socket_accept(pic_state *pic)
+{
+  pic_value obj;
+  int fd = -1;
+  struct pic_socket_t *sock, *new_sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  errno = 0;
+  while (1) {
+    struct sockaddr_storage addr;
+    socklen_t addrlen = sizeof(struct sockaddr_storage);
+
+    fd = accept(sock->fd, (struct sockaddr *)&addr, &addrlen);
+
+    if (fd < 0) {
+      if (errno == EINTR) {
+        continue;
+      } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+        continue;
+      } else {
+        pic_errorf(pic, "%s", strerror(errno));
+      }
+    } else {
+      break;
+    }
+  }
+
+  new_sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+  new_sock->fd = fd;
+  return pic_obj_value(pic_data_alloc(pic, &socket_type, new_sock));
+}
+
+static pic_value
+pic_socket_socket_send(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_blob *bv;
+  const unsigned char *cursor;
+  int flags = 0;
+  size_t remain, written;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ob|i", &obj, &bv, &flags);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  cursor = bv->data;
+  remain = bv->len;
+  written = 0;
+  errno = 0;
+  while (remain > 0) {
+    ssize_t len = send(sock->fd, cursor, remain, flags);
+    if (len < 0) {
+      if (errno == EINTR) {
+        continue;
+      } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+        break;
+      } else {
+        pic_errorf(pic, "%s", strerror(errno));
+      }
+    }
+    cursor += len;
+    remain -= len;
+    written += len;
+  }
+
+  return pic_int_value(written);
+}
+
+static pic_value
+pic_socket_socket_recv(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_blob *bv;
+  void *buf;
+  int size;
+  int flags = 0;
+  ssize_t len;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "oi|i", &obj, &size, &flags);
+  validate_socket_object(pic, obj);
+  if (size < 0) {
+    pic_errorf(pic, "size must not be negative");
+  }
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  buf = malloc(size);
+  if (buf == NULL && size > 0) {
+    /* XXX: Is it really OK? */
+    pic_panic(pic, "memory exhausted");
+  }
+
+  errno = 0;
+  do {
+    len = recv(sock->fd, buf, size, flags);
+  } while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK));
+
+  if (len < 0) {
+    free(buf);
+    pic_errorf(pic, "%s", strerror(errno));
+  }
+
+  bv = pic_make_blob(pic, len);
+  memcpy(bv->data, buf, len);
+  free(buf);
+
+  return pic_obj_value(bv);
+}
+
+static pic_value
+pic_socket_socket_shutdown(pic_state *pic)
+{
+  pic_value obj;
+  int how;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "oi", &obj, &how);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  if (sock->fd != -1) {
+    shutdown(sock->fd, how);
+    sock->fd = -1;
+  }
+
+  return pic_undef_value();
+}
+
+static pic_value
+pic_socket_socket_close(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  socket_close(pic_socket_data_ptr(obj));
+
+  return pic_undef_value();
+}
+
+static int
+xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size)
+{
+  struct pic_socket_t *sock;
+
+  sock = (struct pic_socket_t *)cookie;
+
+  return recv(sock->fd, ptr, size, 0);
+}
+
+static int
+xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size)
+{
+  struct pic_socket_t *sock;
+
+  sock = (struct pic_socket_t *)cookie;
+
+  return send(sock->fd, ptr, size, 0);
+}
+
+static long
+xf_socket_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence))
+{
+  errno = EBADF;
+  return -1;
+}
+
+static int
+xf_socket_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie))
+{
+  return 0;
+}
+
+static struct pic_port *
+make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir)
+{
+  struct pic_port *port;
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = xfunopen(pic, sock, xf_socket_read, xf_socket_write, xf_socket_seek, xf_socket_close);
+  port->flags = dir | PIC_PORT_BINARY | PIC_PORT_OPEN;
+  return port;
+}
+
+static pic_value
+pic_socket_socket_input_port(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN));
+}
+
+static pic_value
+pic_socket_socket_output_port(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT));
+}
+
+static pic_value
+pic_socket_call_with_socket(pic_state *pic)
+{
+  pic_value obj, result;
+  struct pic_proc *proc;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ol", &obj, &proc);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  result = pic_apply1(pic, proc, obj);
+
+  socket_close(sock);
+
+  return result;
+}
+
+void
+pic_init_socket(pic_state *pic)
+{
+  pic_deflibrary (pic, "(srfi 106)") {
+    pic_defun(pic, "socket?", pic_socket_socket_p);
+    pic_defun(pic, "make-socket", pic_socket_make_socket);
+    pic_defun(pic, "socket-accept", pic_socket_socket_accept);
+    pic_defun(pic, "socket-send", pic_socket_socket_send);
+    pic_defun(pic, "socket-recv", pic_socket_socket_recv);
+    pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown);
+    pic_defun(pic, "socket-close", pic_socket_socket_close);
+    pic_defun(pic, "socket-input-port", pic_socket_socket_input_port);
+    pic_defun(pic, "socket-output-port", pic_socket_socket_output_port);
+    pic_defun(pic, "call-with-socket", pic_socket_call_with_socket);
+
+#ifdef AF_INET
+    pic_define(pic, "*af-inet*", pic_int_value(AF_INET));
+#else
+    pic_define(pic, "*af-inet*", pic_false_value());
+#endif
+#ifdef AF_INET6
+    pic_define(pic, "*af-inet6*", pic_int_value(AF_INET6));
+#else
+    pic_define(pic, "*af-inet6*", pic_false_value());
+#endif
+#ifdef AF_UNSPEC
+    pic_define(pic, "*af-unspec*", pic_int_value(AF_UNSPEC));
+#else
+    pic_define(pic, "*af-unspec*", pic_false_value());
+#endif
+
+#ifdef SOCK_STREAM
+    pic_define(pic, "*sock-stream*", pic_int_value(SOCK_STREAM));
+#else
+    pic_define(pic, "*sock-stream*", pic_false_value());
+#endif
+#ifdef SOCK_DGRAM
+    pic_define(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM));
+#else
+    pic_define(pic, "*sock-dgram*", pic_false_value());
+#endif
+
+#ifdef AI_CANONNAME
+    pic_define(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME));
+#else
+    pic_define(pic, "*ai-canonname*", pic_false_value());
+#endif
+#ifdef AI_NUMERICHOST
+    pic_define(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST));
+#else
+    pic_define(pic, "*ai-numerichost*", pic_false_value());
+#endif
+/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
+#if defined(AI_V4MAPPED) && !defined(BSD)
+    pic_define(pic, "*ai-v4mapped*", pic_int_value(AI_V4MAPPED));
+#else
+    pic_define(pic, "*ai-v4mapped*", pic_false_value());
+#endif
+#if defined(AI_ALL) && !defined(BSD)
+    pic_define(pic, "*ai-all*", pic_int_value(AI_ALL));
+#else
+    pic_define(pic, "*ai-all*", pic_false_value());
+#endif
+#ifdef AI_ADDRCONFIG
+    pic_define(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG));
+#else
+    pic_define(pic, "*ai-addrconfig*", pic_false_value());
+#endif
+#ifdef AI_PASSIVE
+    pic_define(pic, "*ai-passive*", pic_int_value(AI_PASSIVE));
+#else
+    pic_define(pic, "*ai-passive*", pic_false_value());
+#endif
+
+#ifdef IPPROTO_IP
+    pic_define(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP));
+#else
+    pic_define(pic, "*ipproto-ip*", pic_false_value());
+#endif
+#ifdef IPPROTO_TCP
+    pic_define(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP));
+#else
+    pic_define(pic, "*ipproto-tcp*", pic_false_value());
+#endif
+#ifdef IPPROTO_UDP
+    pic_define(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP));
+#else
+    pic_define(pic, "*ipproto-udp*", pic_false_value());
+#endif
+
+#ifdef MSG_PEEK
+    pic_define(pic, "*msg-peek*", pic_int_value(MSG_PEEK));
+#else
+    pic_define(pic, "*msg-peek*", pic_false_value());
+#endif
+#ifdef MSG_OOB
+    pic_define(pic, "*msg-oob*", pic_int_value(MSG_OOB));
+#else
+    pic_define(pic, "*msg-oob*", pic_false_value());
+#endif
+#ifdef MSG_WAITALL
+    pic_define(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL));
+#else
+    pic_define(pic, "*msg-waitall*", pic_false_value());
+#endif
+
+#ifdef SHUT_RD
+    pic_define(pic, "*shut-rd*", pic_int_value(SHUT_RD));
+#else
+    pic_define(pic, "*shut-rd*", pic_false_value());
+#endif
+#ifdef SHUT_WR
+    pic_define(pic, "*shut-wr*", pic_int_value(SHUT_WR));
+#else
+    pic_define(pic, "*shut-wr*", pic_false_value());
+#endif
+#ifdef SHUT_RDWR
+    pic_define(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR));
+#else
+    pic_define(pic, "*shut-rdwr*", pic_false_value());
+#endif
+  }
+}

contrib/40.srfi/srfi/106.scm

@@ -0,0 +1,168 @@
+(define-library (srfi 106)
+  (import (scheme base)
+          (srfi 60)
+          (picrin optional))
+
+  ; TODO: Define assq-ref anywhere else.
+  (define (assq-ref alist key . opt)
+    (cond
+      ((assq key alist) => cdr)
+      (else (if (null? opt) #f (car opt)))))
+
+  (define (socket-merge-flags flag . flags)
+    (if (null? flags)
+      flag
+      (apply socket-merge-flags (logior (or flag 0) (or (car flags) 0))
+             (cdr flags))))
+
+  (define (socket-purge-flags base-flag . flags)
+    (if (null? flags)
+      base-flag
+      (apply socket-purge-flags (logxor (or base-flag 0) (or (car flags) 0))
+             (cdr flags))))
+
+  (define (make-client-socket node service . args)
+    (let-optionals* args ((family *af-inet*)
+                          (type *sock-stream*)
+                          (flags (socket-merge-flags *ai-v4mapped*
+                                                     *ai-addrconfig*))
+                          (protocol *ipproto-ip*))
+      (make-socket node service family type flags protocol)))
+
+  (define (make-server-socket service . args)
+    (let-optionals* args ((family *af-inet*)
+                          (type *sock-stream*)
+                          (flags *ai-passive*)
+                          (protocol *ipproto-ip*))
+      (make-socket #f service family type flags protocol)))
+
+  (define %address-family `((inet .   ,*af-inet*)
+                            (inet6 .  ,*af-inet6*)
+                            (unspec . ,*af-unspec*)))
+
+  (define %socket-domain `((stream .   ,*sock-stream*)
+                           (datagram . ,*sock-dgram*)))
+
+  (define %address-info `((canoname .    ,*ai-canonname*)
+                          (numerichost . ,*ai-numerichost*)
+                          (v4mapped .    ,*ai-v4mapped*)
+                          (all .         ,*ai-all*)
+                          (addrconfig .  ,*ai-addrconfig*)))
+
+  (define %ip-protocol `((ip .  ,*ipproto-ip*)
+                         (tcp . ,*ipproto-tcp*)
+                         (udp . ,*ipproto-udp*)))
+
+  (define %message-types `((none .      0)
+                           (peek .     ,*msg-peek*)
+                           (oob .      ,*msg-oob*)
+                           (wait-all . ,*msg-waitall*)))
+
+  (define-syntax address-family
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %address-family 'name))))
+
+  (define-syntax socket-domain
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %socket-domain 'name))))
+
+  (define-syntax address-info
+    (syntax-rules ()
+      ((_ names ...)
+       (apply socket-merge-flags
+              (map (lambda (name) (assq-ref %address-info name))
+                   '(names ...))))))
+
+  (define-syntax ip-protocol
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %ip-protocol 'name))))
+
+  (define-syntax message-type
+    (syntax-rules ()
+      ((_ names ...)
+       (apply socket-merge-flags
+              (map (lambda (name) (assq-ref %message-types name))
+                   '(names ...))))))
+
+  (define (%shutdown-method names)
+    (define (state->method state)
+      (case state
+        ((read) *shut-rd*)
+        ((write) *shut-wr*)
+        ((read-write) *shut-rdwr*)
+        (else #f)))
+    (let loop ((names names)
+               (state 'none))
+      (cond
+        ((null? names) (state->method state))
+        ((eq? (car names) 'read)
+         (loop (cdr names)
+               (cond
+                 ((eq? state 'none) 'read)
+                 ((eq? state 'write) 'read-write)
+                 (else state))))
+        ((eq? (car names) 'write)
+         (loop (cdr names)
+               (cond
+                 ((eq? state 'none) 'write)
+                 ((eq? state 'read) 'read-write)
+                 (else state))))
+        (else (loop (cdr names) 'other)))))
+
+  (define-syntax shutdown-method
+    (syntax-rules ()
+      ((_ names ...)
+       (%shutdown-method '(names ...)))))
+
+  ;; Constructors and predicate
+  (export make-client-socket
+          make-server-socket
+          socket?)
+
+  ;; Socket operations
+  (export socket-accept
+          socket-send
+          socket-recv
+          socket-shutdown
+          socket-close)
+
+  ;; Port conversion
+  (export socket-input-port
+          socket-output-port)
+
+  ;; Control feature
+  (export call-with-socket)
+
+  ;; Flag operations
+  (export address-family
+          socket-domain
+          address-info
+          ip-protocol
+          message-type
+          shutdown-method
+          socket-merge-flags
+          socket-purge-flags)
+
+  ;; Constant values
+  (export *af-inet*
+          *af-inet6*
+          *af-unspec*)
+  (export *sock-stream*
+          *sock-dgram*)
+  (export *ai-canonname*
+          *ai-numerichost*
+          *ai-v4mapped*
+          *ai-all*
+          *ai-addrconfig*)
+  (export *ipproto-ip*
+          *ipproto-tcp*
+          *ipproto-udp*)
+  (export *msg-peek*
+          *msg-oob*
+          *msg-waitall*)
+  (export *shut-rd*
+          *shut-wr*
+          *shut-rdwr*))

contrib/40.srfi/t/106.scm

@@ -0,0 +1,72 @@
+(import (scheme base)
+        (srfi 106)
+        (picrin test))
+
+; The number 9600 has no meaning. I just borrowed from Rust.
+(define *test-port* 9600)
+(define (next-test-port)
+  (set! *test-port* (+ *test-port* 1))
+  (number->string *test-port*))
+
+(test #f (socket? '()))
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port)))
+  (test #t (socket? server))
+  (test #t (socket? client)))
+
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port)))
+  (test #t (socket? (socket-accept server))))
+
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port))
+       (conn (socket-accept server)))
+  (test 5 (socket-send conn (string->utf8 "hello")))
+  (test "hello" (utf8->string (socket-recv client 5))))
+
+(let* ((port (next-test-port))
+       (sock (make-server-socket port)))
+  (test #t (port? (socket-input-port sock)))
+  (test #t (port? (socket-output-port sock))))
+
+(test *ai-canonname* (socket-merge-flags *ai-canonname*))
+(test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*)
+                                         *ai-all*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*)
+                                         *ai-all*))
+
+(test *af-inet* (address-family inet))
+(test *af-inet6* (address-family inet6))
+(test *af-unspec* (address-family unspec))
+
+(test *sock-stream* (socket-domain stream))
+(test *sock-dgram* (socket-domain datagram))
+
+(test *ai-canonname* (address-info canoname))
+(test *ai-numerichost* (address-info numerichost))
+(test *ai-v4mapped* (address-info v4mapped))
+(test *ai-all* (address-info all))
+(test *ai-addrconfig* (address-info addrconfig))
+(test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*)
+      (address-info v4mapped addrconfig))
+
+(test *ipproto-ip* (ip-protocol ip))
+(test *ipproto-tcp* (ip-protocol tcp))
+(test *ipproto-udp* (ip-protocol udp))
+
+(test 0 (message-type none))
+(test *msg-peek* (message-type peek))
+(test *msg-oob* (message-type oob))
+(test *msg-waitall* (message-type wait-all))
+(test (socket-merge-flags *msg-oob* *msg-waitall*)
+      (message-type oob wait-all))
+
+(test *shut-rd* (shutdown-method read))
+(test *shut-wr* (shutdown-method write))
+(test *shut-rdwr* (shutdown-method read write))
+(test *shut-rdwr* (shutdown-method write read))