ADDED hostinfo/hostinfo.h Index: hostinfo/hostinfo.h ================================================================== --- /dev/null +++ hostinfo/hostinfo.h @@ -0,0 +1,61 @@ +#ifdef _WIN32 +# include +# include + +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 + # include + # include /* in_addr */ +# include /* inet_ntop, ... */ +# include /* hostent, gethostby* */ +# include +#endif ADDED hostinfo/hostinfo.meta Index: hostinfo/hostinfo.meta ================================================================== --- /dev/null +++ hostinfo/hostinfo.meta @@ -0,0 +1,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)) ADDED hostinfo/hostinfo.scm Index: hostinfo/hostinfo.scm ================================================================== --- /dev/null +++ hostinfo/hostinfo.scm @@ -0,0 +1,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.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 + 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)) #<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]) ADDED hostinfo/hostinfo.setup Index: hostinfo/hostinfo.setup ================================================================== --- /dev/null +++ hostinfo/hostinfo.setup @@ -0,0 +1,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"))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -22,10 +22,11 @@ (include "stml2/cookie.scm") (include "stml2/stml2.scm") (include "pkts/pkts.scm") (include "csv-xml/csv-xml.scm") (include "ducttape/ducttape-lib.scm") +(include "hostinfo/hostinfo.scm") ;; (include "call-with-environment-variables/call-with-environment-variables.scm") (module megatest-main * @@ -136,10 +137,11 @@ (include "common.scm") (include "configf.scm") (include "margs.scm") (include "process.scm") (include "keys.scm") +(include "portlogger.scm") (include "db.scm") (include "rmt.scm") (include "runs.scm") (include "launch.scm") (include "server.scm") Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -15,17 +15,17 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit portlogger)) -(declare (uses db)) +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit portlogger)) +;; (declare (uses db)) ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away