Megatest

Check-in [c3e3d94576]
Login
Overview
Comment:Removed need for old hostinfo egg
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.0001
Files: files | file ages | folders
SHA1: c3e3d94576aa89dadd6970d5fc3fb72be944d914
User & Date: matt on 2022-01-14 00:34:12
Other Links: branch diff | manifest | tags
Context
2022-01-14
00:35
Missed hostinfo.scm check-in: b542bf1f82 user: matt tags: v2.0001
00:34
Removed need for old hostinfo egg check-in: c3e3d94576 user: matt tags: v2.0001
2022-01-13
18:50
Merged fork check-in: 6bbd0fa9a2 user: matt tags: v2.0001, ulex-smoketest
Changes

Modified Makefile from [a7d80e1a40] to [cae3ebc4c9].

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# add dboard mtut and tcmt back later

# module source files
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm	\
            cookie.scm mutils.scm mtargs.scm apimod.scm	ulex.scm	\
            configfmod.scm commonmod.scm dbmod.scm rmtmod.scm		\
            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            hostinfo.scm adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm

# GUISRCF = 








|







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# add dboard mtut and tcmt back later

# module source files
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm	\
            cookie.scm mutils.scm mtargs.scm apimod.scm	ulex.scm	\
            configfmod.scm commonmod.scm dbmod.scm rmtmod.scm		\
            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm

# GUISRCF = 

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o
mofiles/commonmod.o : mofiles/hostinfo.o
mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
mofiles/dbimod.o : mofiles/autoload.o
mofiles/dbmod.o : mofiles/commonmod.o







<







75
76
77
78
79
80
81

82
83
84
85
86
87
88
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o

mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
mofiles/dbimod.o : mofiles/autoload.o
mofiles/dbmod.o : mofiles/commonmod.o

Modified commonmod.scm from [9a2ccbe33e] to [68c43be7f7].

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(declare (uses mtver))
(declare (uses debugprint))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
(declare (uses hostinfo))
(declare (uses keysmod))

;; odd but it works?
;; (declare (uses itemsmod))

