commit 9b5f5db7cd18e0678d4591dc889b200b717c8cc2
parent df145908860c79bb9ac51bab06456d3860a69a7f
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 1 Nov 2014 23:31:11 +0100
dns added
Diffstat:
| M | cl-rw.asd | | | 4 | +++- |
| A | dns.lisp | | | 212 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | socket.lisp | | | 25 | +++++++++++-------------- |
| A | wire.lisp | | | 249 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
4 files changed, 475 insertions(+), 15 deletions(-)
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -48,5 +48,7 @@
(:file "cas")
(:file "zip")
(:file "der")
- (:file "tls-macros")
+ (:file "wire")
+ (:file "dns")
+ (:file "tls-macros") ;; TODO use wire!
(:file "tls")))
diff --git a/dns.lisp b/dns.lisp
@@ -0,0 +1,212 @@
+;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.dns
+ (:use :cl)
+ (:export :dns-query))
+
+(in-package :rw.dns)
+
+;;https://www.ietf.org/rfc/rfc1035.txt
+
+(defvar *name-from-position*)
+
+(defun next-$name (reader) ;; TODO encoding?
+ (with-output-to-string (s)
+ (flet ((next ()
+ (rw:next-u8 reader)))
+ (loop
+ for n = (next)
+ for i from 0
+ while (plusp n)
+ do (progn
+ (when (plusp i)
+ (write-char #\. s))
+ (cond
+ ((< n 64)
+ (dotimes (i n)
+ (let ((n (next)))
+ (assert (<= 1 n 127))
+ (write-char (code-char n) s))))
+ (t
+ (assert (= #xc0 (logand #xc0 n)))
+ (write-string
+ (funcall
+ *name-from-position*
+ (logior (ash (logand #x3f n) 8) (next)))
+ s)
+ (return))))))))
+
+;;(next-$name (rw:reader #(3 109 120 49 6 108 111 103 97 110 100 3 99 111 109 0)))
+
+(defun write-$name (writer x) ;; TODO encoding?
+ (let ((r (rw:peek-reader (rw:reader x))))
+ (loop
+ for y = (rw:till r '(#\.))
+ for i from 0
+ while (progn
+ (rw:next r)
+ (rw:write-u8 writer (length y))
+ y)
+ do (dolist (e y)
+ (let ((n (char-code e)))
+ (assert (<= 1 n 127))
+ (rw:write-u8 writer n))))))
+
+#+nil
+(let ((b (rw.wire::make-octet-buffer 42)))
+ (write-$name (rw:writer b) "mx1.logand.com")
+ (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)))
+
+(defun write-$ipv4-address (writer x)
+ (assert (= 4 (length x)))
+ (map nil (lambda (x) (rw:write-u8 writer x)) x))
+
+(rw.wire:defenum $resource-type (:nbits 16)
+ (A . 1)
+ (NS . 2)
+ (MD . 3)
+ (MF . 4)
+ (CNAME . 5)
+ (SOA . 6)
+ (MB . 7)
+ (MG . 8)
+ (MR . 9)
+ (NULL . 10)
+ (WKS . 11)
+ (PTR . 12)
+ (HINFO . 13)
+ (MINFO . 14)
+ (MX . 15)
+ (TXT . 16)
+ (SRV . 33)
+ (OPT . 41)
+ (IXFR . 251)
+ (AXFR . 252)
+ (MAILB . 253)
+ (MAILA . 254)
+ (ALL . 255))
+
+(rw.wire:defenum $resource-class (:nbits 16)
+ (IN . 1)
+ (CS . 2)
+ (CH . 3)
+ (HS . 4))
+
+(rw.wire:defstruc $question ()
+ ($name name)
+ ($resource-type type)
+ ($resource-class class))
+
+(rw.wire:defstruc $mx-rdata ()
+ (rw.wire:u16 preference)
+ ($name name))
+
+(rw.wire:defstruc $resource ()
+ ($name name)
+ ($resource-type type)
+ ($resource-class class)
+ (rw.wire:u32 ttl)
+ #+nil(rw.wire:u8 data :length rw.wire:u16)
+ ((ecase type
+ (A $ipv4-address)
+ (CNAME $name)
+ (NS $name)
+ (MX $mx-rdata))
+ data :length rw.wire:u16))
+
+(rw.wire:defstruc $message ()
+ (rw.wire:u16 tid)
+ (rw.wire:u16 flags)
+ (rw.wire:u16 nquestion)
+ (rw.wire:u16 nanswer)
+ (rw.wire:u16 nauthority)
+ (rw.wire:u16 nadditional)
+ ($question question :size nquestion)
+ ($resource answer :size nanswer)
+ ($resource authority :size nauthority)
+ ($resource additional :size nadditional))
+
+(defun udp-query (hostname server &key (type 'A) (class 'IN) (port 53))
+ (let ((n 512) ;; TODO minus IP/UDP headers
+ (s (rw.socket::make-udp-socket server port)))
+ (unwind-protect
+ (let ((b (rw.wire::make-octet-buffer n)))
+ ;;(sb-bsd-sockets:socket-connect s server port)
+ (write-$message
+ (rw:writer b)
+ (make-$message
+ :tid #x3141 #+nil(random 65536)
+ :flags #x100 ;; std query TODO flags
+ :nquestion 1
+ :nanswer 0
+ :nauthority 0
+ :nadditional 0
+ :question (list (make-$question :name hostname
+ :type type
+ :class class))
+ :answer nil
+ :authority nil
+ :additional nil))
+ (assert (<= (length b) n))
+ (sb-bsd-sockets:socket-send s b (length b) :address (list server port))
+ (setf (fill-pointer b) n)
+ (multiple-value-bind (buf len addr)
+ (sb-bsd-sockets:socket-receive s b n)
+ (declare (ignore addr))
+ ;;(print (list ::@@@ (subseq buf 0 len)))
+ (flet ((cb (n)
+ (let (*name-from-position*)
+ (next-$name
+ (rw:skip (rw:reader buf) n)))))
+ (let ((*name-from-position* #'cb))
+ (next-$message
+ (rw:shorter-reader (rw:reader buf) len))))))
+ (sb-bsd-sockets:socket-close s))))
+
+;;(print (udp-query "mx1.logand.com" #(8 8 8 8)))
+;;(print (udp-query "seznam.cz" #(8 8 8 8)))
+;;(print (udp-query "seznam.cz" #(192 168 1 1)))
+;;(print (udp-query "www.google.com" #(8 8 8 8)))
+
+;;(print (udp-query "mx1.logand.com" #(8 8 8 8) :type 'NS))
+
+;;(print (udp-query "mx1.logand.com" #(8 8 8 8) :type 'MX))
+;;(print (udp-query "seznam.cz" #(8 8 8 8) :type 'MX))
+;;(print (udp-query "www.google.com" #(8 8 8 8) :type 'MX)) ;; TODO SOA follow authoritative nameservers
+
+#+nil ;; TODO dns over tcp doesnt seem to work, depends on server?
+(defun tcp-query (hostname server &key (port 53))
+ (with-open-stream (s (rw.socket:make-tcp-client-socket server port))
+ (let ((w (rw.wire:packet-writer s)))
+ (write-dns-question-packet w hostname)
+ (rw.wire:flush w)
+ (rw:next-u8 (rw:byte-reader s)))))
+
+;;(dns-query "seznam.cz" "8.8.8.8")
+;;(dns-query "seznam.cz" "192.168.1.1")
diff --git a/socket.lisp b/socket.lisp
@@ -68,26 +68,23 @@
:remote-host host
:remote-port port))
-(defun make-passive-udp-socket (host port)
- #-ccl
+(defun make-udp-socket (host port &key remote-host remote-port) ;; TODO understand
+ #-(or ccl sbcl)
(error "TODO port RW.SOCKET:MAKE-PASSIVE-UDP-SOCKET")
#+ccl
- (ccl:make-socket :connect :passive
+ (ccl:make-socket ;;:connect :passive
:address-family :internet
:type :datagram
- :local-host host
+ :local-host remote-host
:local-port port
- :reuse-address t))
+ :remote-host remote-host
+ :remote-port remote-port
+ :reuse-address t)
+ #+sbcl
+ (make-instance 'sb-bsd-sockets:inet-socket
+ :type :datagram
+ :protocol :udp))
-(defun make-active-udp-socket (host port)
- #-ccl
- (error "TODO port RW.SOCKET:MAKE-ACTIVE-UDP-SOCKET")
- #+ccl
- (ccl:make-socket :connect :active
- :address-family :internet
- :type :datagram
- :remote-host host
- :remote-port port))
;; eol
;; keepalive nodelay broadcast linger
;; backlog class out-of-band-inline
diff --git a/wire.lisp b/wire.lisp
@@ -0,0 +1,249 @@
+;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.wire
+ (:use :cl)
+ (:export :defenum
+ :defstruc
+ :flush
+ :packet-writer
+ :u8
+ :u16
+ :u24
+ :u32))
+
+(in-package :rw.wire)
+
+;; TODO lots of cut&paste from tls
+
+(defun make-octet-buffer (length)
+ (make-array length
+ :element-type '(unsigned-byte 8)
+ :initial-element 0
+ :adjustable t
+ :fill-pointer 0))
+
+(defun next-u8 (reader)
+ (rw:next-u8 reader))
+
+(defun next-u16 (reader)
+ (rw:next-u16 reader))
+
+(defun next-u24 (reader)
+ (rw:next-u24 reader))
+
+(defun next-u32 (reader)
+ (rw:next-u32 reader))
+
+(defun write-u8 (writer x)
+ (rw:write-u8 writer x))
+
+(defun write-u16 (writer x)
+ (rw:write-u16 writer x))
+
+(defun write-u24 (writer x)
+ (assert (<= 0 x #.(1- (expt 2 24))))
+ (write-u8 writer (ash x -16))
+ (write-u8 writer (logand #xff (ash x -8)))
+ (write-u8 writer (logand #xff x)))
+
+(defun write-u32 (writer x)
+ (rw:write-u32 writer x))
+
+(defun %intern (pre x post)
+ (intern (format nil "~a~a~a" pre x post) (symbol-package x)))
+
+(defun fname (x)
+ (%intern "" x ""))
+
+(defun mname (x)
+ (%intern "MAKE-" x ""))
+
+(defun rname (x)
+ (%intern "NEXT-" x ""))
+
+(defun wname (x)
+ (%intern "WRITE-" x ""))
+
+(defmacro defenum (name (&key nbits) &body alist)
+ (let ((fname (fname name))
+ (sname (%intern "" name "-SYMBOLS"))
+ (cname (%intern "" name "-CODES"))
+ (rname (rname name))
+ (wname (wname name)))
+ `(let* ((alist ',alist)
+ (symbols (mapcar #'car alist))
+ (codes (mapcar #'cdr alist)))
+ (defun ,fname (x)
+ (etypecase x
+ (symbol (cdr (assoc x alist)))
+ (integer (car (rassoc x alist)))))
+ (defun ,sname () symbols)
+ (defun ,cname () codes)
+ (defun ,rname (reader)
+ (let ((z (,fname (, (ecase nbits
+ (8 'rw:next-u8)
+ (16 'rw:next-u16))
+ reader))))
+ (assert z)
+ z))
+ (defun ,wname (writer x)
+ (, (ecase nbits
+ (8 'rw:write-u8)
+ (16 'rw:write-u16))
+ writer
+ (etypecase x
+ (symbol (,fname x))
+ (integer (when (member x codes) x))))))))
+
+(defun aname (struc &optional slot)
+ (intern (format nil "~a-~a" struc slot) (symbol-package struc)))
+
+(defun defun-rname-slot (slot)
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ `(,na
+ , (flet ((r1 ()
+ (if (listp ty)
+ `(ecase ,(cadr ty)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect (if ty
+ `(,nm (,(rname ty) r))
+ `(,nm))))
+ `(,(rname ty) r))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (or compute next))
+ (length
+ `(let ((l (,(rname length) r))
+ (b (make-octet-buffer 100)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (dotimes (i l)
+ (vector-push-extend (next-u8 r) b))
+ ,(if (eq 'u8 ty)
+ 'b
+ (if size
+ `(let ((r (rw:peek-reader (rw:reader b))))
+ (loop
+ while (rw:peek r)
+ collect ,(r1)))
+ `(let ((r (rw:reader b)))
+ ,(r1))))))
+ (size
+ ;;(assert (eq 'u8 ty))
+ `(loop for i from 0 below ,size collect ,(r1)))
+ (t
+ `(let ((v ,(r1)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ v)))))))
+
+(defun defun-rname (name slots)
+ `(defun ,(rname name) (r)
+ (let* (,@(mapcar 'defun-rname-slot slots))
+ (,(mname name)
+ ,@(loop
+ for slot in slots
+ appending (let ((na (cadr slot)))
+ (list (intern (symbol-name na) :keyword) na)))))))
+
+(defun defun-wname (name slots)
+ `(defun ,(wname name) (w x)
+ ,@(loop
+ for slot in slots
+ collect
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ (flet ((w1 ()
+ (if (listp ty)
+ (ecase (car ty)
+ (ecase `(ecase (,(aname name (cadr ty)) x)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect
+ (if ty
+ `(,nm (,(wname ty) w v))
+ `(,nm))))))
+ `(,(wname ty) w v))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (when compute
+ `(setf (,(aname name na) x) ,compute)))
+ (length
+ `(let ((v (,(aname name na) x))
+ (b (make-octet-buffer 100)))
+ (let ((w (rw:writer b)))
+ ,(cond
+ (size
+ `(if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1))))
+ (t (w1))))
+ (let ((l (length b)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (,(wname length) w l))
+ (loop for e across b do (write-u8 w e))))
+ (size
+ ;;(assert (eq 'u8 ty))
+ `(let ((v (,(aname name na) x)))
+ ,@ (when (or min max (integerp size))
+ `((let ((l (length v)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size)))))))
+ (if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1)))))
+ (t
+ `(let ((v (,(aname name na) x)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ ,(w1)))))))))
+
+(defmacro defstruc (name () &body slots)
+ `(progn
+ (defstruct ,(fname name) ,@(mapcar #'cadr slots))
+ ,(defun-rname name slots)
+ ,(defun-wname name slots)))
+
+(defun packet-writer (stream)
+ (let ((b (make-octet-buffer 42)))
+ (lambda (x)
+ (case x
+ (flush
+ (print b)
+ (write-sequence b stream)
+ (finish-output stream)
+ (setf (fill-pointer b) 0))
+ (t
+ (vector-push-extend x b)))
+ x)))
+
+(defun flush (writer)
+ (funcall writer 'flush))
