Browse code
chore: add minimal implementation of ssdp
Edward Langley authored on 27/09/2022 04:25:16Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,60 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.ssdp-impl |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export )) |
|
| 4 |
+(in-package :fwoar.lisp-sandbox.ssdp-impl) |
|
| 5 |
+ |
|
| 6 |
+(defun crlf-string (&rest lines) |
|
| 7 |
+ (with-output-to-string (s) |
|
| 8 |
+ (loop for line in lines |
|
| 9 |
+ do |
|
| 10 |
+ (etypecase line |
|
| 11 |
+ (string (princ line s)) |
|
| 12 |
+ (cons (apply #'format s line))) |
|
| 13 |
+ (princ #.(coerce #(#\return #\newline) |
|
| 14 |
+ 'string) |
|
| 15 |
+ s)))) |
|
| 16 |
+ |
|
| 17 |
+ |
|
| 18 |
+(defun make-search (&optional (ST "upnp:rootdevice")) |
|
| 19 |
+ (crlf-string "M-SEARCH * HTTP/1.1" |
|
| 20 |
+ "HOST: 239.255.255.250:1900" |
|
| 21 |
+ "MAN:\"ssdp:discover\"" |
|
| 22 |
+ "MX:3" |
|
| 23 |
+ (list "ST: ~a" st) |
|
| 24 |
+ "")) |
|
| 25 |
+ |
|
| 26 |
+(defun send-discover-root-device (sock) |
|
| 27 |
+ (sb-bsd-sockets:socket-send sock |
|
| 28 |
+ (make-search) |
|
| 29 |
+ nil |
|
| 30 |
+ :address (list #(239 255 255 250) 1900))) |
|
| 31 |
+ |
|
| 32 |
+(defun send-search (sock &optional st) |
|
| 33 |
+ (sb-bsd-sockets:socket-send sock |
|
| 34 |
+ (make-search st) |
|
| 35 |
+ nil |
|
| 36 |
+ :address (list #(239 255 255 250) 1900))) |
|
| 37 |
+ |
|
| 38 |
+(defun receive-discover-result (sock &optional blocking) |
|
| 39 |
+ (let ((buffer (make-array 4096 :element-type 'serapeum:octet))) |
|
| 40 |
+ (multiple-value-bind (buf read address port) |
|
| 41 |
+ (sb-bsd-sockets:socket-receive sock buffer nil :dontwait (not blocking)) |
|
| 42 |
+ (declare (ignore read)) |
|
| 43 |
+ (values (when buf |
|
| 44 |
+ (funcall (http-parse:make-parser (make-instance 'http-parse:http-response)) |
|
| 45 |
+ buf)) |
|
| 46 |
+ address |
|
| 47 |
+ port)))) |
|
| 48 |
+ |
|
| 49 |
+(defun addr->int (addr) |
|
| 50 |
+ (let ((addr (coerce addr 'vector))) |
|
| 51 |
+ (cffi:with-foreign-object (vbuf :int32) |
|
| 52 |
+ (dotimes (i 4) |
|
| 53 |
+ (setf (cffi:mem-ref vbuf :uint8 i) (aref addr i))) |
|
| 54 |
+ (cffi:mem-aref vbuf :int32)))) |
|
| 55 |
+ |
|
| 56 |
+(defun setup-sockopt (socket addr) |
|
| 57 |
+ (setf (sb-bsd-sockets:sockopt-ip-multicast-loop socket) nil |
|
| 58 |
+ (sb-bsd-sockets:sockopt-multicast-if socket) (addr->int addr) |
|
| 59 |
+ (sb-bsd-sockets:sockopt-multicast-ttl socket) 2) |
|
| 60 |
+ socket) |