(module commonmod
	   (







|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(declare (uses mtver))
(declare (uses debugprint))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
;; (declare (uses hostinfo))
(declare (uses keysmod))

;; odd but it works?
;; (declare (uses itemsmod))

(module commonmod
	   (
529
530
531
532
533
534
535


536
537
538
539
540
541
542
	chicken.io
	chicken.string
	chicken.sort
	chicken.time.posix
	
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)


	directory-utils
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors







>
>







529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
	chicken.io
	chicken.string
	chicken.sort
	chicken.time.posix
	
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)

	address-info
	directory-utils
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
	stml2
	pkts
	processmod
	(prefix mtargs args:)
	configfmod
	keysmod
	;; itemsmod
	hostinfo
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions







|







556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
	stml2
	pkts
	processmod
	(prefix mtargs args:)
	configfmod
	keysmod
	;; itemsmod
	;; hostinfo
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
4340
4341
4342
4343
4344
4345
4346




4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
































4359
4360
4361
4362
4363
4364
4365
		  d
		  (begin
		    ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
		    ;;	(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))





(define (server:get-best-guess-address hostname)
  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

































(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)







>
>
>
>
|











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







4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
		  d
		  (begin
		    ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
		    ;;	(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))

;;======================================================================
;; network utilities
;;======================================================================

#;(define (server:get-best-guess-address hostname)
  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

;; NOTE: Look at address-info egg as alternative to some of this

(define (rate-ip ipaddr)
  (regex-case ipaddr
    ( "^127\\..*" _ 0 )
    ( "^(10\\.0|192\\.168)\\..*" _ 1 )
    ( else 2 ) ))

;; Change this to bias for addresses with a reasonable broadcast value?
;;
(define (ip-pref-less? a b)
  (> (rate-ip a) (rate-ip b)))

(define (server:get-best-guess-address hostname)
  (let ((all-addresses (get-all-ips hostname)))
    (cond
     ((null? all-addresses)
      hostname #;(get-host-name))                                          ;; no interfaces?
     ((eq? (length all-addresses) 1)
      (car all-addresses))                      ;; only one to choose from, just go with it
     (else
      (car (sort all-addresses ip-pref-less?))))))

(define (get-all-ips-sorted)
  (sort (get-all-ips) ip-pref-less?))

(define (get-all-ips hostname)
  (map address-info-host
       (filter (lambda (x)
		 (equal? (address-info-type x) 'tcp))
	       (address-infos hostname))))

(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)

Deleted hostinfo/hostinfo.h version [4f39d60970].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
#ifdef _WIN32
# include <winsock2.h>
# include <ws2tcpip.h>

const char *inet_ntop(int af, const void *src, char *dst, socklen_t cnt)
{
        if (af == AF_INET)
        {
                struct sockaddr_in in;
                memset(&in, 0, sizeof(in));
                in.sin_family = AF_INET;
                memcpy(&in.sin_addr, src, sizeof(struct in_addr));
                getnameinfo((struct sockaddr *)&in, sizeof(struct
sockaddr_in), dst, cnt, NULL, 0, NI_NUMERICHOST);
                return dst;
        }
        else if (af == AF_INET6)
        {
                struct sockaddr_in6 in;
                memset(&in, 0, sizeof(in));
                in.sin6_family = AF_INET6;
                memcpy(&in.sin6_addr, src, sizeof(struct in_addr6));
                getnameinfo((struct sockaddr *)&in, sizeof(struct
sockaddr_in6), dst, cnt, NULL, 0, NI_NUMERICHOST);
                return dst;
        }
        return NULL;
}

int inet_pton(int af, const char *src, void *dst)
{
        struct addrinfo hints, *res, *ressave;

        memset(&hints, 0, sizeof(struct addrinfo));
        hints.ai_family = af;

        if (getaddrinfo(src, NULL, &hints, &res) != 0)
        {
                return -1;
        }

        ressave = res;

        while (res)
        {
                memcpy(dst, res->ai_addr, res->ai_addrlen);
                res = res->ai_next;
        }

        freeaddrinfo(ressave);
        return 0;
}

#else
 # include <sys/types.h>
 # include <sys/socket.h>
 # include <netinet/in.h>  /* in_addr */
# include <arpa/inet.h>   /* inet_ntop, ... */
# include <netdb.h>       /* hostent, gethostby* */
# include <unistd.h>
#endif
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































Deleted hostinfo/hostinfo.meta version [90c3b6c82d].

1
2
3
4
5
6
7
8
9
;;; hostinfo.meta -*- Hen -*-
((synopsis "Look up host, protocol, and service information")
 (author "Jim Ursetto")
 (needs vector-lib foreigners)
 (egg "hostinfo.egg")
 (files "hostinfo.h" "hostinfo.meta" "hostinfo.scm" "hostinfo.setup")
 (license "BSD")
 (doc-from-wiki)
 (category net))
<
<
<
<
<
<
<
<
<


















Deleted hostinfo/hostinfo.scm version [15139d566b].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
101
102
103
104
105
106
107
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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
;;; hostinfo extension to Chicken Scheme
;;; Description: Look up host, service, and protocol information

;; Copyright (c) 2005-2008, Jim Ursetto.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;;   Redistributions of source code must retain the above copyright notice,
;;   this list of conditions and the following disclaimer. Redistributions in
;;   binary form must reproduce the above copyright notice, this list of
;;   conditions and the following disclaimer in the documentation and/or
;;   other materials provided with the distribution. Neither the name of the
;;   author nor the names of its contributors may be used to endorse or
;;   promote products derived from this software without specific prior
;;   written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;;

;; This extension performs host, protocol and service information lookups
;; via underlying calls to gethostbyname(3), getprotobyname(3), and
;; getservbyname(3).  Depending on your system, this may consult DNS,
;; NIS, /etc/hosts, /etc/services, /etc/protocols, and so on.

;; A simple interface is provided for the most commmon queries. Also
;; provided is a more comprehensive interface using records, which
;; contain all data available in a lookup.

;; IP addresses are represented by 4 (IPv4) or 16 (IPv6) byte
;; u8vectors. The interface requires, and returns, addresses in this
;; format; functions are provided to convert between the string and
;; u8vector representations. However, the "do what I want" procedures
;; (e.g. host-information) will do the conversion for you.

;; Caveats:
;; - IPv6 addresses can be converted to and from strings, and the underlying structure
;;   supports IPv6, but lookup of IPv6 addresses and records is not currently implemented.
;; - array0->string-vector and array0->bytevector-vector contain redundant code.
;; - host, services, and protocol-information check their argument types, even
;;   though the underlying code already does it.

(declare
 (fixnum))

(cond-expand [paranoia]
             [else
              (declare (no-bound-checks))])

#> #include "../hostinfo/hostinfo.h" <#

;; (require-extension srfi-4 lolevel posix)

(module hostinfo
;;; Short and sweet lookups
  (current-hostname
   hostname->ip ip->hostname
   protocol-name->number protocol-number->name
   service-port->name service-name->port
;;; Entire host, protocol or service record lookup
   hostname->hostinfo ip->hostinfo
   protocol-name->protoinfo protocol-number->protoinfo
   service-port->servinfo service-name->servinfo
;;; Record accessors and predicates
   hostinfo? hostinfo-name hostinfo-aliases hostinfo-addresses
   hostinfo-address hostinfo-type hostinfo-length
   protoinfo? protoinfo-name protoinfo-aliases protoinfo-number
   servinfo? servinfo-name servinfo-aliases servinfo-port servinfo-protocol
;;; One-stop shops -- does what you want
   host-information protocol-information service-information
;;; Utilities
   string->ip ip->string)

  (import chicken.fixnum chicken.string chicken.blob srfi-2 scheme
          typed-records srfi-9 chicken.foreign srfi-4 chicken.base
	  foreigners system-information
	  chicken.format)

  (define (vector-map p v0)   ; to avoid linking in vector-lib
    (let* ((len (vector-length v0))
           (v (make-vector len)))
      (do ((i 0 (+ i 1)))
          ((>= i len) v)
        (vector-set! v i
                     (p i (vector-ref v0 i))))))

  (cond-expand [unsafe
                (eval-when (compile)
                           (define-inline (##sys#check-string . r)
                             (##core#undefined))) ]
               [else])

;;; C data structure conversions

  (define (c-pointer->blob ptr len)
    (let ((bv (make-blob len))
          (memcpy (foreign-lambda bool "C_memcpy" blob c-pointer integer)))
      (memcpy bv ptr len)
      bv))

;; Convert from null-terminated array of c-strings to vector of strings.
;; These functions use C_alloc and so are not suitable for large datasets.
;; Note: get_argv_2 of runtime.c shows how to build a list instead of a vector (in reverse).
  (define array0->string-vector
    (foreign-primitive scheme-object (((c-pointer "char *") list)) "
    char **p; int len = 0;
    C_word *a, vec, *elt;

    for (p = list; *p; ++p, ++len);

    a = C_alloc(C_SIZEOF_VECTOR(len));
    vec = (C_word)a;
    *a++ = C_make_header(C_VECTOR_TYPE, len);

    for (p = list; *p; ++p) {
       len = strlen(*p);
       elt = C_alloc(C_SIZEOF_STRING(len));
       /* Both C_mutate and *a++ =  seem to work fine here. */
       C_mutate(a++, C_string(&elt, len, *p));
    }
    return(vec);"
                       ))

  ;; Convert from null-terminated array of IP addresses to vector of strings.
  (define array0->bytevector-vector
    (foreign-primitive scheme-object (((c-pointer "char *") list) (integer addrlen)) "
    char **p; int len = 0;
    C_word *a, vec, *elt;

    for (p = list; *p; ++p, ++len);

    a = C_alloc(C_SIZEOF_VECTOR(len));
    vec = (C_word)a;
    *a++ = C_make_header(C_VECTOR_TYPE, len);

    for (p = list; *p; ++p) {
       elt = C_alloc(C_SIZEOF_STRING(addrlen));
       C_mutate(a++, C_bytevector(&elt, addrlen, *p));
    }
    return(vec);"
                       ))

  ;; Not currently used.  Could make the array0-> stuff somewhat cleaner.
  ;; (define array0-length
  ;;   (foreign-lambda* integer (((pointer "void *") list)) #<<EOF
  ;;     void **p; int len = 0;
  ;;     for (p = list; *p; ++p, ++len);
  ;;     return(len);
  ;; EOF
  ;; ))

;;; string->ip conversion

  ;; inet_pton does not like "127.1", nor "0", nor any other non-standard
  ;; representation of IP addresses.  This is specified by RFC2553.
  ;; inet_aton resolves these addresses.  We use inet_pton here.

  (define-foreign-variable inet4-addrstrlen integer "INET_ADDRSTRLEN")
  (define-foreign-variable inet6-addrstrlen integer "INET6_ADDRSTRLEN")
  (define-foreign-variable af-inet  integer "AF_INET")
  (define-foreign-variable af-inet6 integer "AF_INET6")

  (define inet-ntop (foreign-lambda c-string "inet_ntop" integer u8vector c-string integer))
  (define inet-pton (foreign-lambda* bool ((integer type) (c-string src) (blob dest))
                                     "return(inet_pton(type, src, dest) == 1);"))

  (define (string->ip4 str)
    (##sys#check-string str 'string->ip4)
    (let ((bv (make-blob 4)))
      (and (inet-pton af-inet str bv)
           (blob->u8vector bv))))

  (define (string->ip6 str)
    (##sys#check-string str 'string->ip6)
    (let ((bv (make-blob 16)))
      (and (inet-pton af-inet6 str bv)
           (blob->u8vector bv))))

  (define (string->ip str)
    (or (string->ip4 str)
        (string->ip6 str)))

;;; ip->string conversion

  (define (ip4->string addr)
    (let ((len inet4-addrstrlen))
      (inet-ntop af-inet addr (make-string len) len)))

  (define (ip6->string addr)
    (let ((len inet6-addrstrlen))
      (inet-ntop af-inet6 addr (make-string len) len)))

  ;; Take an IPv4 or IPv6 u8vector and convert it into the
  ;; appropriate string representation, via inet_ntop.
  (define (ip->string addr)
    (let ((len (u8vector-length addr)))
      (cond ((fx= len 4)  (ip4->string addr))
            ((fx= len 16) (ip6->string addr))
            (else
             (error "Invalid IP address length" addr)))))

;;; hostent raw structure

  (define-foreign-record-type (hostent "struct hostent")
    (c-string h_name hostent-name)
    (c-pointer h_aliases hostent-h_aliases)
    (integer h_addrtype hostent-addrtype)
    (integer h_length hostent-length)
    (c-pointer h_addr_list hostent-addr-list))

  ;; Some convenient accessors for the raw hostent structure--with raw c pointers
  ;; converted to the appropriate scheme objects.  We only use these once or twice
  ;; below, so their main advantage is clarity.
  (define (hostent-aliases h)
    (array0->string-vector (hostent-h_aliases h)))
  (define (hostent-address h)
    (let* ((get-addr (foreign-lambda* c-pointer ((hostent h)) "return(h->h_addr_list[0]);"))
           (addr (get-addr h)))
      (blob->u8vector
       (c-pointer->blob addr (hostent-length h)))))
  (define (hostent-addresses h)
    (vector-map (lambda (i x) (blob->u8vector x))
                (array0->bytevector-vector (hostent-addr-list h)
                                           (hostent-length h))))
  ;; The IPv6 equivalents of these are getipnodebyname and
  ;; getipnodebyaddr.
  (define gethostent/name (foreign-lambda hostent "gethostbyname" c-string))

  (define (gethostent/addr addr)
    (if (fx= (u8vector-length addr) 4)
        (gethostent/addr/bv (u8vector->blob addr))
        (error "invalid IP address length; only IPv4 supported" addr)))

  ;; Warning: handle IPv6!!
  (define gethostent/addr/bv (foreign-lambda* hostent ((blob addr))
                                              "return(gethostbyaddr((const char *)addr, 4, AF_INET));"))

  ;; This was originally made a macro so we could easily return multiple
  ;; values -- but we're now returning a hostinfo structure.  Eh.
  (define (hostent->hostinfo h)
    (make-hostinfo (hostent-name h)
                   (hostent-addresses h)
                   (hostent-aliases h)))

;;; hostinfo and host information

  ;; The standard host name for the current processor.
  ;; Gets & Sets, error otherwise.

  (define set-host-name!
    (foreign-lambda* int ((c-string name))
                     "return(sethostname(name, strlen(name)));"))

  (define (current-hostname . args)
    (if (null? args)
        (get-host-name)
        (and (zero? (set-host-name! (->string (car args))))
             (error 'current-hostname "cannot set hostname"))))

  ;; Structure accessors created by define-foreign-record do not intercept
  ;; NULL pointer input, including #f.
  (define (hostname->ip host)
    (and-let* ((h (gethostent/name host)))
      (hostent-address h)))

  (define (hostname->hostinfo host)
    (and-let* ((h (gethostent/name host)))
      (hostent->hostinfo h)))

  (define (ip->hostname addr)
    (and-let* ((h (gethostent/addr addr)))
      (hostent-name h)))

  (define (ip->hostinfo addr)
    (and-let* ((h (gethostent/addr addr)))
      (hostent->hostinfo h)))

  ;; A simple hostinfo structure.
  (define-record-type hostinfo
    (make-hostinfo name addresses aliases)
    hostinfo?
    (name hostinfo-name)
    (addresses hostinfo-addresses)
    (aliases hostinfo-aliases))

  ;; "Accessors" for phantom fields.
  ;; We don't need to store length or type, as these are artifacts
  ;; of the C implementation, and can be derived from the address itself.
  (define (hostinfo-address h) (vector-ref (hostinfo-addresses h) 0))
  (define (hostinfo-length h) (u8vector-length (hostinfo-address h)))
  (define (hostinfo-type h)
    (let ((len (u8vector-length (hostinfo-address h))))
      (cond ((fx= len 4)  'AF_INET)   ;; Kind of a dummy implementation--
            ((fx= len 16) 'AF_INET6)  ;; not sure what value would be appropriate
            (else
             (error "Invalid IP address length" (hostinfo-address h))))))

  ;; Format the structure for easy interactive viewing--should be possible to
  ;; add a ctor for this representation, though it's not clear why you'd want to.
  (define-record-printer (hostinfo h port)
    (fprintf port "#,(hostinfo name: ~S addresses: ~S aliases: ~S)"
             (hostinfo-name h) (hostinfo-addresses h) (hostinfo-aliases h)))

  ;; Warning:  lookup of an IP address which is invalid yet numeric will
  ;; return a false positive.  Bug in gethostbyname?
  ;; E.g.  (hostname->hostinfo "1") => #,(hostinfo name: "1" addresses: (#u8(0 0 0 1)))
  ;; ** If we used inet_aton for string->ip, then these cases would
  ;; be transformed into u8vector IPs, and the lookup would correctly fail.

  ;; Return a hostinfo record.  HOST is a u8vector IP address, a string
  ;; hostname, or a string numeric IP address.
  (define (host-information host)
    (if (u8vector? host)
        (ip->hostinfo host)
        (begin
          (##sys#check-string host 'host-information)
          (cond ((string->ip host) => ip->hostinfo)
                (else (hostname->hostinfo host))))))

;;; protocols

  (define-foreign-record-type (protoent "struct protoent")
    (c-string p_name protoent-name)
    (c-pointer p_aliases protoent-p_aliases)
    (integer p_proto protoent-proto))

  (define getprotoent/name   (foreign-lambda protoent "getprotobyname" c-string))
  (define getprotoent/number (foreign-lambda protoent "getprotobynumber" integer))

  ;; Raw structure -> scheme-object accessors
  (define (protoent-aliases p)
    (array0->string-vector (protoent-p_aliases p)))

  (define-record-type protoinfo
    (make-protoinfo name number aliases)
    protoinfo?
    (name protoinfo-name)
    (number protoinfo-number)
    (aliases protoinfo-aliases))

  (define-record-printer (protoinfo p port)
    (fprintf port "#,(protoinfo name: ~S number: ~S aliases: ~S)"
             (protoinfo-name p) (protoinfo-number p) (protoinfo-aliases p)))

  (define (protocol-name->number name)
    (and-let* ((p (getprotoent/name name)))
      (protoent-proto p)))
  (define (protocol-number->name nr)
    (and-let* ((p (getprotoent/number nr)))
      (protoent-name p)))

  (define (protoent->protoinfo p)
    (make-protoinfo (protoent-name p)
                    (protoent-proto p)
                    (protoent-aliases p)))

  (define (protocol-name->protoinfo name)
    (and-let* ((p (getprotoent/name name)))
      (protoent->protoinfo p)))
  (define (protocol-number->protoinfo nr)
    (and-let* ((p (getprotoent/number nr)))
      (protoent->protoinfo p)))

  (define (protocol-information proto)
    (if (fixnum? proto)
        (protocol-number->protoinfo proto)
        (begin
          (##sys#check-string proto 'protocol-information)
          (protocol-name->protoinfo proto))))

;;; services

  (define-foreign-type port-number int
    (foreign-lambda int "htons" int)
    (foreign-lambda int "ntohs" int) )

  (define-foreign-record-type (servent "struct servent")
    (c-string s_name servent-name)
    (c-pointer s_aliases servent-s_aliases)
    (port-number s_port servent-port)
    (c-string s_proto servent-proto))

  (define (servent->servinfo s)
    (make-servinfo (servent-name s)
                   (servent-port s)
                   (array0->string-vector
                    (servent-s_aliases s))
                   (servent-proto s)))

  (define getservent/name (foreign-lambda servent "getservbyname" c-string c-string))
  (define getservent/port (foreign-lambda servent "getservbyport" port-number c-string))

  (define-record-type servinfo
    (make-servinfo name port aliases protocol)
    servinfo?
    (name servinfo-name)
    (port servinfo-port)
    (aliases servinfo-aliases)
    (protocol servinfo-protocol))

  (define-record-printer (servinfo s port)
    (fprintf port "#,(servinfo name: ~S port: ~S aliases: ~S protocol: ~S)"
             (servinfo-name s) (servinfo-port s) (servinfo-aliases s) (servinfo-protocol s)))

  ;; If provided with the optional protocol argument (a string), these will
  ;; restrict their search to that protocol.
  (define (service-name->port name . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/name name proto)))
                     (servent-port s))))
  (define (service-port->name port . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/port port proto)))
                     (servent-name s))))
  (define (service-name->servinfo name . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/name name proto)))
                     (servent->servinfo s))))
  (define (service-port->servinfo port . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/port port proto)))
                     (servent->servinfo s))))

  ;; Return service information given a service name or port, and an
  ;; optional protocol name or number to restrict the search to.
  ;; Note: if the protocol-number->name lookup fails,
  ;; an error is thrown, as this was probably not intended.
  (define (service-information service . pr)
    (let-optionals pr ((proto #f))
                   (let ((proto (if (fixnum? proto)
                                    (or (protocol-number->name proto)
                                        (error 'service-information "illegal protocol number" proto))
                                    proto)))
                     (if (fixnum? service)
                         (service-port->servinfo service proto)
                         (begin
                           (##sys#check-string service 'service-information)
                           (service-name->servinfo service proto))))))
)   ; end module

;;; Tests
(cond-expand
 [testing
  (import hostinfo)
  (current-hostname)
  (host-information "www.call-with-current-continuation.org")
  (host-information '#u8(194 97 107 133))
  (host-information "194.97.107.133")
                                        ; =>  #,(hostinfo name: "www003.lifemedien.de" addresses: #(#u8(194 97 107 133))
                                        ;        aliases: #("www.call-with-current-continuation.org"))
  (ip->hostname '#u8(194 97 107 133)) ; "www003.lifemedien.de"
  (string->ip "0708::0901")  ;  #u8(7 8 0 0 0 0 0 0 0 0 0 0 0 0 9 1)
  (ip->string '#u8(127 0 0 1))        ;  "127.0.0.1"
  (hostinfo-aliases
   (hostname->hostinfo
    (ip->hostname (hostname->ip
                   (hostinfo-name
                    (host-information "www.call-with-current-continuation.org"))))))
                                        ; => #("www.call-with-current-continuation.org")

  (protocol-information 17) ; => #,(protoinfo name: "udp" number: 17 aliases: #("UDP"))
  (protoinfo-name (protocol-information 2)) ; => "igmp"
  (protoinfo-aliases (protocol-name->protoinfo
                      (protocol-number->name
                       (protoinfo-number
                        (protocol-information "ospf"))))) ; => #("OSPFIGP")
  (protocol-name->number "OSPFIGP") ; 89 (you can look up aliases, too)

  (servinfo-protocol (service-name->servinfo
                      (service-port->name
                       (servinfo-port (service-information "ssh"))))) ; => "udp" (yes, really)
  (service-information "ssh" "tcp") ; => #,(servinfo name: "ssh" port: 22 aliases: #() protocol: "tcp")
  (service-information "ssh" "tco")   ; => #f
  (service-information 512 "tcp") ; #,(servinfo name: "exec" port: 512 aliases: #() protocol: "tcp")
  (service-information 512 "udp") ; #,(servinfo name: "comsat" port: 512 aliases: #("biff") protocol: "udp")
  (service-information 512 17)        ; same as previous
  (service-information 512 170000)   ; Error: (service-information) illegal protocol number: 170000
  ] [else])
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted hostinfo/hostinfo.setup version [94d320c0dc].

1
2
3
4
5
6
7
8
9
10
11
(define libs
  (if (eq? (build-platform) 'msvc)
      "-lws2_32"
      "") )

(compile -s -O2 -d2 hostinfo.scm ,libs -j hostinfo)
(compile -s -O2 -d0 hostinfo.import.scm)
(install-extension
 'hostinfo 
 '("hostinfo.so" "hostinfo.import.so")
 '((version "1.4.1")))
<
<
<
<
<
<
<
<
<
<
<