350 lines
11 KiB
Scheme
350 lines
11 KiB
Scheme
;;; socket.ss
|
|
;;; R. Kent Dybvig May 1998
|
|
;;; Updated November 2005
|
|
;;; Public Domain
|
|
;;;
|
|
;;; bindings for socket operations and other items useful for writing
|
|
;;; programs that use sockets.
|
|
|
|
;;; Requires csocket.so, built from csocket.c.
|
|
(load-shared-object "./csocket.so")
|
|
|
|
;;; Requires from C library:
|
|
;;; close, dup, execl, fork, kill, listen, tmpnam, unlink
|
|
(case (machine-type)
|
|
[(i3le ti3le) (load-shared-object "libc.so.6")]
|
|
[(i3osx ti3osx) (load-shared-object "libc.dylib")]
|
|
[else (load-shared-object "libc.so")])
|
|
|
|
;;; basic C-library stuff
|
|
|
|
(define close
|
|
(foreign-procedure "close" (integer-32)
|
|
integer-32))
|
|
|
|
(define dup
|
|
(foreign-procedure "dup" (integer-32)
|
|
integer-32))
|
|
|
|
(define execl4
|
|
(let ((execl-help
|
|
(foreign-procedure "execl"
|
|
(string string string string integer-32)
|
|
integer-32)))
|
|
(lambda (s1 s2 s3 s4)
|
|
(execl-help s1 s2 s3 s4 0))))
|
|
|
|
(define fork
|
|
(foreign-procedure "fork" ()
|
|
integer-32))
|
|
|
|
(define kill
|
|
(foreign-procedure "kill" (integer-32 integer-32)
|
|
integer-32))
|
|
|
|
(define listen
|
|
(foreign-procedure "listen" (integer-32 integer-32)
|
|
integer-32))
|
|
|
|
(define tmpnam
|
|
(foreign-procedure "tmpnam" (integer-32)
|
|
string))
|
|
|
|
(define unlink
|
|
(foreign-procedure "unlink" (string)
|
|
integer-32))
|
|
|
|
;;; routines defined in csocket.c
|
|
|
|
(define accept
|
|
(foreign-procedure "do_accept" (integer-32)
|
|
integer-32))
|
|
|
|
(define bytes-ready?
|
|
(foreign-procedure "bytes_ready" (integer-32)
|
|
boolean))
|
|
|
|
(define bind
|
|
(foreign-procedure "do_bind" (integer-32 string)
|
|
integer-32))
|
|
|
|
(define c-error
|
|
(foreign-procedure "get_error" ()
|
|
string))
|
|
|
|
(define c-read
|
|
(foreign-procedure "c_read" (integer-32 string integer-32)
|
|
integer-32))
|
|
|
|
(define c-write
|
|
(foreign-procedure "c_write" (integer-32 string integer-32)
|
|
integer-32))
|
|
|
|
(define connect
|
|
(foreign-procedure "do_connect" (integer-32 string)
|
|
integer-32))
|
|
|
|
(define socket
|
|
(foreign-procedure "do_socket" ()
|
|
integer-32))
|
|
|
|
;;; higher-level routines
|
|
|
|
(define dodup
|
|
; (dodup old new) closes old and dups new, then checks to
|
|
; make sure that resulting fd is the same as old
|
|
(lambda (old new)
|
|
(check 'close (close old))
|
|
(unless (= (dup new) old)
|
|
(error 'dodup
|
|
"couldn't set up child process io for fd ~s" old))))
|
|
|
|
(define dofork
|
|
; (dofork child parent) forks a child process and invokes child
|
|
; without arguments and parent with the child's pid
|
|
(lambda (child parent)
|
|
(let ([pid (fork)])
|
|
(cond
|
|
[(= pid 0) (child)]
|
|
[(> pid 0) (parent pid)]
|
|
[else (error 'fork (c-error))]))))
|
|
|
|
(define setup-server-socket
|
|
; create a socket, bind it to name, and listen for connections
|
|
(lambda (name)
|
|
(let ([sock (check 'socket (socket))])
|
|
(unlink name)
|
|
(check 'bind (bind sock name))
|
|
(check 'listen (listen sock 1))
|
|
sock)))
|
|
|
|
(define setup-client-socket
|
|
; create a socket and attempt to connect to server
|
|
(lambda (name)
|
|
(let ([sock (check 'socket (socket))])
|
|
(check 'connect (connect sock name))
|
|
sock)))
|
|
|
|
(define accept-socket
|
|
; accept a connection
|
|
(lambda (sock)
|
|
(check 'accept (accept sock))))
|
|
|
|
(define check
|
|
; signal an error if status x is negative, using c-error to
|
|
; obtain the operating-system's error message
|
|
(lambda (who x)
|
|
(if (< x 0)
|
|
(error who (c-error))
|
|
x)))
|
|
|
|
(define terminate-process
|
|
; kill the process identified by pid
|
|
(lambda (pid)
|
|
(define sigterm 15)
|
|
(kill pid sigterm)
|
|
(void)))
|
|
|
|
(define open-process
|
|
(lambda (command)
|
|
(define handler
|
|
(lambda (pid socket)
|
|
(define (flush-output who p)
|
|
(let ([i (port-output-index p)])
|
|
(when (fx> i 0)
|
|
(check who (c-write socket (port-output-buffer p) i))
|
|
(set-port-output-index! p 0))))
|
|
(lambda (msg . args)
|
|
(record-case (cons msg args)
|
|
[block-read (p str cnt)
|
|
(critical-section
|
|
(let ([b (port-input-buffer p)]
|
|
[i (port-input-index p)]
|
|
[s (port-input-size p)])
|
|
(if (< i s)
|
|
(let ([cnt (fxmin cnt (fx- s i))])
|
|
(do ([i i (fx+ i 1)]
|
|
[j 0 (fx+ j 1)])
|
|
((fx= j cnt)
|
|
(set-port-input-index! p i)
|
|
cnt)
|
|
(string-set! str j (string-ref b i))))
|
|
(begin
|
|
(flush-output 'block-read p)
|
|
(let ([n (check 'block-read (c-read socket str cnt))])
|
|
(if (fx= n 0)
|
|
#!eof
|
|
n))))))]
|
|
[char-ready? (p)
|
|
(or (< (port-input-index p) (port-input-size p))
|
|
(bytes-ready? socket))]
|
|
[clear-input-port (p)
|
|
; set size to zero rather than index to size
|
|
; in order to invalidate unread-char
|
|
(set-port-input-size! p 0)]
|
|
[clear-output-port (p) (set-port-output-index! p 0)]
|
|
[close-port (p)
|
|
(critical-section
|
|
(flush-output 'close-port p)
|
|
(set-port-output-size! p 0)
|
|
(set-port-input-size! p 0)
|
|
(mark-port-closed! p)
|
|
(terminate-process pid))]
|
|
[file-length (p) 0]
|
|
[file-position (p . pos)
|
|
(if (null? pos)
|
|
(most-negative-fixnum)
|
|
(error 'process-port "cannot reposition"))]
|
|
[flush-output-port (p)
|
|
(critical-section
|
|
(flush-output 'flush-output-port p))]
|
|
[peek-char (p)
|
|
(critical-section
|
|
(let ([b (port-input-buffer p)]
|
|
[i (port-input-index p)]
|
|
[s (port-input-size p)])
|
|
(if (fx< i s)
|
|
(string-ref b i)
|
|
(begin
|
|
(flush-output 'peek-char p)
|
|
(let ([s (check 'peek-char (c-read socket b (string-length b)))])
|
|
(if (fx= s 0)
|
|
#!eof
|
|
(begin (set-port-input-size! p s)
|
|
(string-ref b 0))))))))]
|
|
[port-name (p) "process"]
|
|
[read-char (p)
|
|
(critical-section
|
|
(let ([b (port-input-buffer p)]
|
|
[i (port-input-index p)]
|
|
[s (port-input-size p)])
|
|
(if (fx< i s)
|
|
(begin
|
|
(set-port-input-index! p (fx+ i 1))
|
|
(string-ref b i))
|
|
(begin
|
|
(flush-output 'peek-char p)
|
|
(let ([s (check 'read-char (c-read socket b (string-length b)))])
|
|
(if (fx= s 0)
|
|
#!eof
|
|
(begin (set-port-input-size! p s)
|
|
(set-port-input-index! p 1)
|
|
(string-ref b 0))))))))]
|
|
[unread-char (c p)
|
|
(critical-section
|
|
(let ([b (port-input-buffer p)]
|
|
[i (port-input-index p)]
|
|
[s (port-input-size p)])
|
|
(when (fx= i 0)
|
|
(error 'unread-char
|
|
"tried to unread too far on ~s"
|
|
p))
|
|
(set-port-input-index! p (fx- i 1))
|
|
; following could be skipped; supposed to be
|
|
; same character
|
|
(string-set! b (fx- i 1) c)))]
|
|
[write-char (c p)
|
|
(critical-section
|
|
(let ([b (port-output-buffer p)]
|
|
[i (port-output-index p)]
|
|
[s (port-output-size p)])
|
|
(string-set! b i c)
|
|
(check 'write-char (c-write socket b (fx+ i 1)))
|
|
(set-port-output-index! p 0)))]
|
|
[block-write (p str cnt)
|
|
(critical-section
|
|
; flush buffered data
|
|
(flush-output 'block-write p)
|
|
; write new data
|
|
(check 'block-write (c-write socket str cnt)))]
|
|
[else
|
|
(error 'process-port "operation ~s not handled" msg)]))))
|
|
(let* ([server-socket-name (tmpnam 0)]
|
|
[server-socket (setup-server-socket server-socket-name)])
|
|
(dofork
|
|
(lambda () ; child
|
|
(check 'close (close server-socket))
|
|
(let ([sock (setup-client-socket server-socket-name)])
|
|
(dodup 0 sock)
|
|
(dodup 1 sock))
|
|
(check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" command))
|
|
(error 'open-process "subprocess exec failed"))
|
|
(lambda (pid) ; parent
|
|
(let ([sock (accept-socket server-socket)])
|
|
(check 'close (close server-socket))
|
|
(let ([ib (make-string 1024)] [ob (make-string 1024)])
|
|
(let ([p (make-input/output-port
|
|
(handler pid sock)
|
|
ib ob)])
|
|
(set-port-input-size! p 0)
|
|
(set-port-output-size! p (fx- (string-length ob) 1))
|
|
p))))))))
|
|
|
|
#!eof
|
|
|
|
;;; sample session using base socket functionality
|
|
|
|
> (define client-pid)
|
|
> (define client-socket)
|
|
> (let* ([server-socket-name (tmpnam 0)]
|
|
[server-socket (setup-server-socket server-socket-name)])
|
|
; fork a child, use it to exec a client Scheme process, and set
|
|
; up server-side client-pid and client-socket variables.
|
|
(dofork ; child
|
|
(lambda ()
|
|
; the child establishes the socket input/output fds as
|
|
; stdin and stdout, then starts a new Scheme session
|
|
(check 'close (close server-socket))
|
|
(let ([sock (setup-client-socket server-socket-name)])
|
|
(dodup 0 sock)
|
|
(dodup 1 sock))
|
|
(check 'execl (execl4 "/bin/sh" "/bin/sh" "-c" "exec scheme"))
|
|
(error 'client "returned!"))
|
|
(lambda (pid) ; parent
|
|
; the parent waits for a connection from the client
|
|
(set! client-pid pid)
|
|
(set! client-socket (accept-socket server-socket))
|
|
(check 'close (close server-socket)))))
|
|
> (define put ; procedure to send data to client
|
|
(lambda (x)
|
|
(let ([s (format "~s~%" x)])
|
|
(c-write client-socket s (string-length s)))
|
|
(void)))
|
|
> (define get ; procedure to read data from client
|
|
(let ([buff (make-string 1024)])
|
|
(lambda ()
|
|
(let ([n (c-read client-socket buff (string-length buff))])
|
|
(printf "client:~%~a~%server:~%" (substring buff 0 n))))))
|
|
> (get)
|
|
client:
|
|
Chez Scheme Version 7.0
|
|
Copyright (c) 1985-2005 Cadence Research Systems
|
|
|
|
>
|
|
server:
|
|
> (put '(let ((x 3)) x))
|
|
> (get)
|
|
client:
|
|
3
|
|
>
|
|
server:
|
|
> (terminate-process client-pid)
|
|
> (exit)
|
|
|
|
|
|
;;; sample session using process port
|
|
|
|
> (define p (open-process "exec scheme -q"))
|
|
> (define s (make-string 1000 #\nul))
|
|
> (pretty-print '(+ 3 4) p)
|
|
> (read p)
|
|
7
|
|
> (pretty-print '(define (f x) (if (= x 0) 1 (* x (f (- x 1))))) p)
|
|
> (pretty-print '(f 10) p)
|
|
> (read p)
|
|
3628800
|
|
> (pretty-print '(exit) p)
|
|
> (read p)
|
|
#!eof
|
|
> (close-port p)
|