Retropikzel
/
foreign-c-srfis
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add unix-socket support to SRFI-106

This commit is contained in:
retropikzel 2025-12-21 14:16:12 +02:00
parent 5661e0000d
commit b063c39388
3 changed files with 110 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
srfi/106.scm
View File

@ -1,5 +1,13 @@
(define-c-library libc (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 libc-name
'((additional-versions ("0" "6")))) '((additional-versions ("0" "6"))))
@ -11,6 +19,7 @@
(define-c-procedure c-send libc 'send 'int '(int pointer int int)) (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-read libc 'read 'int '(int pointer int))
(define-c-procedure c-poll libc 'poll 'int '(pointer int 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 <socket> (define-record-type <socket>
@ -20,6 +29,7 @@
(define *af-inet* 2) (define *af-inet* 2)
(define *af-inet6* 10) (define *af-inet6* 10)
(define *af-unix* 1)
(define *af-unspec* 0) (define *af-unspec* 0)
(define *sock-stream* 1) (define *sock-stream* 1)
@ -54,73 +64,66 @@
(define socket-merge-flags (lambda flags (apply + flags))) (define socket-merge-flags (lambda flags (apply + flags)))
(define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags))) (define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags)))
(define (make-client-socket node service . args) (define (make-network-socket node service ai-family ai-socktype ai-flags ai-protocol)
(let* ((ai-family (if (>= (length args) 1) (list-ref args 0) *af-inet*)) (let* ((addrinfo-hints (let ((pointer (make-c-bytevector 128 0)))
(ai-socktype (if (>= (length args) 2) (list-ref args 1) *sock-stream*)) (c-bytevector-sint-set! pointer
(ai-flags (if (>= (length args) 3) (c-type-size 'int)
(list-ref args 2) ai-family
(socket-merge-flags *ai-v4mapped* *ai-addrconfig*))) (native-endianness)
(ai-protocol (if (>= (length args) 4) (list-ref args 3) *ipproto-ip*)) (c-type-size 'int))
(binary-address (make-c-bytevector 128 0)) (c-bytevector-sint-set! pointer
(addrinfo-hints (let ((pointer (make-c-bytevector 128 0))) (* (c-type-size 'int) 2)
(c-bytevector-sint-set! pointer ai-socktype
(c-type-size 'int) (native-endianness)
ai-family (c-type-size 'int))
(native-endianness) pointer))
(c-type-size 'int)) (addrinfo (make-c-bytevector 128 0))
(c-bytevector-sint-set! pointer (addrinfo-result
(* (c-type-size 'int) 2) (call-with-address-of
ai-socktype addrinfo
(native-endianness) (lambda (addrinfo-address)
(c-type-size 'int)) (call-with-address-of
pointer)) addrinfo-hints
(addrinfo (make-c-bytevector 128 0)) (lambda (addrinfo-hints-address)
(addrinfo-result (c-getaddrinfo (string->c-utf8 node)
(call-with-address-of (string->c-utf8 service)
addrinfo addrinfo-hints
(lambda (addrinfo-address) addrinfo-address))))))
(call-with-address-of (socket-file-descriptor
addrinfo-hints (c-socket
(lambda (addrinfo-hints-address) ;; ai-family
(c-getaddrinfo (string->c-utf8 node) (c-bytevector-sint-ref addrinfo
(string->c-utf8 service) (c-type-size 'int)
addrinfo-hints (native-endianness)
addrinfo-address)))))) (c-type-size 'int))
(socket-file-descriptor ;; ai-socktype
(c-socket (c-bytevector-sint-ref addrinfo
;; ai-family (* (c-type-size 'int) 2)
(c-bytevector-sint-ref addrinfo (native-endianness)
(c-type-size 'int) (c-type-size 'int))
(native-endianness) ;; ai-protocol
(c-type-size 'int)) (c-bytevector-sint-ref addrinfo
;; ai-socktype (* (c-type-size 'int) 3)
(c-bytevector-sint-ref addrinfo (native-endianness)
(* (c-type-size 'int) 2) (c-type-size 'int)))))
(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) (when (< addrinfo-result 0)
(c-perror (string->c-utf8 "Failed get address")) (c-perror (string->c-utf8 "make-client-socket (addrinfo) error"))
(exit 1)) (exit 1))
(when (< socket-file-descriptor 0) (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)) (exit 1))
(when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0)
(c-perror (string->c-utf8 "Failed to set the socket to nonblocking"))) (c-perror (string->c-utf8 "make-client-socket (fcntl) error")))
(letrec* ((connect-result (c-connect socket-file-descriptor (letrec* ((connect-result
;; ai-addr (c-connect socket-file-descriptor
(c-bytevector-pointer-ref addrinfo ;; ai-addr
(* (c-type-size 'int) 6) (c-bytevector-pointer-ref addrinfo
) (* (c-type-size 'int) 6))
;; ai-addrlen ;; ai-addrlen
(c-bytevector-sint-ref addrinfo (c-bytevector-sint-ref addrinfo
(* (c-type-size 'int) 4) (* (c-type-size 'int) 4)
(native-endianness) (native-endianness)
(c-type-size 'int)))) (c-type-size 'int))))
(pollfd (make-c-bytevector 128 0))) (pollfd (make-c-bytevector 128 0)))
(c-bytevector-sint-set! pollfd (c-bytevector-sint-set! pollfd
0 0
@ -134,9 +137,47 @@
(c-type-size 'int)) (c-type-size 'int))
;; TODO Why 8 works but 1 does not? ;; TODO Why 8 works but 1 does not?
(when (= (c-poll pollfd 8 5000) 0) (when (= (c-poll pollfd 8 5000) 0)
(error "Connection timed out"))) (error "make-client-socket (poll) error")))
(make-socket socket-file-descriptor))) (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 (define message-type
(lambda names (lambda names
(if (null? names) (if (null? names)
@ -154,7 +195,7 @@
(msg-len (bytevector-length bv)) (msg-len (bytevector-length bv))
(sent-count (c-send (socket-file-descriptor socket) msg msg-len 0))) (sent-count (c-send (socket-file-descriptor socket) msg msg-len 0)))
(when (= sent-count -1) (when (= sent-count -1)
(c-perror (string->c-utf8 "Sending erorr")) (c-perror (string->c-utf8 "socket-send error"))
(exit 1)) (exit 1))
sent-count)) sent-count))

3
srfi/106.sld
View File

@ -23,9 +23,10 @@
;shutdown-method ;shutdown-method
socket-merge-flags socket-merge-flags
socket-purge-flags socket-purge-flags
*af-unspec*
*af-inet* *af-inet*
*af-inet6* *af-inet6*
*af-unix*
*af-unspec*
*sock-stream* *sock-stream*
*sock-dgram* *sock-dgram*
*ai-canonname* *ai-canonname*

3
srfi/106/test.scm
View File

@ -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")) (socket-send client-socket (string->utf8 "Hello from test"))