cl-rw

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

commit 16eda13c367b19579c12f03b76b15a662554736d
parent f3aeb18e5e8f222f14a5e667eeff192026045e07
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun,  2 Nov 2014 13:57:41 +0100

dns queries over udp work on sbcl ccl ecl

Diffstat:
Mcl-rw.asd | 1+
Mder.lisp | 32++------------------------------
Mdns.lisp | 112+++++++++++++++++++++++++++++++++++++------------------------------------------
Msocket.lisp | 110++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------------
Astring.lisp | 56++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 192 insertions(+), 119 deletions(-)

diff --git a/cl-rw.asd b/cl-rw.asd @@ -47,6 +47,7 @@ (:file "ui") (:file "cas") (:file "zip") + (:file "string") (:file "der") (:file "wire") (:file "dns") diff --git a/der.lisp b/der.lisp @@ -40,34 +40,6 @@ ;; http://www.herongyang.com/Cryptography/Certificate-Format-PEM-on-Certificates.html ;; http://serverfault.com/questions/9708/what-is-a-pem-file-and-how-does-it-differ-from-other-openssl-generated-key-file -(defun octets-to-utf8-string (x) - #-(or ecl ccl sbcl) - (error "TODO port RW.DER::OCTETS-TO-UTF8-STRING") - #+ecl - (let ((s (ext:make-sequence-input-stream x :external-format :utf-8))) - (coerce (rw:till (rw:peek-reader (rw:char-reader s)) nil nil nil) 'string)) - #+ccl - (ccl:decode-string-from-octets x :external-format :utf-8) - #+sbcl - (sb-ext:octets-to-string x :external-format :utf-8)) - -(defun utf8-string-to-octets (x) - #-(or ecl ccl sbcl) - (error "TODO port RW.DER::UTF8-STRING-TO-OCTETS") - #+ecl - (let ((z (make-array 42 - :adjustable t - :fill-pointer 0 - :element-type '(unsigned-byte 8) - :initial-element 0))) - (write-string x - (ext:make-sequence-output-stream z :external-format :utf-8)) - z) - #+ccl - (ccl:encode-string-to-octets x :external-format :utf-8) - #+sbcl - (sb-ext:string-to-octets x :external-format :utf-8)) - (defun decode (reader) (labels ((len () (let ((n (rw:next-u8 reader))) @@ -147,7 +119,7 @@ (z (make-array n :element-type '(unsigned-byte 8) :initial-element 0))) - (dotimes (i n (list 'utf8string (octets-to-utf8-string z))) + (dotimes (i n (list 'utf8string (rw.string:octets-to-string z :utf-8))) (setf (aref z i) (rw:next-u8 reader))))) (19 ;; printablestring (list 'printable-string (ascii))) @@ -290,7 +262,7 @@ do (rw:write-u8 writer x)))) (utf8string (rw:write-u8 writer 12) - (let ((x (utf8-string-to-octets (cadr x)))) + (let ((x (rw.string:string-to-octets (cadr x) :utf-8))) (len (length x)) (loop for x across x diff --git a/dns.lisp b/dns.lisp @@ -22,7 +22,7 @@ (defpackage :rw.dns (:use :cl) - (:export :dns-query)) + (:export :query)) (in-package :rw.dns) @@ -101,18 +101,13 @@ (assert (= 8 (length x))) (map nil (lambda (x) (rw:write-u16 writer x)) x)) -(defun octets-to-string (x) ;; TODO refactor - (sb-ext:octets-to-string x :external-format :ascii)) - -(defun string-to-octets (x) ;; TODO refactor - (sb-ext:string-to-octets x :external-format :ascii)) - (defun next-$dns-string (reader) - (octets-to-string - (rw:next-octets reader (rw:next-u8 reader)))) + (rw.string:octets-to-string + (rw:next-octets reader (rw:next-u8 reader)) + :ascii)) (defun write-$dns-string (writer x) - (let ((b (string-to-octets x))) + (let ((b (rw.string:string-to-octets x :ascii))) (rw:write-u8 writer (length b)) (rw:write-octets writer b))) @@ -220,54 +215,53 @@ ($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 "www.google.com" #(8 8 8 8) :type 'AAAA)) - -;;(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 +(defun udp (buf server port) + (rw.socket:with-socket (s (rw.socket:make-udp-socket)) + (rw.socket:udp-send s buf (length buf) + :remote-host server + :remote-port port) + (let ((n (array-total-size buf))) + (setf (fill-pointer buf) n) + (multiple-value-bind (b len addr) (rw.socket:udp-receive s buf n) + (declare (ignore addr)) + ;;(print (list :@@@ (subseq b 0 len))) + (flet ((cb (pos) + (next-$name (rw:skip (rw:reader b) pos)))) + (let ((*name-from-position* #'cb)) + (next-$message (rw:shorter-reader (rw:reader b) len)))))))) + +(defun query (hostname server &key (type 'A) (class 'IN) (port 53)) + (let* ((n 512) ;; TODO minus IP/UDP headers + (b (rw.wire::make-octet-buffer n))) + (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)) ;; TODO dns over tcp + (udp b server port))) + +;;(print (query "mx1.logand.com" #+ccl "8.8.8.8" #-ccl #(8 8 8 8))) +;;(print (query "seznam.cz" #+ccl "8.8.8.8" #-ccl #(8 8 8 8))) +;;(print (query "seznam.cz" #(192 168 1 1))) +;;(print (query "www.google.com" #(8 8 8 8))) + +;;(print (query "mx1.logand.com" #(8 8 8 8) :type 'NS)) +;;(print (query "www.google.com" #(8 8 8 8) :type 'AAAA)) + +;;(print (query "mx1.logand.com" #(8 8 8 8) :type 'MX)) +;;(print (query "seznam.cz" #(8 8 8 8) :type 'MX)) +;;(print (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)) @@ -277,5 +271,3 @@ (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 @@ -23,21 +23,44 @@ (defpackage :rw.socket (:use :cl) (:export :accept + :close-socket :make-tcp-server-socket - :make-tcp-client-socket)) + :make-tcp-client-socket + :make-udp-socket + :udp-receive + :udp-send + :with-socket)) (in-package :rw.socket) -(defun make-tcp-server-socket (host port &key backlog) +(defun close-socket (socket) + #-(or ccl ecl sbcl) + (error "TODO port RW.SOCKET::CLOSE-SOCKET") + #+ccl + (close socket) + #+(or ecl sbcl) + (sb-bsd-sockets:socket-close socket)) + +(defun call-with-socket (socket fn) + (unwind-protect (funcall fn socket) + (close-socket socket))) + +(defmacro with-socket ((var socket) &body body) + `(call-with-socket ,socket (lambda (,var) ,@body))) + +(defun make-tcp-server-socket (local-host local-port &key backlog) #-(or sbcl ecl ccl) (error "TODO port RW.SOCKET:MAKE-TCP-SERVER-SOCKET") #+(or sbcl ecl) - (let ((x (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (let ((x (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address x) t) - (sb-bsd-sockets:socket-bind x - (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name host))) - port) + (sb-bsd-sockets:socket-bind + x + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name local-host))) + local-port) (sb-bsd-sockets:socket-listen x (or backlog 5)) x) #+ccl @@ -45,19 +68,22 @@ :address-family :internet :type :stream :format :bivalent ;; TODO :binary - :local-host host - :local-port port + :local-host local-host + :local-port local-port :reuse-address t)) -(defun make-tcp-client-socket (host port) +(defun make-tcp-client-socket (remote-host remote-port) #-(or sbcl ecl ccl) (error "TODO port RW.SOCKET:MAKE-TCP-CLIENT-SOCKET") #+(or sbcl ecl) - (let ((x (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) - (sb-bsd-sockets:socket-connect x - (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name host))) - port) + (let ((x (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect + x + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name remote-host))) + remote-port) (sb-bsd-sockets:socket-make-stream x :input t :output t ;;:buffering :none :element-type :default)) #+ccl @@ -65,25 +91,32 @@ :address-family :internet :type :stream :format :bivalent ;; TODO :binary - :remote-host host - :remote-port port)) + :remote-host remote-host + :remote-port remote-port)) -(defun make-udp-socket (host port &key remote-host remote-port) ;; TODO understand - #-(or ccl sbcl) +(defun make-udp-socket (&key local-host local-port remote-host remote-port) + #-(or ccl ecl sbcl) (error "TODO port RW.SOCKET:MAKE-PASSIVE-UDP-SOCKET") #+ccl - (ccl:make-socket ;;:connect :passive - :address-family :internet + (ccl:make-socket :address-family :internet :type :datagram - :local-host remote-host - :local-port port + :local-host local-host + :local-port local-port :remote-host remote-host - :remote-port remote-port - :reuse-address t) - #+sbcl - (make-instance 'sb-bsd-sockets:inet-socket - :type :datagram - :protocol :udp)) + :remote-port remote-port) + #+(or ecl sbcl) + (let ((x (make-instance 'sb-bsd-sockets:inet-socket + :type :datagram + :protocol :udp))) + (when (and local-host local-port) + (sb-bsd-sockets:socket-bind + x + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name local-host))) + local-port)) + (when (and remote-host remote-port) + (sb-bsd-sockets:socket-connect x remote-host remote-port)) + x)) ;; eol ;; keepalive nodelay broadcast linger @@ -104,3 +137,22 @@ :auto-close t) #+ccl (ccl:accept-connection socket)) + +(defun udp-send (socket buf len &key remote-host remote-port) + #-(or ccl ecl sbcl) + (error "TODO port RW.SOCKET:UDP-SEND") + #+ccl + (ccl:send-to socket buf len + :remote-host remote-host + :remote-port remote-port) + #+(or ecl sbcl) + (sb-bsd-sockets:socket-send socket buf len + :address (list remote-host remote-port))) + +(defun udp-receive (socket buf len) + #-(or ccl ecl sbcl) + (error "TODO port RW.SOCKET:UDP-RECEIVE") + #+ccl + (ccl:receive-from socket len :buffer buf) + #+(or ecl sbcl) + (sb-bsd-sockets:socket-receive socket buf len)) diff --git a/string.lisp b/string.lisp @@ -0,0 +1,56 @@ +;;; 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.string + (:use :cl) + (:export :octets-to-string + :string-to-octets)) + +(in-package :rw.string) + +(defun octets-to-string (x encoding) + #-(or ecl ccl sbcl) + (error "TODO port RW.STRING:OCTETS-TO-STRING") + #+ecl + (let ((s (ext:make-sequence-input-stream x :external-format encoding))) + (coerce (rw:till (rw:peek-reader (rw:char-reader s)) nil nil nil) 'string)) + #+ccl + (ccl:decode-string-from-octets x :external-format encoding) + #+sbcl + (sb-ext:octets-to-string x :external-format encoding)) + +(defun string-to-octets (x encoding) + #-(or ecl ccl sbcl) + (error "TODO port RW.STRING:STRING-TO-OCTETS") + #+ecl + (let ((z (make-array 42 + :adjustable t + :fill-pointer 0 + :element-type '(unsigned-byte 8) + :initial-element 0))) + (write-string x + (ext:make-sequence-output-stream z :external-format encoding)) + z) + #+ccl + (ccl:encode-string-to-octets x :external-format encoding) + #+sbcl + (sb-ext:string-to-octets x :external-format encoding))