From b063c393885a62213789588c76abf3316e6bd9ed Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 21 Dec 2025 14:16:12 +0200 Subject: [PATCH] Add unix-socket support to SRFI-106 --- srfi/106.scm | 171 ++++++++++++++++++++++++++++------------------ srfi/106.sld | 3 +- srfi/106/test.scm | 3 +- 3 files changed, 110 insertions(+), 67 deletions(-) diff --git a/srfi/106.scm b/srfi/106.scm index 047573a..4203499 100644 --- a/srfi/106.scm +++ b/srfi/106.scm @@ -1,5 +1,13 @@ (define-c-library libc - `("sys/types.h" "sys/socket.h" "netdb.h" "errno.h" "fcntl.h" "poll.h") + `("sys/types.h" + "sys/socket.h" + "sys/un.h" + "netinet/in.h" + "netdb.h" + "errno.h" + "fcntl.h" + "poll.h" + "string.h") libc-name '((additional-versions ("0" "6")))) @@ -11,6 +19,7 @@ (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)) +(define-c-procedure c-strcpy libc 'strcpy 'int '(pointer pointer)) (define-record-type @@ -20,6 +29,7 @@ (define *af-inet* 2) (define *af-inet6* 10) +(define *af-unix* 1) (define *af-unspec* 0) (define *sock-stream* 1) @@ -54,73 +64,66 @@ (define socket-merge-flags (lambda flags (apply + flags))) (define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags))) -(define (make-client-socket node 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-flags (if (>= (length args) 3) - (list-ref args 2) - (socket-merge-flags *ai-v4mapped* *ai-addrconfig*))) - (ai-protocol (if (>= (length args) 4) (list-ref args 3) *ipproto-ip*)) - (binary-address (make-c-bytevector 128 0)) - (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))))) +(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))))) (when (< addrinfo-result 0) - (c-perror (string->c-utf8 "Failed get address")) + (c-perror (string->c-utf8 "make-client-socket (addrinfo) error")) (exit 1)) (when (< socket-file-descriptor 0) - (c-perror (string->c-utf8 "Failed to create socket")) + (c-perror (string->c-utf8 "make-client-socket error")) (exit 1)) (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) - (c-perror (string->c-utf8 "Failed to set the socket to nonblocking"))) - (letrec* ((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-perror (string->c-utf8 "make-client-socket (fcntl) error"))) + (letrec* ((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)))) (pollfd (make-c-bytevector 128 0))) (c-bytevector-sint-set! pollfd 0 @@ -134,9 +137,47 @@ (c-type-size 'int)) ;; TODO Why 8 works but 1 does not? (when (= (c-poll pollfd 8 5000) 0) - (error "Connection timed out"))) + (error "make-client-socket (poll) error"))) (make-socket socket-file-descriptor))) +(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*) + (c-strcpy node-pointer (string->c-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")) + (exit 1)) + (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) + (c-perror (string->c-utf8 "make-client-socket (fcntl) error")) + (exit 1)) + (let ((connect-result (c-connect socket-file-descriptor sockaddr sockaddr-size))) + (when (< connect-result 0) + (c-perror (string->c-utf8 "make-client-socket error")) + (exit 1)) + (make-socket socket-file-descriptor)))) + +(define (make-client-socket node 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-flags (if (>= (length args) 3) + (list-ref args 2) + (socket-merge-flags *ai-v4mapped* *ai-addrconfig*))) + (ai-protocol + (if (>= (length args) 4) + (list-ref args 3) + *ipproto-ip*))) + (if (equal? ai-family *af-unix*) + (make-unix-socket node service ai-family ai-socktype ai-flags ai-protocol) + (make-network-socket node service ai-family ai-socktype ai-flags ai-protocol)))) + (define message-type (lambda names (if (null? names) @@ -154,7 +195,7 @@ (msg-len (bytevector-length bv)) (sent-count (c-send (socket-file-descriptor socket) msg msg-len 0))) (when (= sent-count -1) - (c-perror (string->c-utf8 "Sending erorr")) + (c-perror (string->c-utf8 "socket-send error")) (exit 1)) sent-count)) diff --git a/srfi/106.sld b/srfi/106.sld index 4834090..fa44507 100644 --- a/srfi/106.sld +++ b/srfi/106.sld @@ -23,9 +23,10 @@ ;shutdown-method socket-merge-flags socket-purge-flags - *af-unspec* *af-inet* *af-inet6* + *af-unix* + *af-unspec* *sock-stream* *sock-dgram* *ai-canonname* diff --git a/srfi/106/test.scm b/srfi/106/test.scm index 0b4f108..56da827 100644 --- a/srfi/106/test.scm +++ b/srfi/106/test.scm @@ -1,5 +1,6 @@ -(define client-socket (make-client-socket "127.0.0.1" "3000")) +;(define client-socket (make-client-socket "127.0.0.1" "3000")) +(define client-socket (make-client-socket "/tmp/demo.sock" "3000" *af-unix*)) (socket-send client-socket (string->utf8 "Hello from test"))