Project kick-off

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))))
+             )))))))