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:
| M | cl-rw.asd | | | 1 | + |
| M | der.lisp | | | 32 | ++------------------------------ |
| M | dns.lisp | | | 112 | +++++++++++++++++++++++++++++++++++++------------------------------------------ |
| M | socket.lisp | | | 110 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------------- |
| A | string.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))
