From 04591680139f83219a20829006c56142bbc5a41f Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 2 Jan 2026 12:21:59 +0200 Subject: [PATCH] Add make-server-socket and socket-accept into SRFI-106 --- srfi/106.scm | 231 ++++++++++++++++++++++++++++++++-------------- srfi/106.sld | 4 +- srfi/106/test.scm | 37 +++++++- 3 files changed, 200 insertions(+), 72 deletions(-) diff --git a/srfi/106.scm b/srfi/106.scm index a94e2af..ac19b20 100644 --- a/srfi/106.scm +++ b/srfi/106.scm @@ -12,10 +12,15 @@ '((additional-versions ("0" "6")))) (define-c-procedure c-socket libc 'socket 'int '(int int int)) +(define-c-procedure c-setsockopt libc 'setsockopt 'int '(int int int pointer int)) (define-c-procedure c-getaddrinfo libc 'getaddrinfo 'int '(pointer pointer pointer pointer)) (define-c-procedure c-connect libc 'connect 'int '(int pointer int)) +(define-c-procedure c-bind libc 'bind 'int '(int pointer int)) +(define-c-procedure c-listen libc 'listen 'int '(int int)) +(define-c-procedure c-accept libc 'accept 'int '(int pointer pointer)) (define-c-procedure c-perror libc 'perror 'void '(pointer)) (define-c-procedure c-fcntl libc 'fcntl 'int '(int int int)) +(define-c-procedure c-htons libc 'htons 'u16 '(u16)) (define-c-procedure c-send libc 'send 'int '(int pointer int int)) (define-c-procedure c-read libc 'read 'int '(int pointer int)) (define-c-procedure c-poll libc 'poll 'int '(pointer int int)) @@ -61,82 +66,62 @@ (define SO-ERROR 4) (define POLLIN 1) (define POLLOUT 4) +(define INADDR-ANY 0) +(define SO-REUSEADDR 2) +(define SO-REUSEPORT 15) +(define AI-PASSIVE 1) + +(define +sockaddr-size+ 16) +(define +ai-family-size+ 2) (define socket-merge-flags (lambda flags (apply + flags))) (define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags))) (define (make-network-socket node service ai-family ai-socktype ai-flags ai-protocol) - (let* ((addrinfo-hints (let ((pointer (make-c-bytevector 128 0))) - (c-bytevector-sint-set! pointer - (c-type-size 'int) - ai-family - (native-endianness) - (c-type-size 'int)) - (c-bytevector-sint-set! pointer - (* (c-type-size 'int) 2) - ai-socktype - (native-endianness) - (c-type-size 'int)) - pointer)) - (addrinfo (make-c-bytevector 128 0)) - (addrinfo-result - (call-with-address-of - addrinfo - (lambda (addrinfo-address) - (call-with-address-of - addrinfo-hints - (lambda (addrinfo-hints-address) - (c-getaddrinfo (string->c-utf8 node) - (string->c-utf8 service) - addrinfo-hints - addrinfo-address)))))) - (socket-file-descriptor - (c-socket - ;; ai-family - (c-bytevector-sint-ref addrinfo - (c-type-size 'int) - (native-endianness) - (c-type-size 'int)) - ;; ai-socktype - (c-bytevector-sint-ref addrinfo - (* (c-type-size 'int) 2) - (native-endianness) - (c-type-size 'int)) - ;; ai-protocol - (c-bytevector-sint-ref addrinfo - (* (c-type-size 'int) 3) - (native-endianness) - (c-type-size 'int))))) + (let* ((ai-family-offset (c-type-size 'int)) + (ai-socktype-offset (* (c-type-size 'int) 2)) + (ai-protocol-offset (* (c-type-size 'int) 3)) + (addrinfo-hints + (let ((pointer (make-c-bytevector 128 0))) + (c-bytevector-set! pointer 'int ai-family-offset ai-family) + (c-bytevector-set! pointer 'int ai-socktype-offset ai-socktype) + pointer)) + (addrinfo (make-c-bytevector 128 0)) + (addrinfo-result + (call-with-address-of + addrinfo + (lambda (addrinfo-address) + (call-with-address-of + addrinfo-hints + (lambda (addrinfo-hints-address) + (c-getaddrinfo (string->c-utf8 node) + (string->c-utf8 service) + addrinfo-hints + addrinfo-address)))))) + (socket-file-descriptor + (c-socket + (c-bytevector-ref addrinfo 'int ai-family-offset) + (c-bytevector-ref addrinfo 'int ai-socktype-offset) + (c-bytevector-ref addrinfo 'int ai-protocol-offset)))) (when (< addrinfo-result 0) (c-perror (string->c-utf8 "make-client-socket (addrinfo) error")) (raise-continuable "make-client-socket (addrinfo) error")) (when (< socket-file-descriptor 0) - (c-perror (string->c-utf8 "make-client-socket error")) + (c-perror (string->c-utf8 "make-client-socket (socket) error")) (raise-continuable "make-client-socket (socket) error")) (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) (c-perror (string->c-utf8 "make-client-socket (fcntl) error")) (raise-continuable "make-client-socket (fcntl) error")) - (letrec* ((connect-result + (letrec* ((ai-addr-offset (* (c-type-size 'int) 6)) + (ai-addrlen-offset (* (c-type-size 'int) 4)) + (connect-result (c-connect socket-file-descriptor - ;; ai-addr - (c-bytevector-pointer-ref addrinfo - (* (c-type-size 'int) 6)) - ;; ai-addrlen - (c-bytevector-sint-ref addrinfo - (* (c-type-size 'int) 4) - (native-endianness) - (c-type-size 'int)))) + (c-bytevector-ref addrinfo 'pointer ai-addr-offset) + (c-bytevector-ref addrinfo 'int ai-addrlen-offset))) (pollfd (make-c-bytevector 128 0))) - (c-bytevector-sint-set! pollfd - 0 - socket-file-descriptor - (native-endianness) - (c-type-size 'int)) - (c-bytevector-sint-set! pollfd - 0 - 0 - (native-endianness) - (c-type-size 'int)) + (c-bytevector-set! pollfd 'uint 0 socket-file-descriptor) + (c-bytevector-set! pollfd 'int 0 0) + ;; FIXME No magic numbers, like 8 or 1 here. Put into variable with good name ;; TODO Why 8 works but 1 does not? (when (= (c-poll pollfd 8 5000) 0) (error "make-client-socket (poll) error"))) @@ -144,18 +129,17 @@ (define (make-unix-socket node service ai-family ai-socktype ai-flags ai-protocol) (let* ((socket-file-descriptor (c-socket ai-family ai-socktype 0)) - (ai-family-size 2) (sockaddr (let* ((pointer (make-c-bytevector 128 0)) (pointer-address (c-bytevector->address pointer)) (node-pointer (address->c-bytevector - (+ pointer-address ai-family-size)))) - (c-bytevector-u16-native-set! pointer 0 *af-unix*) + (+ pointer-address +ai-family-size+)))) + (c-bytevector-set! pointer 'u16 0 *af-unix*) (c-strcpy node-pointer (string->c-utf8 node)) - pointer)) - (sockaddr-size (+ ai-family-size (bytevector-length (string->utf8 node))))) + pointer)) + (sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node))))) (when (< socket-file-descriptor 0) - (c-perror (string->c-utf8 "make-client-socket error")) + (c-perror (string->c-utf8 "make-client-socket (socket) error")) (raise-continuable "make-client-socket (socket) error")) (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) (c-perror (string->c-utf8 "make-client-socket (fcntl) error")) @@ -222,4 +206,117 @@ (error "socket-close: Not a socket" socket)) (c-close (socket-file-descriptor socket))) +(define (make-network-server-socket-old service ai-family ai-socktype ai-protocol) + (let* ((socket-file-descriptor (c-socket ai-family ai-socktype 0)) + (node "127.0.0.1") + (sockaddr + (let* ((pointer (make-c-bytevector 128 0)) + (pointer-address (c-bytevector->address pointer)) + (node-pointer (address->c-bytevector + (+ pointer-address +ai-family-size+)))) + (c-bytevector-set! pointer 'u16 0 *af-inet*) + (c-bytevector-set! pointer + 'u16 + (c-type-size 'u16) + (c-htons (string->number service))) + (c-bytevector-set! pointer 'u16 (* (c-type-size 'u16) 2) INADDR-ANY) + ;(c-strcpy node-pointer (string->c-utf8 node)) + pointer)) + (option (let ((pointer (make-c-bytevector (c-type-size 'int)))) + (c-bytevector-set! pointer 'int 0 1) + pointer)) + (sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node))))) + (when (< socket-file-descriptor 0) + (c-perror (string->c-utf8 "make-server-socket (socket) error")) + (raise-continuable "make-server-socket (socket) error")) + (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0) + (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error")) + (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error")) + (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0) + (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error")) + (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error")) + (when (< (c-bind socket-file-descriptor sockaddr +sockaddr-size+) 0) + (c-perror (string->c-utf8 "socket-accept (bind) error")) + (raise-continuable "socket-accept (bind) error")) + (when (< (c-listen socket-file-descriptor 0) 0) + (c-perror (string->c-utf8 "make-server-socket (listen) error")) + (raise-continuable "make-server-socket (listen) error")) + (make-socket socket-file-descriptor))) +(define (make-network-server-socket service ai-family ai-socktype ai-protocol) + (let* ((ai-flags AI-PASSIVE) + (ai-flags-offset 0) + (ai-family-offset (c-type-size 'int)) + (ai-socktype-offset (* (c-type-size 'int) 2)) + (ai-protocol-offset (* (c-type-size 'int) 3)) + (addrinfo-hints + (let ((pointer (make-c-bytevector 128 0))) + (c-bytevector-set! pointer 'int ai-flags-offset ai-flags) + (c-bytevector-set! pointer 'int ai-family-offset ai-family) + (c-bytevector-set! pointer 'int ai-socktype-offset ai-socktype) + pointer)) + (addrinfo (make-c-bytevector 128 0)) + (addrinfo-result + (call-with-address-of + addrinfo + (lambda (addrinfo-address) + (call-with-address-of + addrinfo-hints + (lambda (addrinfo-hints-address) + (c-getaddrinfo (string->c-utf8 "0.0.0.0") + (string->c-utf8 service) + addrinfo-hints + addrinfo-address)))))) + (socket-file-descriptor + (c-socket + (c-bytevector-ref addrinfo 'int ai-family-offset) + (c-bytevector-ref addrinfo 'int ai-socktype-offset) + (c-bytevector-ref addrinfo 'int ai-protocol-offset))) + (option (let ((pointer (make-c-bytevector (c-type-size 'int)))) + (c-bytevector-set! pointer 'int 0 1) + pointer)) + (ai-addr-offset (* (c-type-size 'int) 6)) + (ai-addr (c-bytevector-ref addrinfo 'pointer ai-addr-offset)) + (ai-addrlen-offset (* (c-type-size 'int) 4)) + (ai-addr-len (c-bytevector-ref addrinfo 'int ai-addrlen-offset))) + (when (< addrinfo-result 0) + (c-perror (string->c-utf8 "make-server-socket (addrinfo) error")) + (raise-continuable "make-server-socket (addrinfo) error")) + (when (< socket-file-descriptor 0) + (c-perror (string->c-utf8 "make-server-socket (socket) error")) + (raise-continuable "make-server-socket (socket) error")) + (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0) + (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error")) + (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error")) + (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0) + (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error")) + (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error")) + (when (< (c-bind socket-file-descriptor ai-addr ai-addr-len) 0) + (c-perror (string->c-utf8 "make-server-socket (bind) error")) + (raise-continuable "make-servever-socket (bind) error")) + (when (< (c-listen socket-file-descriptor 5) 0) + (c-perror (string->c-utf8 "make-server-socket (listen) error")) + (raise-continuable "make-server-socket (listen) error")) + (make-socket socket-file-descriptor))) + +(define (make-server-socket service . args) + (let* ((ai-family (if (>= (length args) 1) (list-ref args 0) *af-inet*)) + (ai-socktype (if (>= (length args) 2) (list-ref args 1) *sock-stream*)) + (ai-protocol (if (>= (length args) 3) (list-ref args 2) *ipproto-ip*))) + (if (equal? ai-family *af-unix*) + ;(make-unix-server-socket node service ai-family ai-socktype ai-protocol) + (error "Unix server sockets are WIP") + (make-network-server-socket service ai-family ai-socktype ai-protocol)))) + +(define (socket-accept socket) + (let* ((addrlen (let ((pointer (make-c-bytevector (c-type-size 'int)))) + (c-bytevector-set! pointer 'int 0 128) + pointer)) + (client-sockaddr (make-c-bytevector 128 0)) + (accepted-socket (c-accept (socket-file-descriptor socket) + client-sockaddr + addrlen))) + (when (< accepted-socket 0) + (c-perror (string->c-utf8 "socket-accept (accept) error")) + (raise-continuable "socket-accept (accept) error")) + (make-socket accepted-socket))) diff --git a/srfi/106.sld b/srfi/106.sld index 3fabb29..0485279 100644 --- a/srfi/106.sld +++ b/srfi/106.sld @@ -5,9 +5,9 @@ (scheme process-context) (foreign c)) (export make-client-socket - ;make-server-socket + make-server-socket socket? - ;socket-accept + socket-accept socket-send socket-recv ;socket-shutdown diff --git a/srfi/106/test.scm b/srfi/106/test.scm index 66368b3..3d5fecc 100644 --- a/srfi/106/test.scm +++ b/srfi/106/test.scm @@ -2,12 +2,15 @@ (define-c-library libc `("stdlib.h") libc-name '((additional-versions ("0" "6")))) (define-c-procedure c-system libc 'system 'int '(pointer)) +(c-system (string->c-utf8 "echo \"lol\" | nc -l 3001 &")) -(c-system (string->c-utf8 "echo \"lol\" | nc -l 3000 &")) - -(define sock1 (make-client-socket "127.0.0.1" "3000")) +(define sock1 (make-client-socket "127.0.0.1" "3001")) (display "HERE sock1: ") +(write sock1) +(newline) + +(display "HERE sock1 recv: ") (write (utf8->string (socket-recv sock1 3))) (newline) @@ -16,6 +19,29 @@ (socket-close sock1) +(define sock2-port "3002") +(define sock2 (make-server-socket sock2-port)) +(display "HERE sock2: ") +(write sock2) +(newline) + +(display (string-append "run: echo \"lol\" | nc 127.0.0.1 " sock2-port)) +(newline) + +(define client-sock1 (socket-accept sock2)) +(display "HERE client-sock1: ") +(write client-sock1) +(newline) + +(socket-send client-sock1 (string->utf8 "Hello from client-sock1\n")) + +(display "HERE client-sock1 recv: ") +(write (utf8->string (socket-recv client-sock1 3))) +(newline) + + + +#| (c-system (string->c-utf8 "echo \"lol\" | nc -l -U /tmp/demo.sock &")) (define sock2 (make-client-socket "/tmp/demo.sock" "3000" *af-unix*)) @@ -28,3 +54,8 @@ (socket-send sock2 (string->utf8 "Hello from sock2\n")) (socket-close sock2) +|# + + + +