Add make-server-socket and socket-accept into SRFI-106

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,22 +66,25 @@
 (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))
+  (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
@@ -92,51 +100,28 @@
                                   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)))))
+             (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)))))
+         (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)))

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

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)
+|#
+
+
+
+