;;; -*-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.  There's a special case here for the
    ;; IPv6-mapped IPv4 address space ::ffff:0.0.0.0/96.
    (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-length 2)
	       (chunk 0 8))
	      ((and (= best-start 0)
		    (or (and (= best-length 5)
			     (= (aref words 5) #xffff))
			(= best-length 6)))
	       (let ((v4addr (make-instance 'ip4addr
					    :addr (ldb (byte 32 0) addr))))
		 (write-string "::" out)
		 (when (= best-length 5)
		   (chunk 5 6)
		   (write-char #\: out))
		 (write-string (ipaddr-string v4addr) out)))
	      (t
	       (chunk 0 best-start)
	       (write-string "::" out)
	       (chunk (+ best-start best-length) 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))
  (make-domain-name :labels (list "arpa" "ip6") :absolutep t))

;;;----- That's all, folks --------------------------------------------------