gambit-dsock-1.1/000075500000000000000000000000001230740044200137115ustar00rootroot00000000000000gambit-dsock-1.1/Makefile000064400000000000000000000030011230740044200153430ustar00rootroot00000000000000 libdir=/usr/lib includedir=/usr/include BASENAME=dsock LIBS= #LIBS=-l$(BASENAME) all: libgambc-$(BASENAME).so libgambc-$(BASENAME).c: $(BASENAME).scm $(BASENAME)-common.scm $(BASENAME)-ffi.scm gsc -:daq- -link -flat -o libgambc-$(BASENAME).c $(BASENAME).scm $(BASENAME).c: libgambc-$(BASENAME).c [ -f $< ] libgambc-$(BASENAME).o: $(BASENAME).c libgambc-$(BASENAME).c gsc -:daq- -obj -cc-options "-D___LIBRARY -D___SHARED -D___PRIMAL" $(BASENAME).c libgambc-$(BASENAME).c $(BASENAME).o: libgambc-$(BASENAME).o [ -f $< ] libgambc-$(BASENAME).so: $(BASENAME).o libgambc-$(BASENAME).o gcc -shared $(BASENAME).o libgambc-$(BASENAME).o -lgambc $(LIBS) -o libgambc-$(BASENAME).so install: libgambc-$(BASENAME).so libgambc-$(BASENAME).c install -Dp -m0644 libgambc-$(BASENAME).so $(libdir)/gambit/libgambc-$(BASENAME).so install -Dp -m0644 libgambc-$(BASENAME).c $(includedir)/gambit/libgambc-$(BASENAME).c $(BASENAME)-test: $(BASENAME)-test.scm libgambc-$(BASENAME).so echo "Run $(BASENAME)-test.scm to verify the library" gsc -:daq- -link ./libgambc-$(BASENAME).c $(BASENAME)-test.scm gsc -:daq- -obj $(BASENAME)-test.c $(BASENAME)-test_.c gcc $(BASENAME)-test.o $(BASENAME)-test_.o -lgambc -L. -lgambc-$(BASENAME) -o $(BASENAME)-test check: $(BASENAME)-test LD_LIBRARY_PATH=. ./$(BASENAME)-test -:daq- clean: rm -fv libgambc-$(BASENAME).c libgambc-$(BASENAME).o libgambc-$(BASENAME).so rm -fv $(BASENAME)-test $(BASENAME)-test.c $(BASENAME)-test.o $(BASENAME)-test_.c $(BASENAME)-test_.o $(BASENAME).c $(BASENAME).o gambit-dsock-1.1/dsock-common.scm000064400000000000000000000061401230740044200170070ustar00rootroot00000000000000;; UNIX domain sockets for Gambit-C. High-level interface. ;; ;; Copyright (C) 2013 Paul Wolneykien ;; ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . (define (raise-domain-socket-lasterror) (raise (cons 'domain-socket-exception (cons (dlasterror) (dlasterror-string))))) (define (domain-socket-exception? e) (and (pair? e) (eq? 'domain-socket-exception (car e)))) (define (domain-socket-exception-code e) (cadr e)) (define (domain-socket-exception-message e) (cddr e)) (define (make-domain-socket path backlog) (let ((socket-fd (dsocket))) (if (< 0 socket-fd) (if (= 0 (dbind socket-fd path)) (if (= 0 (dlisten socket-fd backlog)) (cons socket-fd path) (raise-domain-socket-lasterror)) (raise-domain-socket-lasterror)) (raise-domain-socket-lasterror)))) (define (domain-socket? ds) (and ds (pair? ds) (integer? (car ds)) (< 0 (car ds)) (string? (cdr ds)))) (define (assert-domain-socket ds) (or (domain-socket? ds) (raise "Instance of make-domain-socket expected"))) (define (domain-socket-fd ds) (and (assert-domain-socket ds) (car ds))) (define (domain-socket-path ds) (and (assert-domain-socket ds) (cdr ds))) (define (domain-socket-shutdown-read ds) (or (= 0 (dshutdown-read (domain-socket-fd ds))) (raise-domain-socket-lasterror))) (define (domain-socket-shutdown-write ds) (or (= 0 (dshutdown-write (domain-socket-fd ds))) (raise-domain-socket-lasterror))) (define (domain-socket-shutdown-both ds) (or (= 0 (dshutdown (domain-socket-fd ds))) (raise-domain-socket-lasterror))) (define (delete-domain-socket ds) (if (domain-socket-shutdown-both ds) (delete-file (domain-socket-path ds)) #t)) (define (domain-socket-accept ds . args) (let* ((timeout (or (and (not (null? args)) (pair? args) (car args)) -1)) (client-fd (daccept (domain-socket-fd ds) timeout))) (if (< 0 client-fd) (##open-predefined 3 (list (domain-socket-path ds) 'server) client-fd) (if (and (= 0 client-fd) (<= 0 timeout)) #f (raise-domain-socket-lasterror))))) (define *EINPROGRESS* (dsock-EINPROGRESS-code)) (define (domain-socket-connect path . args) (let ((timeout (or (and (not (null? args)) (pair? args) (car args)) -1)) (socket-fd (dsocket))) (if (< 0 socket-fd) (let ((ret (dconnect socket-fd path timeout))) (if (= 0 ret) (##open-predefined 3 (list path 'client) socket-fd) (if (= *EINPROGRESS* ret) #f (raise-domain-socket-lasterror)))) (raise-domain-socket-lasterror)))) gambit-dsock-1.1/dsock-ffi.scm000064400000000000000000000070761230740044200162740ustar00rootroot00000000000000;; UNIX domain sockets for Gambit-C. Low-level interface. ;; ;; Copyright (C) 2013 Paul Wolneykien ;; ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . (c-declare " #include #include #include #include #include #include #include ") (define dsocket (c-lambda () int "___result = socket (PF_LOCAL, SOCK_STREAM, 0);")) (define dbind (c-lambda (int char-string) int #< 0 && (fds.revents & POLLIN)) { ___result = accept (___arg1, (struct sockaddr *) &clientname, &size); } c-lambda-end )) (define dsock-EINPROGRESS-code (c-lambda () int "___result = EINPROGRESS;")) (define dconnect (c-lambda (int char-string int) int #<= 0) { if ((___result = fcntl (___arg1, F_SETFL, flags | O_NONBLOCK)) == 0) { ___result = connect (___arg1, (struct sockaddr *) &name, size); if (___result < 0) { if (errno == EINPROGRESS || errno == EALREADY) { if (poll (&fds, 1, ___arg3) > 0 && (fds.revents & POLLOUT)) { if ((___result = getsockopt (___arg1, SOL_SOCKET, SO_ERROR, &valopt, &optlen)) == 0) { ___result = errno = valopt; } } else { ___result = EINPROGRESS; } } } ret = fcntl (___arg1, F_SETFL, flags & ~O_NONBLOCK); if (___result == 0) { ___result = ret; } } } else { ___result = (int) flags; } c-lambda-end )) (define dshutdown (c-lambda (int) int #<= t maxloops) (begin (display-message name "Connection timed-out" #t) #f) (begin (thread-sleep! 0.01) (loop (+ t 1)))))))) (define (make-client name maxloops) (make-thread (lambda () (let ((socket (connect-or-report name *socket-path* maxloops))) (if (and socket (port? socket)) (begin (display-message name "Writing the data" #t) (write name socket) (force-output socket 1) (let ((res (read-and-report name socket))) (close-port socket) res)) #f))) name)) (define (accept-or-report name ds maxloops) (display-message name "Waiting for connection..." #t) (let loop ((t 0)) (let ((port (domain-socket-accept ds 0))) (if (and port (port? port)) port (if (>= t maxloops) (begin (display-message name "Connection timed-out" #t) #f) (begin (thread-yield!) (loop (+ t 1)))))))) (let ((ds (make-domain-socket *socket-path* 2)) (c1 (make-client "alpha" 50)) (c2 (make-client "beta" 50))) (thread-start! c1) (thread-start! c2) (let* ((p1 (accept-or-report "server" ds 50)) (d1 (and p1 (read-and-report "server" p1))) (p2 (accept-or-report "server" ds 50)) (d2 (and p2 (read-and-report "server" p2)))) (if p1 (begin (display-message "server" "Writing the data to the peer 1" #t) (write d1 p1) (force-output p1 1) (close-port p1))) (if p2 (begin (display-message "server" "Writing the data to the peer 2" #t) (write d2 p2) (force-output p2 1) (close-port p2))) (delete-domain-socket ds) (if (and p1 p2 (equal? (thread-join! c1) (thread-name c1)) (equal? (thread-join! c2) (thread-name c2))) (begin (display "Test passed") (newline) (exit 0)) (begin (display "Test FAILED") (newline) (exit 1))))) gambit-dsock-1.1/dsock.scm000064400000000000000000000014461230740044200155250ustar00rootroot00000000000000;; UNIX domain sockets for Gambit-C. ;; ;; Copyright (C) 2013 Paul Wolneykien ;; ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . (include "dsock-ffi.scm") (include "dsock-common.scm")