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

77
srfi/106.scm
View File

@ -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 <socket>
@ -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,15 +64,8 @@
(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)))
(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
@ -104,18 +107,18 @@
(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
(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)
)
(* (c-type-size 'int) 6))
;; ai-addrlen
(c-bytevector-sint-ref addrinfo
(* (c-type-size 'int) 4)
@ -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))

3
srfi/106.sld
View File

@ -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*

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"))