/* * Scheme48/scsh network interface. * Routines that require custom C support. * Copyright (c) 1994 by Brian D. Carlstrom * Copyright (c) 1994 by Olin Shivers */ #include "cstuff.h" #include #include #include #include #include #include #include #include #include #include #include /* Make sure our exports match up w/the implementation: */ #include "network1.h" #include "scheme48.h" //extern int h_errno; /* to extract a 4 byte long value from a scheme string */ #define GET_LONG(x,n) (*((u_long *)(S48_ADDRESS_AFTER_HEADER((x),unsigned char)+(n*4)))) #define SET_LONG(x,n,v) GET_LONG((x),(n))=(u_long)(v); s48_value long2byte_vector (long number) { s48_value bv = s48_make_byte_vector (4, 0); S48_BYTE_VECTOR_SET(bv, 0, number & 0xff); S48_BYTE_VECTOR_SET(bv, 1, (number >> 8) & 0xff); S48_BYTE_VECTOR_SET(bv, 2, (number >> 16) & 0xff); S48_BYTE_VECTOR_SET(bv, 3, (number >> 24) & 0xff); return bv; } long byte_vector2long (s48_value bv) { long number = S48_BYTE_VECTOR_REF (bv, 0); number |= (S48_BYTE_VECTOR_REF (bv, 1) << 8); number |= (S48_BYTE_VECTOR_REF (bv, 2) << 16); number |= (S48_BYTE_VECTOR_REF (bv, 3) << 24); return number; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value scheme_bind(s48_value sock, s48_value family, s48_value scheme_name) { int sockfd = s48_extract_fixnum (sock); switch(s48_extract_fixnum (family)) { case AF_UNIX: { struct sockaddr_un name; int scheme_length=S48_STRING_LENGTH(scheme_name); name.sun_family=AF_UNIX; if (scheme_length>=(108-1)) /* save space for \0 */ return(-1); // TODO: check this in scheme ! strncpy(name.sun_path, s48_extract_string(scheme_name), scheme_length); /* copy to c string */ name.sun_path[scheme_length]='\0'; /* add null */ if ( bind(sockfd,(struct sockaddr *)&name,sizeof(name)) < 0) s48_raise_os_error (errno); return S48_UNSPECIFIC; } case AF_INET: { struct sockaddr_in name; u_long addr = htonl(byte_vector2long (S48_CAR (scheme_name))); u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name))); name.sin_family=AF_INET; name.sin_addr.s_addr=addr; name.sin_port=port; if (bind(sockfd,(struct sockaddr *)&name,sizeof(name)) < 0) s48_raise_os_error (errno); return S48_UNSPECIFIC; } default: s48_raise_argtype_error (family); } } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value scheme_connect(s48_value sock, s48_value family, s48_value scheme_name) { int sockfd = s48_extract_fixnum (sock); switch(s48_extract_fixnum (family)) { case AF_UNIX: { struct sockaddr_un name; int ret; int scheme_length=S48_STRING_LENGTH(scheme_name); name.sun_family=AF_UNIX; if (scheme_length>=(108-1)) /* save space for \0 */ return(-1); strncpy(name.sun_path, s48_extract_string (scheme_name), scheme_length); /* copy to c string */ name.sun_path[scheme_length]='\0'; /* add null */ if (connect(sockfd,(struct sockaddr *)&name,sizeof(name)) == 0) return S48_TRUE; if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY && errno != EINPROGRESS && errno != EAGAIN) s48_raise_os_error(errno); if (! (s48_add_pending_fd(sockfd, 0))) s48_raise_out_of_memory_error(); if (errno == EINPROGRESS) return s48_enter_fixnum (0); else return S48_FALSE; } case AF_INET: { struct sockaddr_in name; u_long addr= htonl(byte_vector2long (S48_CAR (scheme_name))); u_short port= htons(s48_extract_fixnum (S48_CDR (scheme_name))); name.sin_family=AF_INET; name.sin_addr.s_addr=addr; name.sin_port=port; if (connect(sockfd,(struct sockaddr *)&name,sizeof(name)) == 0) return S48_TRUE; if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY && errno != EINPROGRESS && errno != EAGAIN) s48_raise_os_error(errno); if (! (s48_add_pending_fd(sockfd, 0))) s48_raise_out_of_memory_error(); if (errno == EINPROGRESS) return s48_enter_fixnum (0); else return S48_FALSE; } default: s48_raise_argtype_error (family); /* error unknown address family */ } } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value scheme_accept(s48_value sockfd_tagged, s48_value family) { int sockfd = s48_extract_fixnum (sockfd_tagged); switch(s48_extract_fixnum (family)) { case AF_UNIX: { struct sockaddr_un name; socklen_t namelen=sizeof(name); int newsockfd=accept(sockfd,(struct sockaddr *)&name,&namelen); if (newsockfd < 0) { if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN)) s48_raise_os_error(errno); if (! s48_add_pending_fd(sockfd, 1))// 1 for is_input s48_raise_out_of_memory_error(); return S48_FALSE; } return(s48_enter_fixnum (newsockfd)); break; } case AF_INET: { struct sockaddr_in name; socklen_t namelen=sizeof(name); int newsockfd; s48_value result, sock_addr; S48_DECLARE_GC_PROTECT(2); newsockfd = accept (sockfd, (struct sockaddr *)&name,&namelen); if (newsockfd < 0) { if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN)) s48_raise_os_error(errno); if (! s48_add_pending_fd(sockfd, 1))// 1 for is_input s48_raise_out_of_memory_error(); return S48_FALSE; } fcntl(newsockfd, F_SETFL, O_NONBLOCK); S48_GC_PROTECT_2 (result, sock_addr); sock_addr = long2byte_vector (ntohl(name.sin_addr.s_addr)); result = s48_cons (sock_addr, s48_enter_fixnum (ntohs(name.sin_port))); result = s48_cons (s48_enter_fixnum (newsockfd), result); S48_GC_UNPROTECT(); return result; break; } default: s48_raise_argtype_error (family); /* error unknown address family */ } } s48_value make_addr (long s_addr, int s_port) { s48_value result, sock_addr; S48_DECLARE_GC_PROTECT(2); S48_GC_PROTECT_2 (result, sock_addr); sock_addr = long2byte_vector (ntohl (s_addr)); result = s48_cons (sock_addr, s48_enter_fixnum (ntohs (s_port))); S48_GC_UNPROTECT(); return result; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value scheme_peer_name(s48_value sock, s48_value family) { int sockfd = s48_extract_fixnum (sock); switch(s48_extract_fixnum (family)) { case AF_INET: { struct sockaddr_in name; socklen_t namelen=sizeof(name); int value=getpeername(sockfd,(struct sockaddr *)&name,&namelen); if (value < 0) s48_raise_os_error (errno); return (make_addr (name.sin_addr.s_addr, name.sin_port)); break; } default: s48_raise_argtype_error (family); /* error unknown address family */ } } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value scheme_socket_name(s48_value sock, s48_value family) { int sockfd = s48_extract_fixnum (sock); switch(s48_extract_fixnum (family)) { case AF_INET: { struct sockaddr_in name; socklen_t namelen=sizeof(name); int value=getsockname(sockfd,(struct sockaddr *)&name,&namelen); if (value < 0) s48_raise_os_error (errno); return(make_addr (name.sin_addr.s_addr, name.sin_port)); break; } default: s48_raise_argtype_error (family); /* error unknown address family */ } } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ int scheme_socket_pair(int type, int *s1, int *s2) { int sv[2]; if( socketpair(PF_UNIX,type,0,sv) ) { *s1 = 0; *s2 = 0; return errno; } *s1 = sv[0]; *s2 = sv[1]; return 0; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value recv_substring(s48_value scm_sockfd, s48_value flags, s48_value buf, s48_value scm_start, s48_value scm_end) { struct sockaddr_in name; socklen_t namelen=sizeof(name); int sockfd = s48_extract_fixnum (scm_sockfd); int start = s48_extract_fixnum (scm_start); int end = s48_extract_fixnum (scm_end); char* buf_part = s48_extract_string (buf) + start; int cc=recvfrom(sockfd, buf_part, end-start, s48_extract_fixnum (flags), (struct sockaddr *)&name, &namelen); s48_value result; if (cc >= 0) return (s48_cons (s48_enter_fixnum (cc), s48_cons (make_addr (name.sin_addr.s_addr, htonl((u_long)ntohs(name.sin_port))), S48_NULL))); if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN)) s48_raise_os_error(errno); if (! s48_add_pending_fd(sockfd, 1))// 1 for is_input s48_raise_out_of_memory_error(); return S48_FALSE; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ s48_value send_substring(s48_value scm_sockfd, s48_value scm_flags, s48_value buf, s48_value scm_start, s48_value scm_end, s48_value scm_family, s48_value scheme_name) { int n; int s = s48_extract_fixnum (scm_sockfd); int flags = s48_extract_fixnum (scm_flags); int start = s48_extract_fixnum (scm_start); int end = s48_extract_fixnum (scm_end); char* buf_part = s48_extract_string (buf) + start; switch(s48_extract_fixnum (scm_family)) { case 0: /* only with connected sockets */ { n = send(s, buf_part, end-start, flags); break; } case AF_UNIX: { struct sockaddr_un name; int scheme_length=S48_STRING_LENGTH(scheme_name); name.sun_family=AF_UNIX; if (scheme_length>=(108-1)) /* save space for \0 */ return(-1); strncpy(name.sun_path, s48_extract_string(scheme_name), scheme_length); /* copy to c string */ name.sun_path[scheme_length]='\0'; /* add null */ n = sendto(s, buf_part, end-start, flags, (struct sockaddr *)&name, sizeof(name)); break; } case AF_INET: { struct sockaddr_in name; u_long addr = htonl (byte_vector2long (S48_CAR (scheme_name))); u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name))); name.sin_family=AF_INET; name.sin_addr.s_addr=addr; name.sin_port=port; n = sendto(s, buf_part, end-start, flags, (struct sockaddr *)&name, sizeof(name)); break; } default: s48_raise_argtype_error (s48_extract_fixnum (scm_family)); /* error unknown address family */ } if (n >= 0) return s48_enter_fixnum (n); if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN)) s48_raise_os_error(errno); if (! s48_add_pending_fd(s, 0))// 0 for is_input s48_raise_out_of_memory_error(); return S48_FALSE; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ int scheme_getsockopt (int s, int level, int optname) { int optval; int optlen=sizeof(optval); if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) return(-1); return(optval); } int scheme_getsockopt_linger (int s, int level, int optname, int *out_time) { struct linger optval; int optlen=sizeof(optval); if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { out_time = 0; return(-1); } *out_time=optval.l_linger; return(optval.l_onoff); } int scheme_getsockopt_timeout (int s, int level, int optname, int *out_usec) { struct timeval optval; size_t optlen=sizeof(optval); if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { out_usec = 0; return(-1); } *out_usec=optval.tv_usec; return(optval.tv_sec); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ int scheme_setsockopt (int s, int level, int optname, int optval) { return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); } int scheme_setsockopt_linger (int s, int level, int optname, int onoff, int linger) { struct linger optval; optval.l_onoff=onoff; optval.l_linger=linger; return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); } int scheme_setsockopt_timeout (int s, int level, int optname, int sec, int usec) { struct timeval optval; optval.tv_sec=sec; optval.tv_usec=usec; return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* Routines for looking up hosts */ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ static s48_value host_info_type_binding = S48_FALSE; s48_value host_ent2host_info (struct hostent * host) { s48_value host_info = S48_FALSE; s48_value list = S48_FALSE; long * ptr; int i; S48_DECLARE_GC_PROTECT (2); if(host==NULL) { return(s48_enter_fixnum (h_errno)); } if (host_info_type_binding == S48_FALSE) { S48_GC_PROTECT_GLOBAL(host_info_type_binding); host_info_type_binding = s48_get_imported_binding ("host-info-type"); } S48_GC_PROTECT_2 (host_info, list); host_info = s48_make_record (host_info_type_binding); S48_RECORD_SET (host_info, 0, s48_enter_string (host->h_name)); ptr = (long *)host->h_aliases; list = S48_NULL; i = 0; while (*ptr) { list = s48_cons (s48_enter_string (host->h_aliases[i]), list); ptr++; i ++; } S48_RECORD_SET (host_info, 1, list); ptr = (long *)host->h_addr_list; list = S48_NULL; i = 0; while (*ptr) { list = s48_cons (long2byte_vector (ntohl (*(long *)(host->h_addr_list[i]))), list); ptr++; i++; } S48_RECORD_SET (host_info, 2, list); S48_GC_UNPROTECT (); return host_info; } s48_value scheme_host_address2host_info(s48_value addr_port) { struct in_addr name; struct hostent *host; u_long addr = htonl(byte_vector2long (S48_CAR (addr_port))); name.s_addr = addr; host=gethostbyaddr((char *)&name,sizeof(name),AF_INET); return (host_ent2host_info (host)); } s48_value scheme_host_name2host_info(s48_value s_name) { struct in_addr name; struct hostent *host; char * scheme_name = s48_extract_string (s_name); if ((name.s_addr=inet_addr(scheme_name)) != -1) host=gethostbyaddr((char *)&name,sizeof(name),AF_INET); else host=gethostbyname(scheme_name); return (host_ent2host_info (host)); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* Routines for looking up networks */ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ static s48_value network_info_type_binding = S48_FALSE; s48_value netent2net_info(struct netent *net) { s48_value network_info = S48_FALSE; s48_value list = S48_FALSE; long * ptr; int i; S48_DECLARE_GC_PROTECT (2); if (net==NULL) return S48_FALSE; if (network_info_type_binding == S48_FALSE) { S48_GC_PROTECT_GLOBAL(network_info_type_binding); network_info_type_binding = s48_get_imported_binding ("network-info-type"); } S48_GC_PROTECT_2 (network_info, list); network_info = s48_make_record (network_info_type_binding); S48_RECORD_SET (network_info, 0, s48_enter_string (net->n_name)); ptr = (long *)net->n_aliases; list = S48_NULL; i = 0; while (*ptr) { list = s48_cons (s48_enter_string (net->n_aliases[i]), list); ptr++; i++; } S48_RECORD_SET (network_info, 1, list); S48_RECORD_SET (network_info, 2, long2byte_vector (net->n_net)); S48_GC_UNPROTECT (); return network_info; } s48_value scheme_net_address2net_info(s48_value net_addr) { struct netent *net; // expects host byte order : net=getnetbyaddr(byte_vector2long (net_addr),AF_INET); return netent2net_info (net); } s48_value scheme_net_name2net_info(s48_value scheme_name) { struct netent *net = getnetbyname(s48_extract_string (scheme_name)); return netent2net_info (net); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* Routines for looking up services */ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ static s48_value service_info_type_binding = S48_FALSE; s48_value servent2service_info(struct servent *serv) { s48_value service_info = S48_FALSE; s48_value list = S48_FALSE; long * ptr; int i; S48_DECLARE_GC_PROTECT (2); if (serv==NULL) return S48_FALSE; if (service_info_type_binding == S48_FALSE) { S48_GC_PROTECT_GLOBAL(service_info_type_binding); service_info_type_binding = s48_get_imported_binding ("service-info-type"); } S48_GC_PROTECT_2 (service_info, list); service_info = s48_make_record (service_info_type_binding); S48_RECORD_SET (service_info, 0, s48_enter_string (serv->s_name)); ptr = (long *)serv->s_aliases; list = S48_NULL; i = 0; while (*ptr) { list = s48_cons (s48_enter_string (serv->s_aliases[i]), list); ptr++; i++; } S48_RECORD_SET (service_info, 1, list); S48_RECORD_SET (service_info, 2, s48_enter_fixnum (ntohs (serv->s_port))); S48_RECORD_SET (service_info, 3, s48_enter_string (serv->s_proto)); S48_GC_UNPROTECT (); return service_info; } s48_value scheme_serv_port2serv_info(s48_value in_port, s48_value in_proto) { struct servent *serv; char * proto; if (in_proto == S48_FALSE) proto = NULL; else proto = s48_extract_string (in_proto); serv = getservbyport(ntohs(s48_extract_fixnum (in_port)), proto); return servent2service_info (serv); } s48_value scheme_serv_name2serv_info(s48_value in_name, s48_value in_proto) { struct servent *serv; char * proto; if (in_proto == S48_FALSE) proto = NULL; else proto = s48_extract_string (in_proto); serv = getservbyname(s48_extract_string (in_name), proto); return servent2service_info (serv); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* Routines for looking up protocols */ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ static s48_value protocol_info_type_binding = S48_FALSE; s48_value protoent2protocol_info(struct protoent *proto) { s48_value protocol_info = S48_FALSE; s48_value list = S48_FALSE; long * ptr; int i; S48_DECLARE_GC_PROTECT (2); if (proto==NULL) return S48_FALSE; if (protocol_info_type_binding == S48_FALSE) { S48_GC_PROTECT_GLOBAL(protocol_info_type_binding); protocol_info_type_binding = s48_get_imported_binding ("protocol-info-type"); } S48_GC_PROTECT_2 (protocol_info, list); protocol_info = s48_make_record (protocol_info_type_binding); S48_RECORD_SET (protocol_info, 0, s48_enter_string (proto->p_name)); ptr = (long *)proto->p_aliases; list = S48_NULL; i = 0; while (*ptr) { list = s48_cons (s48_enter_string (proto->p_aliases[i]), list); ptr++; i++; } S48_RECORD_SET (protocol_info, 1, list); S48_RECORD_SET (protocol_info, 2, s48_enter_fixnum (proto->p_proto)); S48_GC_UNPROTECT (); return protocol_info; } s48_value scheme_proto_num2proto_info(s48_value in_proto) { struct protoent *proto; proto=getprotobynumber(s48_extract_fixnum (in_proto)); return protoent2protocol_info (proto); } s48_value scheme_proto_name2proto_info(s48_value in_name) { struct protoent *proto=getprotobyname(s48_extract_string (in_name)); return protoent2protocol_info (proto); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* Low Level Junk */ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /* svec is a Scheme vector of C carriers. Scan over the C longs ** in cvec, and initialise the corresponding carriers in svec. */ void set_longvec_carriers(s48_value svec, long const * const * cvec) { int svec_len = S48_VECTOR_LENGTH(svec); long const * const *cv = cvec; s48_value s = S48_VECTOR_REF(svec,0); //JMG hack s48_value *sv = &s; for(; svec_len > 0; cv++, sv++, svec_len-- ) { /* *sv is a (make-string 4) */ s48_value carrier = *sv; (*((u_long *)(S48_ADDRESS_AFTER_HEADER(carrier,unsigned char)))) =(long)**cv; } } /* One arg, a zero-terminated C word vec. Returns length. ** The terminating null is not counted. Returns #f on NULL. */ s48_value veclen(const long *vec) { const long *vptr = vec; if( !vptr ) return S48_FALSE; while( *vptr ) vptr++; return s48_enter_fixnum(vptr - vec); }