1;;; socket.ss
2;;; R. Kent Dybvig May 1998
3;;; Updated November 2005
4;;; Updated by Jamie Taylor, Sept 2016
5;;; Public Domain
6;;;
7;;; bindings for socket operations and other items useful for writing
8;;; programs that use sockets.
9
10;;; Requires csocket.so, built from csocket.c.
11;;; Example compilation command line from macOS:
12;;;  cc -c csocket.c -o csocket.o
13;;;  cc csocket.o -dynamic -dynamiclib -current_version 1.0 -compatibility_version 1.0 -o csocket.so
14(load-shared-object "./csocket.so")
15
16;;; Requires from C library:
17;;;   close, dup, execl, fork, kill, listen, tmpnam, unlink
18(case (machine-type)
19  [(i3le ti3le a6le ta6le) (load-shared-object "libc.so.6")]
20  [(i3osx ti3osx a6osx ta6osx) (load-shared-object "libc.dylib")]
21  [else (load-shared-object "libc.so")])
22
23;;; basic C-library stuff
24
25(define close
26  (foreign-procedure "close" (int)
27    int))
28
29(define dup
30  (foreign-procedure "dup" (int)
31    int))
32
33(define execl4
34  (let ((execl-help
35         (foreign-procedure "execl"
36           (string string string string void*)
37           int)))
38    (lambda (s1 s2 s3 s4)
39      (execl-help s1 s2 s3 s4 0))))
40
41(define fork
42  (foreign-procedure "fork" ()
43    int))
44
45(define kill
46  (foreign-procedure "kill" (int int)
47    int))
48
49(define listen
50  (foreign-procedure "listen" (int int)
51    int))
52
53(define tmpnam
54  (foreign-procedure "tmpnam" (void*)
55    string))
56
57(define unlink
58  (foreign-procedure "unlink" (string)
59    int))
60
61;;; routines defined in csocket.c
62
63(define accept
64  (foreign-procedure "do_accept" (int)
65    int))
66
67(define bytes-ready?
68  (foreign-procedure "bytes_ready" (int)
69    boolean))
70
71(define bind
72  (foreign-procedure "do_bind" (int string)
73    int))
74
75(define c-error
76  (foreign-procedure "get_error" ()
77    string))
78
79(define c-read
80  (foreign-procedure "c_read" (int u8* size_t size_t)
81    ssize_t))
82
83(define c-write
84  (foreign-procedure "c_write" (int u8* size_t ssize_t)
85    ssize_t))
86
87(define connect
88  (foreign-procedure "do_connect" (int string)
89    int))
90
91(define socket
92  (foreign-procedure "do_socket" ()
93    int))
94
95;;; higher-level routines
96
97(define dodup
98 ; (dodup old new) closes old and dups new, then checks to
99 ; make sure that resulting fd is the same as old
100  (lambda (old new)
101    (check 'close (close old))
102    (unless (= (dup new) old)
103      (error 'dodup
104        "couldn't set up child process io for fd ~s" old))))
105
106(define dofork
107 ; (dofork child parent) forks a child process and invokes child
108 ; without arguments and parent with the child's pid
109  (lambda (child parent)
110    (let ([pid (fork)])
111      (cond
112        [(= pid 0) (child)]
113        [(> pid 0) (parent pid)]
114        [else (error 'fork (c-error))]))))
115
116(define setup-server-socket
117 ; create a socket, bind it to name, and listen for connections
118  (lambda (name)
119    (let ([sock (check 'socket (socket))])
120      (unlink name)
121      (check 'bind (bind sock name))
122      (check 'listen (listen sock 1))
123      sock)))
124
125(define setup-client-socket
126 ; create a socket and attempt to connect to server
127  (lambda (name)
128    (let ([sock (check 'socket (socket))])
129      (check 'connect (connect sock name))
130      sock)))
131
132(define accept-socket
133 ; accept a connection
134  (lambda (sock)
135    (check 'accept (accept sock))))
136
137(define check
138 ; signal an error if status x is negative, using c-error to
139 ; obtain the operating-system's error message
140  (lambda (who x)
141    (if (< x 0)
142        (error who (c-error))
143        x)))
144
145(define terminate-process
146 ; kill the process identified by pid
147  (lambda (pid)
148    (define sigterm 15)
149    (kill pid sigterm)
150    (void)))
151
152(define open-process
153  (lambda (command)
154    (define (make-r! socket)
155      (lambda (bv start n)
156        (check 'r! (c-read socket bv start n))))
157    (define (make-w! socket)
158      (lambda (bv start n)
159        (check 'w! (c-write socket bv start n))))
160    (define (make-close pid socket)
161      (lambda ()
162        (check 'close (close socket))
163        (terminate-process pid)))
164    (let* ([server-socket-name (tmpnam 0)]
165           [server-socket (setup-server-socket server-socket-name)])
166      (dofork
167        (lambda () ; child
168          (check 'close (close server-socket))
169          (let ([sock (setup-client-socket server-socket-name)])
170            (dodup 0 sock)
171            (dodup 1 sock))
172          (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" command))
173          (error 'open-process "subprocess exec failed"))
174        (lambda (pid) ; parent
175          (let ([sock (accept-socket server-socket)])
176            (check 'close (close server-socket))
177            (make-custom-binary-input/output-port command
178              (make-r! sock) (make-w! sock) #f #f (make-close pid sock))))))))
179
180#!eof
181
182;;; sample session using base socket functionality
183
184> (define client-pid)
185> (define client-socket)
186> (let* ([server-socket-name (tmpnam 0)]
187         [server-socket (setup-server-socket server-socket-name)])
188   ; fork a child, use it to exec a client Scheme process, and set
189   ; up server-side client-pid and client-socket variables.
190    (dofork   ; child
191      (lambda ()
192       ; the child establishes the socket input/output fds as
193       ; stdin and stdout, then starts a new Scheme session
194        (check 'close (close server-socket))
195        (let ([sock (setup-client-socket server-socket-name)])
196          (dodup 0 sock)
197          (dodup 1 sock))
198        (check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" "exec scheme"))
199        (error 'client "returned!"))
200      (lambda (pid) ; parent
201       ; the parent waits for a connection from the client
202        (set! client-pid pid)
203        (set! client-socket (accept-socket server-socket))
204        (check 'close (close server-socket)))))
205> (define put ; procedure to send data to client
206    (lambda (x)
207      (let* ([s (format "~s~%" x)]
208             [bv (string->utf8 s)])
209        (c-write client-socket bv 0 (bytevector-length bv)))
210      (void)))
211> (define get ; procedure to read data from client
212    (let ([buff (make-bytevector 1024)])
213      (lambda ()
214        (let* ([n (c-read client-socket buff 0 (bytevector-length buff))]
215               [bv (make-bytevector n)])
216          (bytevector-copy! buff 0 bv 0 n)
217          (printf "client:~%~a~%server:~%" (utf8->string bv))))))
218> (get)
219client:
220Chez Scheme Version 9.5.1
221Copyright 1984-2017 Cisco Systems, Inc.
222
223>
224server:
225> (put '(let ((x 3)) x))
226> (get)
227client:
2283
229>
230server:
231> (terminate-process client-pid)
232> (exit)
233
234
235;;; sample session using process port
236
237> (define p (transcoded-port (open-process "exec scheme -q") (native-transcoder)))
238> (pretty-print '(+ 3 4) p)
239> (read p)
2407
241> (pretty-print '(define (f x) (if (= x 0) 1 (* x (f (- x 1))))) p)
242> (pretty-print '(f 10) p)
243> (read p)
2443628800
245> (pretty-print '(exit) p)
246> (read p)
247#!eof
248> (close-port p)
249