Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Added socket.sls.

            1  +
            2  +(library (socket)
            3  +  (export file-write file-read bytes-ready socket bind accept close
            4  +	  socket-domain socket-type-flag socket-type gethostbyname
            5  +	  connect/inet)
            6  +  
            7  +  (import (except (chezscheme) bytevector-copy)
            8  +	  (posix)
            9  +	  (ffi-utils))
           10  +
           11  +  (meta-cond
           12  +   [(memq (machine-type) '(a6le ta6le))
           13  +    
           14  +    (define-enumeration* socket-domain
           15  +      (unspec local inet ax25 ipx appletalk
           16  +	      netrom bridge atmpvc x25 inet6 rose decnet netbeui security key
           17  +	      netlink packet ash econet atmsvc rds sna irda ppox wanpipe llc ib mpls
           18  +	      can tipc bluetooth iucv rxrpc isdn phonet ieee802154 caif alg nfc
           19  +	      vsock kcm))
           20  +
           21  +    (define-enumeration* socket-type (unspec stream dgram raw seqpacket dccp))
           22  +    (define-flags socket-type-flag
           23  +      (close-on-exec #o02000000)
           24  +      (non-block #o00004000))
           25  +    
           26  +    (define-ftype hostent
           27  +      (struct
           28  +       (h_name (* char))
           29  +       (h_aliases void*)
           30  +       (h_addrtype int)
           31  +       (h_length int)
           32  +       (h_addr_list void*)))
           33  +    
           34  +    (define-ftype sa_family_t unsigned-short)
           35  +    (define-ftype in_port_t unsigned-16)
           36  +    
           37  +    (define-ftype socklen_t unsigned-int)
           38  +    (define-ftype sockaddr_un
           39  +      (struct (sun_family sa_family_t)
           40  +	      (sun_data (array 108 char))))
           41  +    
           42  +    (define-ftype in_addr_t unsigned-32)
           43  +    (define-ftype in_addr
           44  +      (struct (s_addr in_addr_t)))]
           45  +   [else
           46  +    (error 'socket.sls "unsupported machine-type ~a" (machine-type))])
           47  +
           48  +  
           49  +  ;; WARNING- here the size of sin_zero should be calculated on your machine as:
           50  +  #;(import (c-eval))
           51  +  #;(parameterize ([c-eval-includes '("stdio.h" "sys/socket.h" "netinet/in.h")])
           52  +		(c-eval-printf "%d" "sizeof(struct sockaddr_in) - (sizeof (sa_family_t) - sizeof(in_port_t) - sizeof(in_addr_t))"))
           53  +  ;; in my case  (a6le) -> 20
           54  +  
           55  +  (define-ftype sockaddr_in
           56  +    (struct
           57  +     (sin_family sa_family_t)
           58  +     (sin_port in_port_t)
           59  +     (sin_addr in_addr)
           60  +     (sin_zero (array 20 unsigned-8))))
           61  +  
           62  +  (define (socket domain type type-flags protocol)  
           63  +    (define socket* (foreign-procedure "socket" (int int int) int))
           64  +    (let ([r (socket* (socket-domain domain)
           65  +		      (logior (socket-type type)
           66  +			      (apply socket-type-flag type-flags))
           67  +		      protocol)])
           68  +	  (when (< r 0)
           69  +		(errorf 'socket "failed: ~a" (strerror)))
           70  +	  (open-fd-input/output-port r)))
           71  +
           72  +  
           73  +  
           74  +  (define (bind s name family)
           75  +    (define strcpy* (foreign-procedure "strcpy" (void* string) void*))
           76  +    (define sun (foreign-alloc (ftype-sizeof sockaddr_un)))
           77  +    (define bind* (foreign-procedure "bind" (int void* socklen_t) int))
           78  +    (ftype-set! sockaddr_un (sun_family) sun family)
           79  +    (strcpy* (ftype-&ref sockaddr_un (sun_data) sun) name)
           80  +    (bind* (port-file-descriptor s) sun (ftype-sizeof sockaddr_un))
           81  +    (foreign-free sun))
           82  +  
           83  +  (define (accept s)
           84  +    (define accept* (foreign-procedure "accept" (int void* void*) int))
           85  +    ;;(define sun (foreign-alloc (ftype-sizeof sockaddr_un)))
           86  +    ;;(define length* (foreign-alloc (ftype-sizeof socklen_t)))
           87  +    
           88  +    (let ([r (accept* (port-file-descriptor s) 0 0)])
           89  +					;(foreign-free sun)
           90  +      (when (< r 0)
           91  +	    (errorf 'accept "failed: ~a" (strerror)))
           92  +      r))
           93  +
           94  +
           95  +  ;; MMM... LINUX MAN PAGES SAYS THIS IS DEPRECATED...
           96  +  (define (gethostbyname name)
           97  +    (define ghbn* (foreign-procedure "gethostbyname" (string) void*))
           98  +    (define hstrerror* (foreign-procedure "hstrerror" (int) string))
           99  +    (define (h-errno)
          100  +      (foreign-ref 'int (foreign-entry "__h_errno") 0))
          101  +    
          102  +    (let ([r (ghbn* name)])
          103  +      (when (zero? r)
          104  +	    (errorf 'gethostbyname "failed: ~a" (hstrerror* (h-errno))))
          105  +      (make-ftype-pointer hostent r)))
          106  +     
          107  +  (define (htons n)
          108  +    (define htons* (foreign-procedure "htons" (unsigned-16) unsigned-16))
          109  +    (htons* n))
          110  +  
          111  +  (define (memset dest val n)
          112  +    (define memset* (foreign-procedure "memset" (void* int size_t) void*))
          113  +    (memset* dest val n)
          114  +    (void))
          115  +  
          116  +  (define (memcpy dest src n)
          117  +    (define memcpy* (foreign-procedure "memcpy" (void* void* size_t) void*))
          118  +    (memcpy* dest src n)
          119  +    (void))
          120  +  
          121  +  (define (connect/inet socket address port)
          122  +    (define connect* (foreign-procedure "connect" (int (* sockaddr_in) socklen_t) int))
          123  +    (define server (gethostbyname address))
          124  +    (let ([addr (make-ftype-pointer sockaddr_in
          125  +				    (foreign-alloc (ftype-sizeof sockaddr_in)))])
          126  +      (memset (ftype-pointer-address addr) 0 (ftype-sizeof sockaddr_in))
          127  +      (ftype-set! sockaddr_in (sin_family) addr (socket-domain 'inet))
          128  +      (memcpy (ftype-pointer-address (ftype-&ref sockaddr_in (sin_addr) addr))
          129  +	      (foreign-ref 'void* (ftype-ref hostent (h_addr_list) server) 0)
          130  +	      (ftype-ref hostent (h_length) server))
          131  +      (ftype-set! sockaddr_in (sin_port) addr (htons port))
          132  +      (let ([r (connect* (port-file-descriptor socket)
          133  +			 addr (ftype-sizeof sockaddr_in))])
          134  +	(foreign-free (ftype-pointer-address addr))
          135  +	(when (< r 0)
          136  +	      (errorf 'connect "failed: ~a" (strerror)))))) 
          137  +  
          138  +  )
          139  +
          140  +
          141  +#|
          142  +;Example:
          143  +(load "socket.sls")
          144  +(import (socket))
          145  +
          146  +(define (http-get hostname port q)
          147  +  (define sock (socket 'inet 'stream '() 0))
          148  +  (connect/inet sock hostname port)
          149  +  (put-bytevector sock (string->utf8 (format #f "GET ~a HTTP/1.1\r\nHost: ~a\r\nConnection: Close\r\n\r\n" q hostname)))
          150  +  (flush-output-port sock)
          151  +  (do ([c (get-u8 sock) (get-u8 sock)] 
          152  +	     [l '() (cons c l)])
          153  +    ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))
          154  +
          155  +(substring (http-get "scheme.com" 80 "/tspl4/intro.html") 0 100)
          156  +|#