Check-in [82bf686062]
Not logged in
Home Timeline Files Branches Tags Tickets Wiki Login

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

Overview
Comment:added server support to socket.sls
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 82bf68606247efac4ff6030b63b33f78c075a42e
User & Date: aldo 2016-12-10 18:57:51
Context
2016-12-10
19:00
moved sockaddr_in inside the meta-cond check-in: 0776ca44d8 user: aldo tags: trunk
18:57
added server support to socket.sls check-in: 82bf686062 user: aldo tags: trunk
2016-12-09
20:24
moved d.s. import to top of c-eval check-in: 23bcb0c8b5 user: aldo tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to socket.sls. 

1
2
3
4
5
6
7
8
9
10
11
12
..
37
38
39
40
41
42
43
44


45
46
47
48
49
50
51
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
129
130
131
132
133
134
135





















136
137














138
139
140
141
142

143


144
145
146
147
148
149
150
151
152
153
154
155












156


(library (socket)
  (export file-write file-read bytes-ready socket bind accept close
	  socket-domain socket-type-flag socket-type gethostbyname
	  connect/inet)
  
  (import (except (chezscheme) bytevector-copy)
	  (posix)
	  (ffi-utils))

  (meta-cond
   [(memq (machine-type) '(a6le ta6le))
................................................................................
    (define-ftype socklen_t unsigned-int)
    (define-ftype sockaddr_un
      (struct (sun_family sa_family_t)
	      (sun_data (array 108 char))))
    
    (define-ftype in_addr_t unsigned-32)
    (define-ftype in_addr
      (struct (s_addr in_addr_t)))]


   [else
    (error 'socket.sls "unsupported machine-type ~a" (machine-type))])

  
  ;; WARNING- here the size of sin_zero should be calculated on your machine as:
  #;(import (c-eval))
  #;(parameterize ([c-eval-includes '("stdio.h" "sys/socket.h" "netinet/in.h")])
................................................................................
    (let ([r (socket* (socket-domain domain)
		      (logior (socket-type type)
			      (apply socket-type-flag type-flags))
		      protocol)])
	  (when (< r 0)
		(errorf 'socket "failed: ~a" (strerror)))
	  (open-fd-input/output-port r)))

  
  
  (define (bind s name family)
    (define strcpy* (foreign-procedure "strcpy" (void* string) void*))
    (define sun (foreign-alloc (ftype-sizeof sockaddr_un)))
    (define bind* (foreign-procedure "bind" (int void* socklen_t) int))
    (ftype-set! sockaddr_un (sun_family) sun family)
    (strcpy* (ftype-&ref sockaddr_un (sun_data) sun) name)
    (bind* (port-file-descriptor s) sun (ftype-sizeof sockaddr_un))
    (foreign-free sun))
  
  (define (accept s)
    (define accept* (foreign-procedure "accept" (int void* void*) int))
    ;;(define sun (foreign-alloc (ftype-sizeof sockaddr_un)))
    ;;(define length* (foreign-alloc (ftype-sizeof socklen_t)))
    
    (let ([r (accept* (port-file-descriptor s) 0 0)])
					;(foreign-free sun)
      (when (< r 0)
	    (errorf 'accept "failed: ~a" (strerror)))
      r))


  ;; MMM... LINUX MAN PAGES SAYS THIS IS DEPRECATED...
  (define (gethostbyname name)
    (define ghbn* (foreign-procedure "gethostbyname" (string) void*))
    (define hstrerror* (foreign-procedure "hstrerror" (int) string))
    (define (h-errno)
      (foreign-ref 'int (foreign-entry "__h_errno") 0))
................................................................................
    (memset* dest val n)
    (void))
  
  (define (memcpy dest src n)
    (define memcpy* (foreign-procedure "memcpy" (void* void* size_t) void*))
    (memcpy* dest src n)
    (void))
  
  (define (connect/inet socket address port)
    (define connect* (foreign-procedure "connect" (int (* sockaddr_in) socklen_t) int))
    (define server (gethostbyname address))
    (let ([addr (make-ftype-pointer sockaddr_in
				    (foreign-alloc (ftype-sizeof sockaddr_in)))])
      (memset (ftype-pointer-address addr) 0 (ftype-sizeof sockaddr_in))
      (ftype-set! sockaddr_in (sin_family) addr (socket-domain 'inet))
................................................................................
	      (foreign-ref 'void* (ftype-ref hostent (h_addr_list) server) 0)
	      (ftype-ref hostent (h_length) server))
      (ftype-set! sockaddr_in (sin_port) addr (htons port))
      (let ([r (connect* (port-file-descriptor socket)
			 addr (ftype-sizeof sockaddr_in))])
	(foreign-free (ftype-pointer-address addr))
	(when (< r 0)





















	      (errorf 'connect "failed: ~a" (strerror)))))) 
  














  )


#|
;Example:

(load "socket.sls")


(import (socket))

(define (http-get hostname port q)
  (define sock (socket 'inet 'stream '() 0))
  (connect/inet sock hostname port)
  (put-bytevector sock (string->utf8 (format #f "GET ~a HTTP/1.1\r\nHost: ~a\r\nConnection: Close\r\n\r\n" q hostname)))
  (flush-output-port sock)
  (do ([c (get-u8 sock) (get-u8 sock)] 
	     [l '() (cons c l)])
    ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))

(substring (http-get "scheme.com" 80 "/tspl4/intro.html") 0 100)












|#



|

|







 







|
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>





>

>
>











|
>
>
>
>
>
>
>
>
>
>
>
>


1
2
3
4
5
6
7
8
9
10
11
12
..
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
..
66
67
68
69
70
71
72























73
74
75
76
77
78
79
..
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
...
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185


(library (socket)
  (export file-write file-read bytes-ready socket close
	  socket-domain socket-type-flag socket-type gethostbyname
	  connect/inet bind/inet listen accept)
  
  (import (except (chezscheme) bytevector-copy)
	  (posix)
	  (ffi-utils))

  (meta-cond
   [(memq (machine-type) '(a6le ta6le))
................................................................................
    (define-ftype socklen_t unsigned-int)
    (define-ftype sockaddr_un
      (struct (sun_family sa_family_t)
	      (sun_data (array 108 char))))
    
    (define-ftype in_addr_t unsigned-32)
    (define-ftype in_addr
      (struct (s_addr in_addr_t)))
    (define INADDR_ANY 0)
    ]
   [else
    (error 'socket.sls "unsupported machine-type ~a" (machine-type))])

  
  ;; WARNING- here the size of sin_zero should be calculated on your machine as:
  #;(import (c-eval))
  #;(parameterize ([c-eval-includes '("stdio.h" "sys/socket.h" "netinet/in.h")])
................................................................................
    (let ([r (socket* (socket-domain domain)
		      (logior (socket-type type)
			      (apply socket-type-flag type-flags))
		      protocol)])
	  (when (< r 0)
		(errorf 'socket "failed: ~a" (strerror)))
	  (open-fd-input/output-port r)))
























  ;; MMM... LINUX MAN PAGES SAYS THIS IS DEPRECATED...
  (define (gethostbyname name)
    (define ghbn* (foreign-procedure "gethostbyname" (string) void*))
    (define hstrerror* (foreign-procedure "hstrerror" (int) string))
    (define (h-errno)
      (foreign-ref 'int (foreign-entry "__h_errno") 0))
................................................................................
    (memset* dest val n)
    (void))
  
  (define (memcpy dest src n)
    (define memcpy* (foreign-procedure "memcpy" (void* void* size_t) void*))
    (memcpy* dest src n)
    (void))
    
  (define (connect/inet socket address port)
    (define connect* (foreign-procedure "connect" (int (* sockaddr_in) socklen_t) int))
    (define server (gethostbyname address))
    (let ([addr (make-ftype-pointer sockaddr_in
				    (foreign-alloc (ftype-sizeof sockaddr_in)))])
      (memset (ftype-pointer-address addr) 0 (ftype-sizeof sockaddr_in))
      (ftype-set! sockaddr_in (sin_family) addr (socket-domain 'inet))
................................................................................
	      (foreign-ref 'void* (ftype-ref hostent (h_addr_list) server) 0)
	      (ftype-ref hostent (h_length) server))
      (ftype-set! sockaddr_in (sin_port) addr (htons port))
      (let ([r (connect* (port-file-descriptor socket)
			 addr (ftype-sizeof sockaddr_in))])
	(foreign-free (ftype-pointer-address addr))
	(when (< r 0)
	      (errorf 'connect/inet "failed: ~a" (strerror)))))) 

  (define (bind/inet socket address port)
    (define bind* (foreign-procedure "bind" (int (* sockaddr_in) socklen_t) int))
    (let ([addr (make-ftype-pointer sockaddr_in
				    (foreign-alloc (ftype-sizeof sockaddr_in)))])
      (memset (ftype-pointer-address addr) 0 (ftype-sizeof sockaddr_in))
      (ftype-set! sockaddr_in (sin_family) addr (socket-domain 'inet))
      (case address
	[any
	 (ftype-set! in_addr (s_addr) (ftype-&ref sockaddr_in (sin_addr) addr) INADDR_ANY)]
	[else
	 (let ([server (gethostbyname address)])
	   (memcpy (ftype-pointer-address (ftype-&ref sockaddr_in (sin_addr) addr))
		   (foreign-ref 'void* (ftype-ref hostent (h_addr_list) server) 0)
		   (ftype-ref hostent (h_length) server)))])
      (ftype-set! sockaddr_in (sin_port) addr (htons port))
      (let ([r (bind* (port-file-descriptor socket)
		      addr (ftype-sizeof sockaddr_in))])
	(foreign-free (ftype-pointer-address addr))
	(when (< r 0)
	      (errorf 'bind/inet "failed: ~a" (strerror))))))
  
  (define (listen s backlog)
    (define listen* (foreign-procedure "listen" (int int) int))
    (let ([r (listen* (port-file-descriptor s) backlog)])
      (when (< r 0)
	    (errorf 'listen "failed: ~a" (strerror)))
      r))
  
  (define (accept s)
    (define accept* (foreign-procedure "accept" (int void* void*) int))
    ;; TODO: get the client address!
    (let ([r (accept* (port-file-descriptor s) 0 0)])
      (when (< r 0)
	    (errorf 'accept "failed: ~a" (strerror)))
      (open-fd-input/output-port r)))
  )


#|
;Example:

(load "socket.sls")

;; client
(import (socket))

(define (http-get hostname port q)
  (define sock (socket 'inet 'stream '() 0))
  (connect/inet sock hostname port)
  (put-bytevector sock (string->utf8 (format #f "GET ~a HTTP/1.1\r\nHost: ~a\r\nConnection: Close\r\n\r\n" q hostname)))
  (flush-output-port sock)
  (do ([c (get-u8 sock) (get-u8 sock)] 
	     [l '() (cons c l)])
    ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))

(substring (http-get "scheme.com" 80 "/tspl4/intro.html") 200)

;; server
(import (socket))
(define sock (socket 'inet 'stream '() 0))
(bind/inet sock 'any 8001)
(listen sock 10)
(define clisock (accept sock))
(define (read-all sock) 
  (do ([c (get-u8 sock) (get-u8 sock)] 
	     [l '() (cons c l)])
      ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))
(read-all clisock)
|#

Fossil 2.9 [0fd79a3e09] 2019-07-13 13:05:19