diff --git a/contrib/40.srfi/docs/doc.rst b/contrib/40.srfi/docs/doc.rst index bc95b39f..1dfc7675 100644 --- a/contrib/40.srfi/docs/doc.rst +++ b/contrib/40.srfi/docs/doc.rst @@ -36,6 +36,11 @@ SRFI libraries Sorting and Marging. +- `(srfi 106) + `_ + + Basic socket interface + - `(srfi 111) `_ diff --git a/contrib/40.srfi/examples/106/simple-echo-client.scm b/contrib/40.srfi/examples/106/simple-echo-client.scm new file mode 100644 index 00000000..cfe22edf --- /dev/null +++ b/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")) diff --git a/contrib/40.srfi/examples/106/simple-echo-server.scm b/contrib/40.srfi/examples/106/simple-echo-server.scm new file mode 100644 index 00000000..0c37b66c --- /dev/null +++ b/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) diff --git a/contrib/40.srfi/nitro.mk b/contrib/40.srfi/nitro.mk index fbb9ae38..c5fcc36d 100644 --- a/contrib/40.srfi/nitro.mk +++ b/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 diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c new file mode 100644 index 00000000..c90f5c9a --- /dev/null +++ b/contrib/40.srfi/src/106.c @@ -0,0 +1,521 @@ +#include "picrin.h" + +#include +#include +#include +#include +#include +#include +#include +#include + +#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 + } +} diff --git a/contrib/40.srfi/srfi/106.scm b/contrib/40.srfi/srfi/106.scm new file mode 100644 index 00000000..e224b603 --- /dev/null +++ b/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*)) diff --git a/contrib/40.srfi/t/106.scm b/contrib/40.srfi/t/106.scm new file mode 100644 index 00000000..24c57503 --- /dev/null +++ b/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))