cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit cfa9d110874436bc91ce06d4e02c2c6f37392483
parent e8bbc4a2b37092eafa697bff6c3ad4f24716665e
Author: Tomas Hlavaty <tom@logand.com>
Date:   Thu, 25 Dec 2014 23:22:52 +0100

ipv4 and ipv6 address introduced, more dns features

Diffstat:
Mdns.lisp | 322+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------
Mrw.lisp | 17+++++++++++++----
Msocket.lisp | 249++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------
3 files changed, 472 insertions(+), 116 deletions(-)

diff --git a/dns.lisp b/dns.lisp @@ -31,6 +31,7 @@ ;;https://www.iana.org/domains/root/files ;;http://www.internic.net/domain/named.root ;;http://www.internic.net/domain/root.zone +;;http://www.lifewithdjbdns.org/ (defvar *name-from-position*) @@ -82,28 +83,44 @@ (values b (next-$name (rw:reader b)))) (defun next-$ipv4-address (reader) - (vector (rw:next-u8 reader) - (rw:next-u8 reader) - (rw:next-u8 reader) - (rw:next-u8 reader))) + (rw.socket:make-ipv4-address + (vector (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader)))) (defun write-$ipv4-address (writer x) - (assert (= 4 (length x))) - (map nil (lambda (x) (rw:write-u8 writer x)) x)) + (etypecase x + (rw.socket:ipv4-address + (let ((x (#+ccl + rw.socket::ipv4-integer-to-vector + #-ccl + progn + (rw.socket::native-ip-address x)))) + (assert (= 4 (length x))) + (map nil (lambda (x) (rw:write-u8 writer x)) x))))) (defun next-$ipv6-address (reader) - (vector (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader) - (rw:next-u16be reader))) + (rw.socket:make-ipv6-address + (vector (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader) + (rw:next-u16be reader)))) (defun write-$ipv6-address (writer x) - (assert (= 8 (length x))) - (map nil (lambda (x) (rw:write-u16 writer x)) x)) + (etypecase x + (rw.socket:ipv6-address + (let ((x (#+ccl + rw.socket::ipv6-integer-to-vector + #-ccl + progn + (rw.socket::native-ip-address x)))) + (assert (= 8 (length x))) + (map nil (lambda (x) (rw:write-u16be writer x)) x))))) (defun next-$dns-string (reader) (rw.string:octets-to-string @@ -298,36 +315,26 @@ (assert (<= (length b) n)) ;; TODO dns over tcp (udp b server port))) -;;(print (query1 "mx1.logand.com" #(8 8 8 8))) -;;(print (query1 "mx1.logand.com" "8.8.8.8")) - -;;(print (query1 "mx1.logand.com" #(8 8 8 8))) -;;(print (query1 "seznam.cz" #(8 8 8 8))) -;;(print (query1 "seznam.cz" #(192 168 1 1))) -;;(print (query1 "www.google.com" #(8 8 8 8))) - -;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'NS)) -;;(print (query1 "www.google.com" #(8 8 8 8) :type 'AAAA)) - -;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'MX)) -;;(print (query1 "seznam.cz" #(8 8 8 8) :type 'MX)) -;;(print (query1 "www.google.com" #(8 8 8 8) :type 'MX)) ;; TODO SOA follow authoritative nameservers - -;;; how to resolve logand.com? -;;; logand.com? com logand.com nserv0.domainexpress.co.uk -;;(print (query1 "com" #(8 8 8 8) :type 'A)) -;;(print (query1 "a.gtld-servers.net" #(8 8 8 8) :type 'A)) -;;(print (query1 "logand.com" #(192 5 6 30) :type 'A)) -;;(print (query1 "uk" #(192 5 6 30) :type 'A)) - -;;(print (query1 "www.google.com" #(8 8 8 8) :type 'MX)) -;;(print (query1 "ns1.google.com" #(8 8 8 8) :type 'A)) ;; -> #(216 239 32 10) -;;(print (query1 "www.google.com" #(216 239 32 10) :type 'MX)) -;;(print (query1 "google.com" #(216 239 32 10) :type 'MX)) - -;;(print (query1 "logand.com" #(8 8 8 8) :type 'MX)) -;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'A)) -;;(print (query1 "com" #(8 8 8 8))) +;;(query1 "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8")) +;;(query1 "seznam.cz" (rw.socket:make-ipv4-address "8.8.8.8")) +;;(query1 "seznam.cz" (rw.socket:make-ipv4-address "192.168.1.1")) +;;(query1 "www.google.com" (rw.socket:make-ipv4-address "8.8.8.8")) +;;(query1 "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'NS) +;;(query1 "www.google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'AAAA) +;;(query1 "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query1 "seznam.cz" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query1 "www.google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query1 "com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query1 "a.gtld-servers.net" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query1 "logand.com" (rw.socket:make-ipv4-address "192.5.6.30") :type 'A) +;;(query1 "uk" (rw.socket:make-ipv4-address "192.5.6.30") :type 'A) +;;(query1 "www.google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query1 "ns1.google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query1 "www.google.com" (rw.socket:make-ipv4-address "216.239.32.10") :type 'MX) +;;(query1 "google.com" (rw.socket:make-ipv4-address "216.239.32.10") :type 'MX) +;;(query1 "logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query1 "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query1 "com" (rw.socket:make-ipv4-address "8.8.8.8")) (defvar *cache* (make-hash-table :test #'equal)) ;; TODO locking? @@ -362,9 +369,49 @@ ($resource-class resource)) *cache*))) +(defun reverse-query-name (ip-address) + (etypecase ip-address + (rw.socket:ipv4-address + (with-output-to-string (s) + (loop + with x = (#-ccl + progn + #+ccl + rw.socket::ipv4-integer-to-vector + (rw.socket::ipv4-address-native ip-address)) + for i from 3 downto 0 + do (format s "~d." (aref x i))) + (write-string "in-addr.arpa" s))) + (rw.socket:ipv6-address + (with-output-to-string (s) + (loop + with x = (#-ccl + progn + #+ccl + rw.socket::ipv6-integer-to-vector + (rw.socket::ipv6-address-native ip-address)) + for i from 7 downto 0 + for e = (aref x i) + do (format s "~(~x.~x.~x.~x.~)" + (ldb (byte 4 0) e) + (ldb (byte 4 4) e) + (ldb (byte 4 8) e) + (ldb (byte 4 12) e))) + (write-string "ip6.arpa" s))))) + (defun query (name server &key (type 'A) (class 'IN) (port 53)) (clrhash *cache*) ;; TODO remove - (let ((i 0)) + (let ((i 0) + (name (etypecase name + (string name) + (rw.socket:ipv4-address + (assert (eq 'PTR type)) + (assert (eq 'IN class)) + (reverse-query-name name)) + (rw.socket:ipv6-address + (assert (eq 'PTR type)) + (assert (eq 'IN class)) + (reverse-query-name name))))) (labels ((rec (name type server) (or (lookup name type class) @@ -393,30 +440,163 @@ (SOA (return-from rec nil)))))))))) (values (rec name type server) i)))) -;;(query "logand.com" #(8 8 8 8) :type 'MX) -;;(query "mx1.logand.com" #(8 8 8 8) :type 'A) -;;(query "mx1.logand.com" #(8 8 8 8) :type 'CNAME) -;;(query "logand.com" #(8 8 8 8) :type 'SOA) - -;;(query "google.com" #(8 8 8 8) :type 'AAAA) -;;(query "google.com" #(8 8 8 8) :type 'A) -;;(query "google.com" #(8 8 8 8) :type 'MX) -;;(query "google.com" #(8 8 8 8) :type 'NS) -;;(query "google.com" #(8 8 8 8) :type 'SOA) - -;;(query "google.com" #(8 8 8 8) :type 'CNAME) -;;(query "google.com" #(8 8 8 8) :type 'PTR) -;;(query "mx1.logand.com" #(8 8 8 8) :type 'AAAA) -;;(query "82.192.70.8" #(8 8 8 8) :type 'PTR) - -;;(query "google.com" #(8 8 8 8) :type 'TXT) -;;(query "google.com" #(8 8 8 8) :type 'WKS) - -;;(query "google.com" #(198 41 0 4) :type 'A) -;;(query "mx1.logand.com" #(198 41 0 4) :type 'A) - -;; TODO root hints http://technet.microsoft.com/en-us/library/cc758353(v=ws.10).aspx -;; TODO reverse dns +;;(query "logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'CNAME) +;;(query "logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'SOA) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'AAAA) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'NS) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'SOA) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'TXT) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'CNAME) +;;(query "mx1.logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'AAAA) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'TXT) +;;(query "google.com" (rw.socket:make-ipv4-address "198.41.0.4") :type 'A) +;;(query "mx1.logand.com" (rw.socket:make-ipv4-address "198.41.0.4") :type 'A) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'RRSIG) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'DS) +;;(query "8.8.8.8.in-addr.arpa." (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query "8.8.8.8.in-addr.arpa" (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query ".ip6.arpa" (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query "8.70.192.82.in-addr.arpa" (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query (rw.socket:make-ipv4-address "82.192.70.8") (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query (rw.socket:make-ipv6-address #(10752 5200 16392 2049 0 0 0 4110)) (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query "ber01s09-in-x0e.1e100.net" (rw.socket:make-ipv4-address "8.8.8.8") :type 'AAAA) +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'AAAA) +;;(query (rw.socket:make-ipv4-address "94.242.206.239") (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query (rw.socket:make-ipv4-address "107.191.45.22") (rw.socket:make-ipv4-address "8.8.8.8") :type 'PTR) +;;(query "cr.yp.to" (rw.socket:make-ipv4-address "8.8.8.8") :type 'A) +;;(query "cr.yp.to" (rw.socket:make-ipv4-address "8.8.8.8") :type 'MX) +;;(query "yp.to" (rw.socket:make-ipv4-address "8.8.8.8") :type 'NS) +;;(query "cr.yp.to" (rw.socket:make-ipv4-address "208.67.222.222") :type 'A) + +;;(query "google.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'ANY) +;;(query "logand.com" (rw.socket:make-ipv4-address "8.8.8.8") :type 'ANY) + +;;http://technet.microsoft.com/en-us/library/cc758353(v=ws.10).aspx +(defun parse-named.root-line (line) + (let ((r (rw:peek-reader (rw:reader line)))) + (flet ((str () + (coerce (rw:till r '(#\space #\tab #\newline #\return)) + 'string))) + (let* ((name (str)) + (ttl (progn + (rw:skip r) + (rw:next-z0 r))) + (type (progn + (rw:skip r) + (let ((x (str))) + (cond + ((equal x "A") 'A) + ((equal x "AAAA") 'AAAA) + ((equal x "NS") 'NS) + (t (error "unexpected record ~x ~s" x line)))))) + (detail (progn + (rw:skip r) + (coerce (rw:till r '(#\newline #\return)) 'string)))) + (make-$resource :name name + :type type + :class 'IN + :ttl ttl + :data (ecase type + (A (rw.socket:make-ipv4-address detail)) + (AAAA (rw.socket:make-ipv6-address detail)) + (NS detail))))))) + +(defun parse-named.root (pathname) + (with-open-file (s pathname) + (loop + for line = nil + while (setq line (read-line s nil)) + unless (eql #\; (char line 0)) + collect (parse-named.root-line line)))) + +(defun parse-root.zone-line (line) + (let ((r (rw:peek-reader (rw:reader line)))) + (flet ((str (r) + (coerce (rw:till r '(#\space #\tab #\newline #\return)) + 'string))) + (let* ((name (str r)) + (ttl (progn + (rw:skip r) + (rw:next-z0 r))) + (class (progn + (rw:skip r) + (let ((x (str r))) + (cond + ((equal x "IN") 'IN) + (t (error "unexpected record ~x ~s" x line)))))) + (type (progn + (rw:skip r) + (let ((x (str r))) + (cond + ((equal x "A") 'A) + ((equal x "AAAA") 'AAAA) + ((equal x "NS") 'NS) + ((equal x "SOA") 'SOA) + ((equal x "RRSIG") 'RRSIG) + ((equal x "DNSKEY") 'DNSKEY) + ((equal x "NSEC") 'NSEC) + ((equal x "DS") 'DS) + (t (error "unexpected record ~s ~s" x line)))))) + (detail (progn + (rw:skip r) + (coerce (rw:till r '(#\newline #\return)) 'string)))) + (make-$resource :name name + :type type + :class class + :ttl ttl + :data (ecase type + (A (rw.socket:make-ipv4-address detail)) + (AAAA (rw.socket:make-ipv6-address detail)) + (NS detail) + (SOA + (let ((r (rw:peek-reader (rw:reader detail)))) + (make-$soa :mname (str r) + :rname (progn + (rw:skip r) + (str r)) + :serial (progn + (rw:skip r) + (rw:next-z0 r)) + :refresh (progn + (rw:skip r) + (rw:next-z0 r)) + :retry (progn + (rw:skip r) + (rw:next-z0 r)) + :expire (progn + (rw:skip r) + (rw:next-z0 r)) + :minimum (progn + (rw:skip r) + (rw:next-z0 r))))) + (RRSIG ;; TODO + ;;(error "TODO rrsig ~s" detail) + ;;"SOA 8 0 86400 20141220170000 20141213160000 22603 . EijJa8A2FUTsamqOXCg+k+CTRlAP+ban3iNJifmnEGZCy6PokdOkAj6q8vmoOdvpbLIDNn075KbXT6AFEYyRPh3espFzOBbhF2lonpb0d5rOc8hqH9wKYYbza1YkOh19Q+SNQGYllQCVnHNRvDtKL8bUhs2+gf+QpXiBB7Q4llk=" + #+nil(make-$rrsig )) + (DNSKEY ;; TODO + ;;(error "TODO dnskey ~s" detail) + ;;"256 3 8 AwEAAaPD7Y7XIi1MOEREJNTrRhyqsY3gff6JWzg+XCbqut1sbcbvqyssHw8DT1AkRaAC92pO8xuyq5QEgEPL1IHfABLwpwXI5gTj4gdwi86bpkmlWs9fRpnn4DPDCTdrnxIejJXgClHikLJF3u3CdpNCMijq4CKdQbMlRZ3avv+G7rh7" + #+nil(make-$dnskey )) + (NSEC ;; TODO + ;;(error "TODO nsec ~s" detail) + ;;"abogado. NS SOA RRSIG NSEC DNSKEY" + #+nil(make-$nsec )) + (DS ;; TODO + ;;(error "TODO ds ~s" detail) + ;;"57005 8 2 2009CA303DBEED162EE4BA3F255B2DB5C11FAF26A90804C06F9D8C54BFD6F02E" + #+nil(make-$ds )))))))) + +(defun parse-root.zone (pathname) + (with-open-file (s pathname) + (loop + for line = nil + while (setq line (read-line s nil)) + unless (eql #\; (char line 0)) + collect (parse-root.zone-line line)))) #+nil ;; TODO dns over tcp doesnt seem to work, depends on server? (defun tcp-query (name server &key (port 53)) diff --git a/rw.lisp b/rw.lisp @@ -75,7 +75,8 @@ :write-u32be :write-u32le :write-u8 - :writer)) + :writer + :z0)) (in-package :rw) @@ -319,10 +320,18 @@ (assert x)) (setf (aref z i) x))))) -(defun next-z0 (reader) - (let ((x (rw:till reader '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) t))) +(defun next-z0 (reader &optional (radix 10)) + (let ((x (rw:till reader + (ecase radix + (2 '(#\0 #\1)) + (8 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) + (10 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (16 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\a #\b #\c #\d #\e #\f + #\A #\B #\C #\D #\E #\F))) + t))) (when x - (parse-integer (coerce x 'string))))) ;; TODO better + (parse-integer (coerce x 'string) :radix radix)))) ;; TODO next-u64|128 ;; TODO next-s8|16|32|64|128 diff --git a/socket.lisp b/socket.lisp @@ -24,6 +24,12 @@ (:use :cl) (:export :accept :close-socket + :ipv4-address + :ipv4-address-string + :ipv6-address + :ipv6-address-string + :make-ipv4-address + :make-ipv6-address :make-tcp-server-socket :make-tcp-client-socket :make-udp-socket @@ -33,43 +39,204 @@ (in-package :rw.socket) -(defun native-address (x) +(defstruct (ipv4-address (:constructor %make-ipv4-address)) native string) +(defstruct (ipv6-address (:constructor %make-ipv6-address)) native string) + +(defun next-ipv4-address (r) + (ipv4-integer-to-vector + (cond + ((eql #\0 (rw:peek r)) + (rw:next r) + (cond + ((member (rw:peek r) '(#\x #\X)) + (rw:next r) + (rw:next-z0 r 16)) + (t + (rw:next-z0 r 8)))) + (t + (let ((a (rw:next-z0 r))) + (cond + ((eql #\. (rw:peek r)) + (rw:next r) + (let ((b (rw:next-z0 r))) + (cond + ((eql #\. (rw:peek r)) + (rw:next r) + (let ((c (rw:next-z0 r))) + (cond + ((eql #\. (rw:peek r)) + (rw:next r) + (logior (ash a 24) (ash b 16) (ash c 8) (rw:next-z0 r))) + (t + (logior (ash a 24) (ash b 16) c))))) + (t + (logior (ash a 24) b))))) + (t a))))))) + +(defun parse-ipv4-address (x) + (next-ipv4-address (rw:peek-reader (rw:reader x)))) + +;;(parse-ipv4-address "0xac1f35fe") +;;(parse-ipv4-address "025407632776") +;;(parse-ipv4-address "2887726590") +;;(parse-ipv4-address "172.2045438") +;;(parse-ipv4-address "172.31.13822") +;;(parse-ipv4-address "172.31.53.254") + +;;(parse-ipv4-address "ac.1f.35.fe") ;; TODO ??? + +(defun ipv4-integer-to-dotted (x) + (format nil "~d.~d.~d.~d" + (ldb (byte 8 24) x) + (ldb (byte 8 16) x) + (ldb (byte 8 8) x) + (ldb (byte 8 0) x))) + +(defun ipv4-vector-to-dotted (x) + (format nil "~d.~d.~d.~d" (aref x 0) (aref x 1) (aref x 2) (aref x 3))) + +(defun ipv4-integer-to-vector (x) + (vector (ldb (byte 8 24) x) + (ldb (byte 8 16) x) + (ldb (byte 8 8) x) + (ldb (byte 8 0) x))) + +(defun ipv4-vector-to-integer (x) + (logior (ash (aref x 0) 24) + (ash (aref x 1) 16) + (ash (aref x 2) 8) + (aref x 3))) + +(defun make-ipv4-address (x) + (etypecase x + (string (%make-ipv4-address :native (parse-ipv4-address x) :string x)) + (integer + (%make-ipv4-address :native + #-ccl (ipv4-integer-to-vector x) + #+ccl x + :string (ipv4-integer-to-dotted x))) + (vector + (assert (= 4 (length x))) + (%make-ipv4-address :native + #-ccl x + #+ccl (ipv4-vector-to-integer x) + :string (ipv4-vector-to-dotted x))))) + +;;(make-ipv4-address "127.0.0.1") +;;(make-ipv4-address #(127 0 0 1)) +;;(make-ipv4-address #x7f000001) +;;(make-ipv4-address 0) + +(defun next-ipv6-address (r) + (ipv6-integer-to-vector + (flet ((chain (n) + (loop + with z = 0 + for i from 0 + for p = (unless (member (rw:peek r) '(nil #\:)) + (let ((z (rw:next-z0 r 16))) + (assert z) + (assert (member (rw:next r) '(nil #\:))) + z)) + while p + do (assert (< i n)) + do (setq z (logior (ash z 16) p)) + finally (return (values z (- n i)))))) + (cond + ((eql #\: (rw:peek r)) + (rw:next r) + (assert (eql #\: (rw:next r))) + (chain 6)) + (t + (multiple-value-bind (hx hn) (chain 8) + (let ((x (ash hx (* hn 16)))) + (ecase (rw:peek r) + ((nil) x) + (#\: + (rw:next r) + (logior x (chain hn))))))))))) + +(defun parse-ipv6-address (x) + (next-ipv6-address (rw:peek-reader (rw:reader x)))) + +;;(parse-ipv6-address "::") +;;(parse-ipv6-address "::1") +;;(parse-ipv6-address "::1:2") +;;(parse-ipv6-address "0:0:0:0:0:0:0:0") +;;(parse-ipv6-address "0:0:0:0:0:0:0:1") +;;(parse-ipv6-address "f:e:d:c:b:a:9:8") +;;(parse-ipv6-address "2605:2700:0:3::4713:93e3") +;;(parse-ipv6-address "2001:503:ba3e::2:30") +;;(parse-ipv6-address "fc00::") + +(defun ipv6-integer-to-string (x) + (format nil "~(~x:~x:~x:~x:~x:~x:~x:~x~)" + (ldb (byte 16 112) x) + (ldb (byte 16 96) x) + (ldb (byte 16 80) x) + (ldb (byte 16 64) x) + (ldb (byte 16 48) x) + (ldb (byte 16 32) x) + (ldb (byte 16 16) x) + (ldb (byte 16 0) x))) + +(defun ipv6-vector-to-string (x) + (format nil "~(~x:~x:~x:~x:~x:~x:~x:~x~)" + (aref x 0) + (aref x 1) + (aref x 2) + (aref x 3) + (aref x 4) + (aref x 5) + (aref x 6) + (aref x 7))) + +(defun ipv6-integer-to-vector (x) + (vector (ldb (byte 16 112) x) + (ldb (byte 16 96) x) + (ldb (byte 16 80) x) + (ldb (byte 16 64) x) + (ldb (byte 16 48) x) + (ldb (byte 16 32) x) + (ldb (byte 16 16) x) + (ldb (byte 16 0) x))) + +(defun ipv6-vector-to-integer (x) + (logior (ash (aref x 0) 112) + (ash (aref x 1) 96) + (ash (aref x 2) 80) + (ash (aref x 3) 64) + (ash (aref x 4) 48) + (ash (aref x 5) 32) + (ash (aref x 6) 16) + (aref x 7))) + +(defun make-ipv6-address (x) + (etypecase x + (string (%make-ipv6-address :native (parse-ipv6-address x) :string x)) + (integer + (%make-ipv6-address :native + #-ccl (ipv6-integer-to-vector x) + #+ccl x + :string (ipv6-integer-to-string x))) + (vector + (assert (= 8 (length x))) + (%make-ipv6-address :native + #-ccl x + #+ccl (ipv6-vector-to-integer x) + :string (ipv6-vector-to-string x))))) + +;;(make-ipv6-address "f:e:d:c:b:a:9:8") +;;(make-ipv6-address #(1 2 3 4 5 6 7 8)) +;;(make-ipv6-address #x10002) +;;(make-ipv6-address 0) +;;(make-ipv6-address "2001:503:ba3e::2:30") + +(defun native-ip-address (x) (when x (etypecase x - (string - #-ccl - (let ((r (rw:peek-reader (rw:reader x)))) - (vector (rw:next-z0 r) - (progn - (assert (eql #\. (rw:next r))) - (rw:next-z0 r)) - (progn - (assert (eql #\. (rw:next r))) - (rw:next-z0 r)) - (progn - (assert (eql #\. (rw:next r))) - (rw:next-z0 r)))) - #+ccl - x) - (vector - #-ccl - x - #+ccl - (with-output-to-string (s) - (loop - for e across x - for i from 0 - do (progn - (assert (< i 4)) - (assert (<= 0 e 255)) - (when (plusp i) - (write-char #\. s)) - (format s "~d" e))))) - (list (native-address (coerce x 'vector)))))) - -;;(native-address #(127 0 0 1)) -;;(native-address '(127 0 0 1)) -;;(native-address "127.0.0.1") + (ipv4-address (ipv4-address-native x)) + (ipv6-address (ipv6-address-native x))))) (defun close-socket (socket) #-(or ccl ecl sbcl) @@ -109,7 +276,7 @@ :address-family :internet :type :stream :format :bivalent ;; TODO :binary - :local-host (native-address local-host) + :local-host (native-ip-address local-host) :local-port local-port :reuse-address t)) @@ -134,7 +301,7 @@ :address-family :internet :type :stream :format :bivalent ;; TODO :binary - :remote-host (native-address remote-host) + :remote-host (native-ip-address remote-host) :remote-port remote-port)) (defun make-udp-socket (&key local-host local-port remote-host remote-port) @@ -145,9 +312,9 @@ #+ccl (ccl:make-socket :address-family :internet :type :datagram - :local-host (native-address local-host) + :local-host (native-ip-address local-host) :local-port local-port - :remote-host (native-address remote-host) + :remote-host (native-ip-address remote-host) :remote-port remote-port) #+(or ecl sbcl) (let ((x (make-instance 'sb-bsd-sockets:inet-socket @@ -190,11 +357,11 @@ (error "TODO port RW.SOCKET:UDP-SEND") #+ccl (ccl:send-to socket buf len - :remote-host (native-address remote-host) + :remote-host (native-ip-address remote-host) :remote-port remote-port) #+(or ecl sbcl) (sb-bsd-sockets:socket-send socket buf len - :address (list (native-address remote-host) + :address (list (native-ip-address remote-host) remote-port))) (defun udp-receive (socket buf len)