#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	doc/netglue.README
#	netglue.sc
#	netglue.sch
#	cnet.c
# This archive created: Mon May 13 20:03:27 1991
export PATH; PATH=/bin:$PATH
if test ! -d 'doc'
then
	mkdir 'doc'
fi
if test -f 'doc/netglue.README'
then
	echo shar: will not over-write existing file "'doc/netglue.README'"
else
cat << \SHAR_EOF > 'doc/netglue.README'
netglue
=======
This is a Scheme->C hack that allows you to create and maintain TCP and
UDP sockets.  It has been tested on Sun3 and Sun4 machines.  It has been 
used to implement a simple distributed database and converse with a server
over a TCP connection.

There is also a facility pack/unpack for transmitting simple
Scheme objects (cons nodes, string, symbol and integer) over socket 
connections.  The packing/unpacking routines are probably byte order 
dependent, but they work for Sun3 and Sun4, and will probably work for 
other big-endian architectures.

The code blocks on read, but there is a facility for executing a background
function when no data is available for read, as well as a method of
checking before hand if any data is available.

This is in an early stage (read "alpha" release), and much cleanup will be 
done.  The magic constants for protocol family, etc. will be moved into a 
separate file for starters.

Any improvements or suggestions will be appreciated.
--
Case Larsen
clarsen@lbl.gov
SHAR_EOF
fi # end of overwriting check
if test -f 'netglue.sc'
then
	echo shar: will not over-write existing file "'netglue.sc'"
else
cat << \SHAR_EOF > 'netglue.sc'
;;; $Header: netglue.sc,v 1.11 91/05/12 20:04:50 clarsen Exp $
;;; Message passing through BSD sockets
(module netglue)

