diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/client.lisp | 48 | ||||
| -rw-r--r-- | src/packet.lisp | 83 | ||||
| -rw-r--r-- | src/publisher.lisp | 52 |
3 files changed, 183 insertions, 0 deletions
diff --git a/src/client.lisp b/src/client.lisp new file mode 100644 index 0000000..fd0b581 --- /dev/null +++ b/src/client.lisp @@ -0,0 +1,48 @@ +(defpackage :cl-mdns/client + (:use :cl + :cl-mdns/packet) + (:local-nicknames (:nb :nibbles) + (:f :fsocket)) + (:export :lookup)) +(in-package :cl-mdns/client) + +(defvar *mdns-address* #(224 0 0 251)) +(defvar *mdns-port* 5353) + +(defun parse-ipv4-response (packet) + "Extracts the first IPv4 address found in a DNS response packet." + (let* ((qdcount (+ (ash (aref packet 4) 8) (aref packet 5))) + (ancount (+ (ash (aref packet 6) 8) (aref packet 7))) + (pos 12)) ; Start after header + + ;; Skip Question section + (loop repeat qdcount do + (loop while (not (zerop (aref packet pos))) + do (incf pos (1+ (aref packet pos)))) + (incf pos 5)) ; Skip null byte + Type(2) + Class(2) + + ;; Parse Answer section + (if (> ancount 0) + (let ((type (+ (ash (aref packet (+ pos 2)) 8) (aref packet (+ pos 3)))) + ;(rdlen (+ (ash (aref packet (+ pos 10)) 8) (aref packet (+ pos 11)))) + ) + ;; If Type is 1 (A record), return the next 4 bytes as an IP string + (if (= type 1) + (format nil "~D.~D.~D.~D" + (aref packet (+ pos 12)) (aref packet (+ pos 13)) + (aref packet (+ pos 14)) (aref packet (+ pos 15))) + "Non-IPv4 record received")) + "No answers found"))) + +(defun lookup (domain) + (let ((fd (f:open-socket :type :datagram)) + (packet (build-query-packet domain)) + (buffer (make-array 512 :element-type '(unsigned-byte 8)))) + (unwind-protect + (progn + (f:socket-bind fd (f:make-sockaddr-in)) + (f:socket-sendto fd packet (f:make-sockaddr-in :addr *mdns-address* :port *mdns-port*)) + (multiple-value-bind (count raddr) (f:socket-recvfrom fd buffer) + (declare (ignore raddr)) + (parse-ipv4-response (subseq buffer 0 count)))) + (f:close-socket fd)))) diff --git a/src/packet.lisp b/src/packet.lisp new file mode 100644 index 0000000..12b8926 --- /dev/null +++ b/src/packet.lisp @@ -0,0 +1,83 @@ +(defpackage :cl-mdns/packet + (:use :cl) + (:local-nicknames (:nb :nibbles)) + (:export :build-query-packet)) + +(in-package :cl-mdns/packet) + +(defun encode-name (name-string) + "Converts local domain name to encoded byte array. + E.g. converts 'name.local' to #(4 110 97 109 101 5 108 111 99 97 108 0)" + (let ((parts (uiop:split-string name-string :separator ".")) + (output (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) + (dolist (part parts) + (vector-push-extend (length part) output) + (loop for char across part do + (vector-push-extend (char-code char) output))) + (vector-push-extend 0 output) ; Terminate + output)) + +(defun make-question-header () + (let ((buffer (make-array 12 :element-type '(unsigned-byte 8) :initial-element 0))) + ;; Transaction ID (2 bytes): 0 for mDNS + ;; Flags (2 bytes): 0x0000 basic query + ;; QDCOUNT (2 bytes): 1 + (setf (nb:ub16ref/be buffer 4) 1) + buffer)) + +(defun make-question-tail () + (let ((buffer (make-array 4 :element-type '(unsigned-byte 8)))) + (setf (nibbles:ub16ref/be buffer 0) #x01) ; Type: AA + (setf (nibbles:ub16ref/be buffer 2) 1) ; Class: IN + buffer)) + +(defun build-query-packet (service-name) + "Creates 'question' packet for given SERVICE-NAME." + (let ((header (make-question-header)) + (name (encode-name service-name)) + (tail (make-question-tail))) + (concatenate '(vector (unsigned-byte 8)) header name tail))) + +(defun make-dns-header () + (let ((buffer (make-array 12 :element-type '(unsigned-byte 8) :initial-element 0))) + ;; Header + (setf (nb:ub16ref/be buffer 0) 0) + (setf (nb:ub16ref/be buffer 2) #x8400) ; Flags: Standard response, AA + (setf (nb:ub16ref/be buffer 4) 0) ; Questions + (setf (nb:ub16ref/be buffer 6) 1) ; Answer RRs + (setf (nb:ub16ref/be buffer 8) 0) ; Authority RRs + (setf (nb:ub16ref/be buffer 10) 0) ; Additional RRs + + buffer)) + +(defun ip-addr-list-p (x) + (and (listp x) + (= (length x) 4) + (every #'integerp x))) + +(deftype ip-addr-list () + '(satisfies ip-addr-list-p)) + +(defun make-ip-body (ip) + (destructuring-bind (ip-a ip-b ip-c ip-d) ip + (let ((buffer (make-array 14 :element-type '(unsigned-byte 8) :initial-element 0)) + (pos 0)) + ;; Type A (1), Class IN (1) + (setf (nb:ub16ref/be buffer pos) 1) (incf pos 2) + (setf (nb:ub16ref/be buffer pos) 1) (incf pos 2) + ;; TTL (120 seconds) + (setf (nb:ub32ref/be buffer pos) 120) (incf pos 4) + ;; Data Length (4 bytes for IPv4) + (setf (nb:ub16ref/be buffer pos) 4) (incf pos 2) + (setf (aref buffer pos) ip-a) (incf pos) + (setf (aref buffer pos) ip-b) (incf pos) + (setf (aref buffer pos) ip-c) (incf pos) + (setf (aref buffer pos) ip-d) + buffer))) + +(defun build-response (domain-name ip) + (check-type ip ip-addr-list) + (let ((header (make-dns-header)) + (name (encode-name domain-name)) + (ip-part (make-ip-body ip))) + (concatenate '(vector (unsigned-byte 8)) header name ip-part))) diff --git a/src/publisher.lisp b/src/publisher.lisp new file mode 100644 index 0000000..bcff655 --- /dev/null +++ b/src/publisher.lisp @@ -0,0 +1,52 @@ +;; Doesn't currently work. I'm unable to join the multicast group to listen for messages. +(defpackage :cl-mdns/publisher + (:use :cl + :cl-mdns/packet) + (:local-nicknames (:nb :nibbles) + (:f :fsocket))) +(in-package :cl-mdns/publisher) + +(defvar *mdns-address* #(224 0 0 251)) +(defvar *mdns-port* 5353) + +; TODO: Bring cl-arrows lib so I can thread expressions +(defun parse-query-body-message (lst) + "Parses the body of message. +The rest of the packet (meaning the tail) is ignored." + (labels ((parse-rec (acc rem-lst) + (destructuring-bind (cnt &rest msg) rem-lst + (if (or (null cnt) (zerop cnt)) + acc + (parse-rec + (concatenate 'list acc (list (coerce (map 'list #'code-char (subseq msg 0 cnt)) 'string))) + (nthcdr cnt msg)))))) + (parse-rec nil lst))) + +(defun parse-query (query) + "Parses question/query and returns domain name. +Completely ignores header and tail of packet for now." + (let ((message (subseq query 12))) + (format nil "~{~A~^.~}" + (parse-query-body-message message)))) + +(defun publish () + (f:with-poll (pc) + (f:with-socket (sock :datagram) + (let ((addr (f:make-sockaddr-in :addr *mdns-address* :port *mdns-port*)) + (laddr (f:make-sockaddr-in :port *mdns-port*)) + (buffer (make-array 512 :element-type '(unsigned-byte 8)))) + + ;; Prepare multicast socket + (setf (f:socket-option sock :socket :reuseaddr) t) + (f:socket-bind sock laddr) + (f:multicast-join sock addr) + + ;; Register for polling - we don't want to waste compute time on active listening + (f:poll-register pc (make-instance 'f:pollfd :fd sock :events (f:poll-events :pollin))) + (loop + (f:doevents (pollfd event) (f:poll pc) + (case event + (:pollin + (multiple-value-bind (count saddr) (f:socket-recvfrom sock buffer) + (format t "Recieved ~A from ~A, buffer: ~A" count saddr (subseq buffer 0 count)))) + ))))))) |