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:
| M | dns.lisp | | | 322 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------ |
| M | rw.lisp | | | 17 | +++++++++++++---- |
| M | socket.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)