;; connections-server
;;  (cs 'establish-udp port)
;;  (cs 'send-udp from-port destination msg msglen)
;;  (cs 'add-destination destname  "hostname" port)
;;  (cs 'recv-udp our-port msg maxlen)  returns destname

;;  (cs 'recv-possible) returns destname

;;  (cs 'establish-tcp local-port)  establish a local port for TCP
;;  (cs 'connect-tcp local-port destname) establish a TCP stream between
;;       our port and a destination added with 'add-destination
;;  (cs 'write-tcp local-port msg msglen) send a message
;;  (cs 'read-tcp local-port msg maxlen)  receive a message
;;  (cs 'breakdown local-port)  teardown the connection
;;  The top-level symbol net-background should be defined, either as
;;  a procedure to call when waiting for input, or as #f.

(define-c-external (socket int int int) int "socket")
(define-c-external (bind int pointer int) int "bind")
(define-c-external (sendto int pointer int int pointer int) int "sendto")
(define-c-external (recvfrom int pointer int int pointer pointer) int "recvfrom")
(define-c-external (connect int pointer int) int "connect")
(define-c-external (unix-read int pointer int) int "read")
(define-c-external (unix-write int pointer int) int "write")

(define-c-external (close int) void "close")
(define-c-external (select-default pointer) pointer "select_default")
(define-c-external (select-read pointer) pointer "select_read")
(define-c-external (strncpy pointer pointer int) pointer "strncpy")
(define-c-external (malloc int) pointer "malloc")

(define-constant SOCK_DGRAM 2)
(define-constant SOCK_STREAM 1)
(define-constant PF_INET 2)
(define-constant IPPROTO_UDP 17)
(define-constant IPPROTO_TCP 6)
(define-constant NULL 0)

(define-constant sockaddr-size 16)
(define-constant fdset-size 256)

(define-c-external (new-sockaddr-in pointer int int) int "new_sockaddr_in")
(define-c-external (new-sockaddr-in-remote pointer int int pointer)
  int "new_sockaddr_in_remote") 
(define-c-external (bcopy pointer pointer int) pointer "bcopy")
(define-c-external (sock-matches pointer pointer) int "sock_matches")

(define-c-external (allocate-fdset) pointer "alloc_fdset")
(define-c-external (fd-set pointer int) void "fd_setfd")
(define-c-external (fd-clr pointer int) void "fd_clrfd")
(define-c-external (fd-isset pointer int) int "fd_issetfd")
(define-c-external (fd-zero pointer) void "fd_zerofd")

(define-c-external (sockaddr-attrs pointer) tscp "sockaddr_attrs")
(define-c-external (hostbyaddr tscp tscp) tscp "hostbyaddr")
(define-c-external (dump-bytes pointer) void "dump_bytes")

(define global-tmp (malloc 1024))

(define (sock-port sa)
  (vector-ref (sockaddr-attrs sa) 1)
  )

(define (assoc-sock sd slist)
  (if (null? slist)
      #f
      (if (= (sock-matches sd (cdar slist)) 1)
	  (caar slist)
	  (assoc-sock sd (cdr slist)))))

;; turn off debugging info
(define (ngddisplay . x)
;  (display x)
  x
)
(define (ngdnewline)
;  (newline)
  '()
)
(define (connections-server)
  (let ((active-sockets '())
	(active-sockets-selectmask (allocate-fdset))
	(active-destinations '()))
    (lambda msg
	(let ((cmd (car msg))
	      (body (cdr msg)))
	(cond ((equal? cmd 'as-selmask) active-sockets-selectmask)
	      ((equal? cmd 'as-destinations) active-destinations)
	      ((equal? cmd 'establish-udp)
	       (let* ((port (car body))
		      (sa (make-string sockaddr-size))
		      (s (socket PF_INET SOCK_DGRAM 0)))
		 (ngddisplay (which-fds active-sockets-selectmask 0))
		 (ngdnewline)
		 (fd-set active-sockets-selectmask s)
		 (ngddisplay (which-fds active-sockets-selectmask 0))
		 (ngdnewline)
		 (new-sockaddr-in-remote sa PF_INET
					 (if (symbol? port)
					     0
					     port)
					 "any.any.any.any")
		 (bind s sa sockaddr-size)
		 (ngddisplay (sockaddr-attrs sa))
		 (ngdnewline)
		 (set! active-sockets (cons (cons port s) active-sockets))
		 ))
	      ;; not much difference between establish-tcp and establish-udp
	      ;; except for SOCK_STREAM and SOCK_DGRAM.
	      ;; this should be factored later.
	      ((equal? cmd 'establish-tcp)
	       (let* ((port (car body))
		      (sa (make-string sockaddr-size))
		      (s (socket PF_INET SOCK_STREAM IPPROTO_TCP)))
		 (ngddisplay (which-fds active-sockets-selectmask 0))
		 (ngdnewline)
		 (fd-set active-sockets-selectmask s)
		 (ngddisplay (which-fds active-sockets-selectmask 0))
		 (ngdnewline)
		 (new-sockaddr-in-remote sa PF_INET (if (symbol? port)
							0
							port)
					 "any.any.any.any")
		 (bind s sa sockaddr-size)
		 (ngddisplay (sockaddr-attrs sa))
		 (ngdnewline)
		 (set! active-sockets (cons (cons port s) active-sockets))
		 ))
	      ((equal? cmd 'add-destination)
	       (let* ((destname (car body))
		      (hostname (cadr body))
		      (port (caddr body))
		      (sr (make-string sockaddr-size)))
		 (ngddisplay "initializing sockaddr ")
		 (ngddisplay port)
		 (ngdnewline)
		 (new-sockaddr-in-remote sr PF_INET port hostname)
		 (ngddisplay "active dest")
		 (ngdnewline)
		 (set! active-destinations (cons (cons destname sr)
						 active-destinations))))
	      ((equal? cmd 'send-udp)
	       (let* ((from-port (car body))
		      (dest (cadr body))
		      (message (caddr body))
		      (msglen (cadddr body))
		      (s (cdr (assoc from-port active-sockets)))
		      (sd (cdr (assoc dest active-destinations))))
		 (sendto s message msglen 0 sd sockaddr-size)))
	      ((equal? cmd 'recv-udp)
	       (let* ((buf (cadr body))
		      (maxlen (caddr body))
		      (our-port (car body))
		      (from (make-string sockaddr-size))
		      (s (cdr (assoc our-port active-sockets)))
		      (saddrlen (make-string 4)))
		 (c-int-set! saddrlen 0 sockaddr-size)
		 (ngddisplay "socket ")
		 (ngddisplay s)
		 (ngdnewline)
		 (ngddisplay (c-int-ref saddrlen 0))
		 (ngdnewline)
		 ;; service Xserver while waiting for message
		 (if (procedure? net-background)
		     (begin
		       (ngddisplay "servicing background tasks")
		       (ngdnewline)
		       (let loop ()
			 (if (member s
				     (which-fds (select-read
						 active-sockets-selectmask) 0))
			     (recvfrom s buf maxlen 0 from saddrlen)
			     (begin
			       (ngddisplay (which-fds (select-read
						 active-sockets-selectmask) 0))
			       (ngdnewline)
			       (net-background)
			       (loop)
			       )
			     ))
			 )
		     (recvfrom s buf maxlen 0 from saddrlen)
		     )
		 (ngddisplay "got ")
		 (ngddisplay buf)
		 (ngdnewline)
		 (let ((other-end (assoc-sock from active-destinations)))
		   (if other-end
		       other-end
		       ;; add-destination
		       (let* ((from-attrs (begin
;;;					    (ngddisplay (sockaddr-attrs from))
;;;					    (ngdnewline)
					    (sockaddr-attrs from)))
			      (deststr (begin
;;;					 (ngddisplay
;;;					  (hostbyaddr (vector-ref from-attrs 2)
;;;						      (vector-ref from-attrs 3)))
;;;					 (ngdnewline)
					 (string-append
					  (hostbyaddr (vector-ref from-attrs 2)
						      (vector-ref from-attrs 3))
					  "."
					  (number->string (vector-ref from-attrs 1))
					  "."
					  (number->string (vector-ref from-attrs 0))
					  )))
			      (sr (make-string sockaddr-size))
			      (destname (string->symbol deststr)))
			 (ngddisplay from-attrs)
			 (ngdnewline)
			 (bcopy from sr sockaddr-size)
			 (set! active-destinations (cons (cons destname sr)
							 active-destinations))
			 (assoc-sock from active-destinations))
		       ))))
	      ((equal? cmd 'connect-tcp)
	       (let* ((our-port (car body))
		      (s (cdr (assoc our-port active-sockets)))
		      (destname (cadr body))
		      (dest-sd (cdr (assoc destname active-destinations)))
		      )
		 (connect s dest-sd sockaddr-size)
		 ))
	      ((equal? cmd 'write-tcp)
	       (let* ((our-port (car body))
		      (s (cdr (assoc our-port active-sockets)))
		      (message (cadr body))
		      (msglen (caddr body))
		      )
		 (unix-write s message msglen)
		 ))
	      ((equal? cmd 'read-tcp)
	       (let* ((our-port (car body))
		      (s (cdr (assoc our-port active-sockets)))
		      (message (cadr body))
		      (maxlen (caddr body))
		      )
		 ;; service X server while waiting for message 
		 (if (procedure? net-background)
		     (begin
		       (ngddisplay "servicing background tasks")
		       (ngdnewline)
		       (let loop ()
			 (if (member s
				     (which-fds (select-read
						 active-sockets-selectmask) 0))
			     (unix-read s message maxlen)
			     (begin
			       (net-background)
			       (loop))
			     ))
			 )
		     (unix-read s message maxlen)
		     )
		 ))
	      ((equal? cmd 'teardown)
	       (let* ((our-port (car body))
		      (s (cdr (assoc our-port active-sockets)))
		      )
		 (fd-clr active-sockets-selectmask s)
		 (close s)
		 (set! active-sockets (remove! (cons our-port s)
					       active-sockets))
		 ))
	      ((equal? cmd 'recv-possible)
	       (which-fds (select-read active-sockets-selectmask) 0))
	      (else (ngddisplay "unknown message"))
	      )))))

(define (which-fds fdset i)
  (if (<  i fdset-size)
      (if ( > (fd-isset fdset i) 0)
	  (cons i (which-fds fdset (+ i 1)))
	  (which-fds fdset (+ i 1)))
      '()))

(define-constant NULLTYPE 0)
(define-constant INTTYPE 1)
(define-constant PAIRTYPE 2)
(define-constant STRINGTYPE 3)
(define-constant SYMBOLTYPE 4)

(define typelens '((int . 4)))
(define (next-addr ptr type)
  (+ ptr (cdr (assoc type typelens))))

;; XDR equivalent -- standard interchange of scheme objects
;; (pack buffer scheme-type) returns space required
;; (unpack buffer) returns scheme type
(define (pack-one ptr type val val-len)
  (cond ((equal? type 'null) (c-int-set! ptr 0 NULLTYPE))
	((equal? type 'int) (c-int-set! ptr 0 INTTYPE)
			    (c-int-set! (+ ptr 4) 0 val))
	((equal? type 'symbol) (pack-string-type SYMBOLTYPE ptr	val))
	((equal? type 'string) (pack-string-type STRINGTYPE ptr val))
	))

(define (lalign ptr len)
  (c-int-set! ptr 0 (+ len (- 4 (modulo len 4))))
)

(define (pack-string-type type ptr str)
  (let ((str-len (string-length str)))
    (c-int-set! ptr 0 type)
    ;; word align the beginning of next field
    (lalign (+ ptr 4) (+ str-len 1))
    (strncpy (+ ptr 8) str (+ 1 str-len)))
)
  

(define (space-required l)
  (if (null? l)
      4
      (cond ((integer? l) 8)
	    ;; word align the next field
	    ((string? l)  (+ 4 4 (string-length l) 1
			    (- 4 (modulo (+ (string-length l) 1) 4))))
	    ((symbol? l)  (let ((str (symbol->string l)))
			    (+ 4 4 (string-length str) 1
			       (- 4 (modulo (+ (string-length str) 1) 4)))))
	    ((pair? l) (+ 4 (space-required (car l))
			  (space-required (cdr l)))))))

(define (unpack-space-required ptr)
  (let ((type (c-int-ref ptr 0)))
    (cond ((= type NULLTYPE) 4)
	  ((= type INTTYPE) 8)
	  ((= type STRINGTYPE) (+ 8 (c-int-ref ptr 4)))
	  ((= type SYMBOLTYPE) (+ 8 (c-int-ref ptr 4)))
	  ((= type PAIRTYPE) (let ((sr (unpack-space-required (+ ptr 4))))
			       (+ 4 sr (unpack-space-required (+ ptr 4 sr)))))
	  )))	  

(define (pack ptr l)
  (if (null? l)
      (c-int-set! ptr 0 NULL)
      (begin
	(cond ((integer? l) (pack-one ptr 'int l 1))
	      ((string? l) (pack-one ptr 'string l (string-length l)))
	      ((symbol? l) (pack-one ptr 'symbol (symbol->string l)
				     (string-length (symbol->string l))))
	      ((pair? l) (c-int-set! ptr 0 PAIRTYPE)
			 (pack (+ ptr 4) (car l))
			 (pack (+ ptr 4 (space-required (car l)))
			       (cdr l))))
	(space-required l))))
(define (byte-dump ptr l)
  (if (> l 0)
      (begin
	(ngddisplay (c-int-ref ptr 0))
	(ngddisplay " ")
	(byte-dump (+ ptr 4)  (- l 4)))
))
(define (unpack ptr)
  (begin
;; (dump-bytes ptr)
    (let ((type (c-int-ref ptr 0)))
      (cond ((= type NULLTYPE)
	     '())
	    ((= type INTTYPE)
	     (c-int-ref (+ ptr 4) 0))
	    ((= type STRINGTYPE)
	     (ngddisplay   (c-string->string (+ ptr 8)))
	     (c-string->string (+ ptr 8)))
	    ((= type SYMBOLTYPE) 
	     (ngddisplay (string->symbol (c-string->string (+ ptr 8))))
	     (string->symbol (c-string->string (+ ptr 8))))
	    ((= type PAIRTYPE) 
	     (cons (unpack (+ ptr 4))
		   (unpack (+ ptr 4
			      (unpack-space-required (+ ptr 4))))))
	    ))))

(define cserver (connections-server))
(define buflen 20)
;;(define (i)
;;  (cserver 'establish-udp 1500))
(define (i) 
  (cserver 'establish-tcp 1500)
  (dest "csam")
  (cserver 'connect-tcp 1500 'dest)
  )
(define buf (make-string buflen))
(define msg "Hello")
(define msglen (string-length msg))
;;(define (dest x)
;;  (cserver 'add-destination 'dest x 1500))
(define (dest x)
  (cserver 'add-destination 'dest x 1610))
;;(define (from)
;;  (cserver 'recv-udp 1500 buf buflen)
;;  )
(define (from)
  (cserver 'recv-tcp 1500 buf buflen)
  )
(define (f) (from) (f))
;;(define (to)
;;  (cserver 'send-udp 1500 'dest msg msglen))
(define (to)
  (cserver 'write-tcp 1500 msg msglen)
  )
(define (s)
  (ngddisplay (cserver 'recv-possible))
  (ngdnewline)
  (s))
(define (sel)
  (cserver 'recv-possible))

;; usage: ctest our-port our-host desthost destport client
(define (ctest clargs)
  (let ((our-host (cadr clargs))
	(our-port (string->number (caddr clargs)))
	(desthost (caddr (cdr clargs)))
	(destport (string->number (caddr (cddr clargs))))
	(client (string->number (caddr (cdddr clargs)))))
    (cserver 'establish-udp our-port)
    (cserver 'add-destination 'dest desthost destport)
    (let ((buf (make-string buflen)))
      (if client
	  (begin
	    (cserver 'recv-udp our-port buf buflen)
	    (ngddisplay buf))
	  (let* ((buf "Hello World")
		 (buflen (string-length buf)))
	    (cserver 'send-udp our-port 'dest buf buflen))
	  ))))
SHAR_EOF
fi # end of overwriting check
if test -f 'netglue.sch'
then
	echo shar: will not over-write existing file "'netglue.sch'"
else
cat << \SHAR_EOF > 'netglue.sch'
;;; $Header: netglue.sch,v 1.1 91/02/26 14:09:58 clarsen Exp $
;;; Header for netglue.sc
(define-external (connections-server) netglue)
(define-external cserver  netglue)
(define-external (pack ptr l) netglue)
(define-external (unpack ptr) netglue)
(define-external (sock-port sa) netglue)
SHAR_EOF
fi # end of overwriting check
if test -f 'cnet.c'
then
	echo shar: will not over-write existing file "'cnet.c'"
else
cat << \SHAR_EOF > 'cnet.c'
/* $Header: cnet.c,v 1.6 91/03/21 16:39:04 clarsen Exp $ */
/* C interface to Scheme network code */
#include <stdio.h>
#include <sys/types.h>
#include <sys/time.h>
#include <netdb.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include "objects.h"

new_sockaddr_in(s,family, port)
    struct sockaddr_in *s;
     int family, port;
{
    s->sin_family = family;
    s->sin_port = htons(port);
    s->sin_addr.s_addr = INADDR_ANY;
}

new_sockaddr_in_remote(s,family,port,host)
     struct sockaddr_in *s;
     int family, port;
     char *host;
{
    struct hostent *he;
/*    printf ("Host name is: %s\n",host);*/
    if (host != NULL) {
	if (!strcmp("any.any.any.any",host)) {
	    new_sockaddr_in(s,family,port);
	    s->sin_addr.s_addr = INADDR_ANY;
	} else if ((he = gethostbyname(host)) != NULL) {
	    new_sockaddr_in(s,family,port);
	    bcopy(he->h_addr,&s->sin_addr.s_addr,he->h_length);
	} else
	  perror (host);
    } else
      perror("(NULL)");
    
}

sock_matches(s1,s2)
     struct sockaddr_in * s1, *s2;
{
    return ((s1->sin_family == s2->sin_family) &&
            (s1->sin_port == s2->sin_port) &&
            (bcmp(&s1->sin_addr,&s2->sin_addr,sizeof(s1->sin_addr)) == 0))
	   ? 1 : 0;
}

fd_set *alloc_fdset()
{
    fd_set *fset = (fd_set *)malloc(sizeof(fd_set));
    FD_ZERO(fset);
    return fset;
}

fd_setfd(fdset,fd)
     fd_set *fdset;
     int fd;
{
    FD_SET(fd,fdset);
}
fd_clrfd(fdset,fd)
     fd_set *fdset;
     int fd;
{
    FD_CLR(fd,fdset);
}
fd_issetfd(fdset,fd)
     fd_set *fdset;
     int fd;
{
/*    printf ("%d is %d\n",fd,FD_ISSET(fd,fdset));*/
    return FD_ISSET(fd,fdset);
}
fd_zerofd(fdset)
     fd_set *fdset;
{
    FD_ZERO(fdset);
}
fd_set *select_default(fdset)
     fd_set *fdset;
{
    static fd_set tmp;
    struct timeval timeout;
    int nfds;
    timeout.tv_sec = 0;
    timeout.tv_usec = 1000; /* 1 ms */

    bcopy(fdset,&tmp,sizeof(tmp));
    if ((nfds = select(FD_SETSIZE,&tmp,&tmp,NULL,&timeout))<0) {
	perror("select");
    }
    return &tmp;
}
fd_set *select_read(fdset)
     fd_set *fdset;
{
    static fd_set tmp;
    struct timeval timeout;
    int nfds;
    timeout.tv_sec = 0;
    timeout.tv_usec = 1000; /* 1 ms */

    bcopy(fdset,&tmp,sizeof(tmp));
    if ((nfds = select(FD_SETSIZE,&tmp,NULL,NULL,&timeout))<0) {
	perror("select");
    }
    return &tmp;
}

/* Vector returned is:
 *         0:  family
 *         1:  port
 *         2:  low 2 byte of address in network byte order
 *         3:  high 2 bytes of address in network byte order
 */
TSCP sockaddr_attrs (sa)
     struct sockaddr_in *sa;
{
    TSCP v;
    PATSCP ve;
    v = sc_make_2dvector( C_FIXED(4),EMPTYLIST);
    ve = &(T_U(v)->vector.element0);
    *ve++ = C_FIXED( sa->sin_family);
    *ve++ = C_FIXED( sa->sin_port);
    *ve++ = C_FIXED( sa->sin_addr.s_addr & 0x0000FFFF );
    *ve++ = C_FIXED( (sa->sin_addr.s_addr >> 16) & 0x0000FFFF );
    return v;
}

/* normal scheme symbols are upper case */
upcase(s)
     char *s;
{
    while(*s) {
	if (*s >= 'a' && *s <= 'z') {
	    *s = 'A' + *s-'a';
	}
	s++;
    }
}

TSCP hostbyaddr(addrlow, addrhigh)
     TSCP addrlow, addrhigh;
{
    struct sockaddr_in adr;
    struct hostent *he;
    int high, low;
    high = sc_tscp_unsigned(addrhigh);
    low = sc_tscp_unsigned(addrlow);
    adr.sin_addr.s_addr = high << 16 | low;
/*    printf ("%lx\n",adr.sin_addr.s_addr);*/
    he = gethostbyaddr( &adr.sin_addr,sizeof(adr.sin_addr),AF_INET );
    if (he == NULL) {
	perror ("gethostbyaddr");
	return sc_emptystring;
    } else {
/*	printf ("%s\n",he->h_name);*/
	upcase(he->h_name);
	return (sc_cstringtostring(he->h_name));
    }
}

void dump_bytes(p)
     char *p;
{
    int i;
    for(i =0;i < 20; i++) {
	printf ("%d ",*p++);
    }
    putchar ('\n');
}
SHAR_EOF
fi # end of overwriting check
#	End of shell archive
exit 0

--
Case Larsen
clarsen@lbl.gov
