--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; IPv6 address family support
+;;;
+;;; (c) 2014 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(in-package #:net)
+
+;;;--------------------------------------------------------------------------
+;;; Basic address type.
+
+(deftype u128 ()
+ "The type of unsigned 128-bit values."
+ '(unsigned-byte 128))
+
+(export 'ip6addr)
+(defclass ip6addr (ipaddr)
+ ((addr :type u128 :initarg :addr :reader ipaddr-addr)))
+
+(defmethod family-addrclass ((family (eql :ipv6))) 'ip6addr)
+
+(defmethod ipaddr-family ((addr ip6addr)) :ipv6)
+(defmethod ipaddr-width ((class (eql 'ip6addr))) 128)
+(defmethod ipaddr-rrtype ((addr ip6addr)) :aaaa)
+
+(defun parse-partial-ip6addr (str
+ &key (start 0) (end nil)
+ (min 0) (max 128))
+ "Parse (a substring of) STR as a partial IPv6 address.
+
+ Specifically, the address is assumed to have the following syntax.
+
+ WORD ::= HEXIT+
+ BYTE ::= DIGIT+
+ WORDS ::= WORD {`:' WORD}*
+ BYTES ::= BYTE {`.' BYTE}*
+ ADDR ::= [WORDS [`::']] WORDS [`:' BYTES] | [WORDS] `::' [WORDS]
+
+ There are a number of constraints not expressed in this simple syntax."
+
+ (labels ((parse-v6 (start end min max shiftp)
+ ;; Abbreviation for parsing a sequence of WORDs.
+ (parse-partial-address str :start start :end end
+ :delim #\: :radix 16 :width 16
+ :min min :max max :shiftp shiftp
+ :what "IPv6 address"))
+
+ (parse-v4 (start end min max shiftp)
+ ;; Abbreviation for parsing a sequence of BYTEs.
+ (parse-partial-address str :start start :end end
+ :delim #\. :radix 10 :width 8
+ :min min :max max :shiftp shiftp
+ :what "IPv4-in-IPv6 address"))
+
+ (parse-low-seq (start end min max shiftp)
+ ;; Parse a sequence [WORDS] | [WORDS `:'] BYTES.
+
+ (let ((last-colon (position #\: str :from-end t
+ :start start :end end))
+ (dotp (position #\. str :start start :end end)))
+
+ (cond ((not dotp)
+ ;; No dots, so no bytes to deal with.
+ (parse-v6 start end min max shiftp))
+
+ ((not last-colon)
+ ;; No colons, so no words to deal with. Ensure that
+ ;; the bytes are in the right place. This is a little
+ ;; fiddly.
+ (when (if shiftp
+ (> max 32)
+ (< max 32))
+ (error "Invalid IPv4-in-IPv6 address"))
+ (parse-v4 start end min (min max 32) t))
+
+ (t
+ ;; Both. The boundary is at the 32-bit mark -- after
+ ;; any necessary shifting.
+ (unless (> max 32)
+ (error "Invalid IPv4-in-IPv6 address"))
+ (multiple-value-bind (v6-addr v6-lo v6-hi)
+ (if shiftp
+ (let ((want (round-up (- max 32) 16)))
+ (parse-v6 start last-colon want want t))
+ (parse-v6 start last-colon
+ (max (- min 32) 1) (- max 32) nil))
+ (multiple-value-bind (v4-addr v4-lo v4-hi)
+ (parse-v4 (1+ last-colon) end
+ (max (- min (- v6-hi v6-lo)) 1) 32 t)
+ (declare (ignore v4-hi))
+ (values (logior (ash v6-addr 32) v4-addr)
+ v4-lo v6-hi))))))))
+
+ (let ((split (search "::" str :start2 start :end2 end)))
+ (if split
+ (multiple-value-bind (left-addr left-lo left-hi)
+ (parse-v6 start split 0 max t)
+ (let ((left-bits (- left-hi left-lo)))
+ (multiple-value-bind (right-addr right-lo right-hi)
+ (parse-low-seq (+ split 2) end
+ 0 (max (- max left-bits) 0) nil)
+ (declare (ignore right-hi))
+ (values (logior left-addr right-addr) right-lo left-hi))))
+ (parse-low-seq start end (max min 1) max t)))))
+
+(defmethod parse-partial-ipaddr ((class (eql 'ip6addr)) str
+ &key (start 0) (end nil) (min 0) (max 128))
+ (parse-partial-ip6addr str :start start :end end :min min :max max))
+
+(defmethod ipaddr-string ((ip ip6addr))
+ "Convert IP into an IPv6-syntax address string."
+ (let ((words (make-array 8 :element-type '(unsigned-byte 16)))
+ (addr (ipaddr-addr ip))
+ (i 0)
+ (best-start nil) (best-length 0)
+ (run-start nil))
+
+ ;; First step: parse the address into words. We could save consing by
+ ;; grabbing bytes out of the address, but it's not like we have a
+ ;; performance problem.
+ (dotimes (i 8)
+ (setf (aref words i)
+ (ldb (byte 16 (- 112 (* i 16))) addr)))
+
+ ;; Second step: identify the leftmost longest run of zeros.
+ (loop
+ (if (and (< i 8)
+ (zerop (aref words i)))
+ (unless run-start
+ (setf run-start i))
+ (when run-start
+ (let ((run-length (- i run-start)))
+ (when (> run-length best-length)
+ (setf best-start run-start
+ best-length run-length)))
+ (setf run-start nil)))
+ (when (>= i 8)
+ (return))
+ (incf i))
+
+ ;; Third step: output the two parts of the address either side of the
+ ;; longest zero run. If there are no zero words in the address, just
+ ;; write the whole thing.
+ (with-output-to-string (out)
+ (flet ((chunk (start end)
+ (when (< start end)
+ (let ((i start))
+ (loop
+ (format out "~(~X~)" (aref words i))
+ (incf i)
+ (when (>= i end) (return))
+ (write-char #\: out))))))
+ (cond (best-start
+ (chunk 0 best-start)
+ (write-string "::" out)
+ (chunk (+ best-start best-length) 8))
+ (t
+ (chunk 0 8)))))))
+
+;;;--------------------------------------------------------------------------
+;;; IPv6 networks.
+
+(defmethod ipmask ((addr ip6addr) (mask ip6addr))
+ (ipaddr-addr mask))
+
+(defclass ip6net (ipnet)
+ ((net :type ip6addr :initarg :net :reader ipnet-net)
+ (mask :type u128 :initarg :mask :reader ipnet-mask)))
+
+(defmethod ipaddr-ipnet ((addr ip6addr) mask)
+ (make-instance 'ip6net :net addr :mask mask))
+
+(defmethod ipnet-broadcast ((ipn ip6net)) nil)
+
+;;;--------------------------------------------------------------------------
+;;; Reverse lookups.
+
+(defmethod reverse-domain-component-width ((ipaddr ip6addr)) 4)
+(defmethod reverse-domain-radix ((ipaddr ip6addr)) 16)
+(defmethod reverse-domain-suffix ((ipaddr ip6addr)) "ip6.arpa")
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / zone / commitdiff