cl-rw

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

commit 9b5f5db7cd18e0678d4591dc889b200b717c8cc2
parent df145908860c79bb9ac51bab06456d3860a69a7f
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat,  1 Nov 2014 23:31:11 +0100

dns added

Diffstat:
Mcl-rw.asd | 4+++-
Adns.lisp | 212+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msocket.lisp | 25+++++++++++--------------
Awire.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))