dlna-chad-music/dlna.lisp

(in-package :cl-user)
(defpackage dlna-chad-music
  (:use :cl)
  (:import-from :woo.ev.event-loop
                :check-event-loop-running
                :with-event-loop
                :callbacks
                :*evloop*
                :*input-buffer*)
  (:import-from :alexandria
                :when-let
                :with-gensyms)
  (:import-from :woo.ev.util
                :define-c-callback
                :io-fd))
(in-package :dlna-chad-music)

(defparameter +sockaddr-in-size+ (cffi:foreign-type-size '(:struct wsock::sockaddr-in)))

(defun set-sock-int-opt (fd level optname &optional (value 1))
  (cffi:with-foreign-object (optval :int)
    (setf (cffi:mem-aref optval :int) value)
    (when (= (wsock:setsockopt fd level optname optval (cffi:foreign-type-size :int)) -1)
      (error 'os-error
             :description "Cannot set socket option"
             :code (wsys:errno)))))

(defun udp-socket (address port &key sockopt)
  (cffi:with-foreign-object (ai '(:pointer (:struct wsock:addrinfo)))
    (cffi:with-foreign-object (hints '(:struct wsock:addrinfo))
      (wsys:bzero hints (cffi:foreign-type-size '(:struct wsock:addrinfo)))
      (cffi:with-foreign-slots ((wsock::family wsock::socktype wsock::flags) hints (:struct wsock:addrinfo))
        (setf wsock::family (if (and (stringp address)
                                     (quri.domain:ipv6-addr-p address))
                                wsock:+AF-INET6+
                                wsock:+AF-INET+)
              wsock::socktype wsock:+SOCK-DGRAM+
              wsock::flags wsock:+AI-PASSIVE+))
      (let ((err (wsock:getaddrinfo (or address (cffi:null-pointer))
                                    (if port (write-to-string port) (cffi:null-pointer))
                                    hints ai)))
        (unless (= err 0)
          (error 'os-error
                 :description "getaddrinfo() failed"
                 :code err))))
    (let ((ai (cffi:mem-ref ai :pointer)))
      (cffi:with-foreign-slots ((wsock::family
                                 wsock::socktype
                                 wsock::protocol
                                 wsock::addr
                                 wsock::addrlen)
                                ai
                                (:struct wsock:addrinfo))
        (let ((fd (wsock:socket wsock::family wsock::socktype wsock::protocol)))
          (when (= fd -1)
            (error 'os-error
                   :description (format nil "Cannot create udp socket (family=~S / socktype=~S / protocol=~S)"
                                        wsock::family
                                        wsock::socktype
                                        wsock::protocol)
                   :code (wsys:errno)))
          (when sockopt (set-sock-int-opt fd wsock:+SOL-SOCKET+ sockopt))
          (when (= (wsock:bind fd wsock::addr wsock::addrlen) -1)
            (error 'os-error
                   :description (format nil "Cannot bind fd to the address ~S" address)
                   :code (wsys:errno)))
          (wsock:freeaddrinfo ai)
          fd)))))

(defun join-multicast-group (fd address)
  (cffi:with-foreign-object (mreq '(:struct wsock:ip-mreq))
    (cffi:with-foreign-slots ((wsock::multiaddr wsock::interface) mreq (:struct wsock:ip-mreq))
      (setf wsock::multiaddr (wsock:inet-addr address)
            wsock::interface wsock:+inaddr-any+)
      (when (= (wsock:setsockopt fd wsock:+ipproto-ip+
                                 wsock:+ip-add-membership+ mreq
                                 (cffi:foreign-type-size '(:struct wsock:ip-mreq))) -1)
        (error 'os-error
               :description (format nil "Cannot join fd to multicast group ~A" address)
               :code (wsys:errno))))))

(defvar *udp-name-len* 128)
(defvar *udp-buffer-len* (* 1024 64))
(defvar *udp-control-len* 1024)
(defparameter *udp-message* nil)
(defparameter *udp-name* nil)
(defparameter *udp-iov* nil)
(defparameter *udp-control* nil)
(defparameter *udp-buffer* nil)
(defparameter *udp-sockstring* nil)

(defmacro with-udp-buffers (&body body)
  `(let ((*udp-name* (static-vectors:make-static-vector *udp-name-len*))
         (*udp-buffer* (static-vectors:make-static-vector *udp-buffer-len*))
         (*udp-control* (static-vectors:make-static-vector *udp-control-len*))
         (*udp-sockstring* (cffi:foreign-alloc :char :count wsock:+inet6-addrstrlen+)))
     (cffi:with-foreign-objects
         ((*udp-message* '(:struct wsock:msghdr))
          (*udp-iov* '(:struct wsock:iovec)))
       (cffi:with-foreign-slots ((wsock::name wsock::iov wsock::iovlen wsock::control wsock::controllen)
                                 *udp-message* (:struct wsock:msghdr))
         (cffi:with-foreign-slots ((wsock::base wsock::len) *udp-iov* (:struct wsock:iovec))
           (setf wsock::base (static-vectors:static-vector-pointer *udp-buffer*)
                 wsock::len (length *udp-buffer*)
                 wsock::name (static-vectors:static-vector-pointer *udp-name*)
                 ;; namelen and controllen have to be set on all recvmsg
                 wsock::iov *udp-iov*
                 wsock::iovlen 1
                 wsock::control (static-vectors:static-vector-pointer *udp-control*))
           (unwind-protect (progn ,@body)
             (static-vectors:free-static-vector *udp-name*)
             (static-vectors:free-static-vector *udp-buffer*)
             (static-vectors:free-static-vector *udp-control*)
             (cffi:foreign-free *udp-sockstring*)))))))

(defun get-name-port (sockaddr)
  (let ((family (cffi:foreign-slot-value sockaddr '(:struct wsock:sockaddr-storage) 'wsock::family)))
    (declare (type fixnum family))
    (cond
      ((= family wsock:+AF-INET6+)
       (wsock:inet-ntop family (cffi:foreign-slot-pointer sockaddr '(:struct wsock:sockaddr-in6) 'wsock::addr)
                        *udp-sockstring* wsock:+inet6-addrstrlen+)
       (values
        (cffi:foreign-string-to-lisp *udp-sockstring*)
        (swap-bytes:ntohs (cffi:foreign-slot-value sockaddr '(:struct wsock:sockaddr-in6) 'wsock::port))))
      ((= family wsock:+AF-INET+)
       (wsock:inet-ntop family (cffi:foreign-slot-pointer sockaddr '(:struct wsock:sockaddr-in) 'wsock::addr)
                        *udp-sockstring* wsock:+inet6-addrstrlen+)
       (values
        (cffi:foreign-string-to-lisp *udp-sockstring*)
        (swap-bytes:ntohs (cffi:foreign-slot-value sockaddr '(:struct wsock:sockaddr-in) 'wsock::port))))
      (:otherwise (values nil nil)))))

(defmacro with-sockaddr-in ((var addr port) &body body)
  `(cffi:with-foreign-object (,var '(:struct wsock::sockaddr-in))
     (cffi:with-foreign-slots ((wsock::family wsock::addr wsock::port) ,var (:struct wsock::sockaddr-in))
       (setf wsock::family wsock:+af-inet+
             wsock::addr (wsock:inet-addr ,addr)
             wsock::port (swap-bytes:htons ,port))
       ,@body)))

(defun send-to (fd addr port data)
  (with-sockaddr-in (dest addr port)
    (let ((message (trivial-utf-8:string-to-utf-8-bytes data)))
      (cffi:with-pointer-to-vector-data (buffer data)
        (wsock:sendto fd buffer (length message) 0 dest +sockaddr-in-size+)))))

(defun align-h (size)
  (declare (optimize (speed 3) (safety 0)))
  (declare (type (unsigned-byte 32) size))
  (let ((r (1- (the (integer 4 32) (cffi:foreign-type-size 'wsock::size-t)))))
    (logand (+ size r) (lognot r))))
(defun align-d (size) (align-h size))

(defun cmsg-next (msg cmsg)
  (cffi:with-foreign-slots ((wsock::control wsock::controllen) msg (:struct wsock::msghdr))
    (declare (type (unsigned-byte 32) wsock::controllen))
    (if (cffi:null-pointer-p cmsg)
        (if (>= wsock::controllen (the (unsigned-byte 32) (cffi:foreign-type-size '(:struct wsock:cmsghdr))))
            wsock::control (cffi:null-pointer))
        (let ((next (cffi:inc-pointer cmsg (align-h (the (unsigned-byte 32) (cffi:foreign-slot-value cmsg '(:struct wsock:cmsghdr) 'wsock::len))))))
          (if (> (cffi:pointer-address (cffi:inc-pointer next (align-d (cffi:foreign-type-size '(:struct wsock:cmsghdr)))))
                 (cffi:pointer-address (cffi:inc-pointer wsock::control wsock::controllen)))
              (cffi:null-pointer)
              next)))))
(defun cmsg-data (cmsg)
  (declare (optimize (speed 3) (safety 0)))
  (cffi:inc-pointer cmsg (align-d (cffi:foreign-type-size '(:struct wsock:cmsghdr)))))

(defun parse-cmsg (level type data len)
  (cond
    ((and (= level wsock:+ipproto-ip+)
          (= type wsock:+ip-pktinfo+))
     (cffi:with-foreign-slots ((wsock::if-index wsock::spec-dst wsock::addr) data (:struct wsock::pktinfo))
       (list :iface-idx wsock::if-index :local-addr (wsock:inet-ntoa wsock::spec-dst) :dst-addr (wsock:inet-ntoa wsock::addr))))
    ((and (= level wsock:+ipproto-ip+)
          (= type wsock::+ip-recvorigdstaddr+))
     (cffi:with-foreign-slots ((wsock::family wsock::port wsock::addr) data (:struct wsock::sockaddr-in))
       (list :dst-family wsock::family :dst-port (swap-bytes:ntohs wsock::port) :dst-addr (wsock:inet-ntoa wsock::addr))))
    (t (list (intern (format nil "LEVEL-~a-TYPE-~a" level type) :keyword)
             (cffi:foreign-array-to-lisp data `(:array :unsigned-char ,len))))))

(defun get-cmsgs (msg)
  (loop for cmsg = (cmsg-next msg (cffi:null-pointer)) then (cmsg-next msg cmsg)
     until (cffi:null-pointer-p cmsg)
     append (cffi:with-foreign-slots ((wsock::level wsock::type wsock::len) cmsg (:struct wsock:cmsghdr))
              (parse-cmsg wsock::level wsock::type (cmsg-data cmsg)
                          (- wsock::len (align-d (cffi:foreign-type-size '(:struct wsock:cmsghdr))))))))

(defun get-name-aux (message)
  (multiple-value-bind (addr port)
      (get-name-port (cffi:foreign-slot-value message '(:struct wsock:msghdr) 'wsock::name))
    (append (list :src-addr addr :src-port port) (get-cmsgs message))))

(defun dump-message (message len)
  (cffi:with-foreign-slots ((wsock::name wsock::namelen wsock::iov wsock::control wsock::controllen)
                            message (:struct wsock:msghdr))
    (cffi:with-foreign-slots ((wsock::base wsock::len) wsock::iov (:struct wsock:iovec))
      (format t "~A ~A~%~A ~A~%~A ~A~%"
              wsock::namelen (cffi:foreign-array-to-lisp wsock::name `(:array :unsigned-char ,wsock::namelen))
              len (cffi:foreign-string-to-lisp wsock::base :count len)
              wsock::controllen (cffi:foreign-array-to-lisp wsock::control `(:array :unsigned-char ,wsock::controllen))))))

(define-c-callback udp-read-cb :void ((evloop :pointer) (watcher :pointer) (events :int))
  (declare (ignore evloop events))
  (let* ((fd (io-fd watcher))
         (read-cb (callbacks fd)))
    (setf (cffi:foreign-slot-value *udp-message* '(:struct wsock:msghdr) 'wsock::namelen) *udp-name-len*
          (cffi:foreign-slot-value *udp-message* '(:struct wsock:msghdr) 'wsock::controllen) *udp-control-len*)
    (let ((len (wsock:recvmsg fd *udp-message* 0)))
      (declare (type fixnum len))
      ;; (dump-message *udp-message* len)
      (if (= len -1)
          (let ((errno (wsys:errno)))
            (cond
              ;; Just to nothing
              ((or (= errno wsys:EWOULDBLOCK)
                   (= errno wsys:EINTR)
                   (= errno wsys:EAGAIN)))
              (t
               (vom:error "Unexpected error (Code: ~D)" errno))))
          (when read-cb
            (apply (the function read-cb) fd *udp-buffer* len (get-name-aux *udp-message*)))))))

(defun udp-server (address port read-cb &key fd (sockopt wsock:+SO-REUSEADDR+) multicast)
  (check-event-loop-running)
  (let ((fd (or fd (udp-socket address port :sockopt sockopt)))
        (listener (cffi:foreign-alloc '(:struct lev:ev-io))))
    (when (= (wsys:set-fd-nonblock fd t) -1)
      (error 'os-error
             :description "Cannot set fd nonblock"
             :code (wsys:errno)))
    #+linux (set-sock-int-opt fd wsock:+ipproto-ip+ wsock:+ip-pktinfo+)
    (loop for address in multicast
       do (join-multicast-group fd address))
    (setf (callbacks fd) read-cb)
    (lev:ev-io-init listener 'udp-read-cb fd lev:+EV-READ+)
    (lev:ev-io-start *evloop* listener)
    listener))

(defparameter +ssdp-multicast-group+ "239.255.255.250")
(defparameter +ssdp-port+ 1900)
(defvar *notify-ip-ttl* 4)
(defvar *ssdp-listener* nil)
(defvar *port* 50000)

;; Devices should wait a random interval less than 100 milliseconds before sending an initial set of advertisements in order to reduce the likelihood of network storms; this random interval should also be applied on occasions where the device obtains a new IP address or a new network interface is installed.
;; In addition, the device must re-send its advertisements periodically prior to expiration of the duration specified in the CACHE-CONTROL header; it is recommended that such refreshing of advertisements be done at a randomly-distributed interval of less than one-half of the advertisement expiration time, so as to provide the opportunity for recovery from lost advertisements before the advertisement expires, and to distribute over time the advertisement refreshment of multiple devices on the network in order to avoid spikes in network traffic

(defvar *root-uuid* "93cb34ca-4bf2-4bc4-ad2b-5a7d1e423e53")
(defvar *max-age* 1800)
(defvar *os-version* "Chad partners")
(defvar *product-version* #.(format nil "Chad Music/~A" (asdf:component-version
                                                         (asdf:find-system :dlna-chad-music))))
(defparameter +notification-subtype-alive+ "ssdp:alive")
(defparameter +notification-subtype-byebye+ "ssdp:byebye")
(defparameter +notify-cs+ "NOTIFY * HTTP/1.1~C~C~
HOST: ~A:~A~C~C~
CACHE-CONTROL: max-age=~A~C~C~
LOCATION: ~A~C~C~
NT: ~A~C~C~
NTS: ~A~C~C~
SERVER: ~A UPnP/1.0 ~A~C~C~
USN: uuid:~A~@[::~A~]~C~C~
~C~C")
(defparameter +upnp-root+ "upnp:rootdevice")
(defparameter +urn-media-server+ "urn:schemas-upnp-org:device:MediaServer:1")
(defun get-notify-message (location nst uuid &optional notify-type)
  (format nil +notify-cs+
          #\return #\linefeed
          +ssdp-multicast-group+ +ssdp-port+ #\return #\linefeed
          *max-age* #\return #\linefeed
          location #\return #\linefeed
          (or notify-type (format nil "uuid:~A" uuid)) #\return #\linefeed
          nst #\return #\linefeed
          *os-version* *product-version* #\return #\linefeed
          uuid notify-type #\return #\linefeed
          #\return #\linefeed))

(defun get-location (local-addr)
  (format nil "http://~A:~A" local-addr *port*))

(defun notify (fd local-addr)
  (let ((location (get-location local-addr)))
    (dolist (nt (list +upnp-root+ nil +urn-media-server+))
      (send-to fd +ssdp-multicast-group+ +ssdp-port+
               (get-notify-message location +notification-subtype-alive+ *root-uuid* nt)))))

(defun get-local-addrs ()
  (cffi:with-foreign-object (ifa '(:pointer (:pointer (:struct wsock::ifaddrs))))
    (when (= (wsock::getifaddrs ifa) -1)
      (error 'os-error
             :description "Error calling getifaddrs"
             :code (wsys:errno)))
    (let ((head (cffi:mem-ref ifa '(:pointer (:struct wsock::ifaddrs)))))
      (unwind-protect
           (loop for ifaddr = head then (cffi:foreign-slot-value ifaddr '(:struct wsock::ifaddrs) 'wsock::next)
              until (cffi:null-pointer-p ifaddr)
              for addr = (cffi:foreign-slot-value ifaddr '(:struct wsock::ifaddrs) 'wsock::addr)
              unless (cffi:null-pointer-p addr)
              when (= (cffi:foreign-slot-value addr '(:struct wsock::sockaddr) 'wsock::family)
                      wsock:+af-inet+)
              collect (cons (cffi:foreign-slot-value ifaddr '(:struct wsock::ifaddrs) 'wsock::name)
                            (wsock:inet-ntoa (cffi:foreign-slot-value addr '(:struct wsock::sockaddr-in) 'wsock::addr))))
        (wsock::freeifaddrs head)))))

(defun make-notify-sockets (&optional addrs)
  (loop for local-addr in (etypecase addrs
                            (null (mapcar 'cdr (get-local-addrs)))
                            (string (list addrs))
                            (list addrs))
     for fd = (udp-socket local-addr nil)
     do (set-sock-int-opt fd wsock:+ipproto-ip+ wsock::+ip-multicast-ttl+ *notify-ip-ttl*)
     collect (list fd local-addr)))

(defvar *ssdp-app* (lambda (env) (declare (ignore env))))
(defun ssdp-read-cb (fd buffer length &rest socket-info)
  (declare (ignorable fd))
  (let* ((ssdp (fast-http:make-http-request))
         (parser (fast-http:make-parser
                  ssdp
                  :finish-callback
                  (lambda ()
                    (let ((env (make-ssdp-env ssdp socket-info)))
                      (handle-ssdp-response fd env (funcall *ssdp-app* env)))))))
    (funcall parser buffer :start 0 :end length)))

(defun make-ssdp-env (ssdp socket-info)
  (let* ((headers (fast-http:http-headers ssdp))
         (host (gethash "host" headers))
         (uri (fast-http:http-resource ssdp)))
    (declare (type simple-string uri))
    (multiple-value-bind (scheme userinfo hostname port path query fragment)
        (quri:parse-uri uri)
      (declare (ignore scheme userinfo hostname port fragment))
      (multiple-value-bind (server-name server-port)
          (if (stringp host)
              (woo::parse-host-header host)
              (values nil nil))
        (nconc
         (list :request-method (fast-http:http-method ssdp)
               :server-name server-name
               :server-port (or server-port 1900)
               :server-protocol (woo::http-version-keyword (woo::http-major-version ssdp)
                                                           (woo::http-minor-version ssdp))
               :path-info (and path (quri:url-decode path :lenient t))
               :query-string query
               :url-scheme "httpu"
               :remote-addr (getf socket-info :src-addr)
               :remote-port (getf socket-info :src-port)
               :request-uri uri
               :content-length (let ((content-length (gethash "content-length" headers)))
                                 (etypecase content-length
                                   (string (parse-integer content-length :junk-allowed t))
                                   (integer content-length)
                                   (null nil)))
               :content-type (gethash "content-type" headers)
               :headers headers)
         socket-info)))))

(defun handle-ssdp-response (fd env response)
  (when response
    (etypecase response
      (function (funcall response (lambda (res) (handle-ssdp-response fd env res))))
      (string (send-to fd (getf env :src-addr) (getf env :src-port) response)))))

(defparameter +search-result-cs+ "HTTP/1.1 200 OK~C~C~
CACHE-CONTROL: max-age=~A~C~C~
DATE: ~A~C~C~
EXT: ~C~C~
LOCATION: ~A~C~C~
SERVER: ~A UPnP/1.0 ~A~C~C~
ST: ~A~C~C~
USN: uuid:~A~@[::~A~]~C~C~
~C~C")
(defun get-search-result-message (date location uuid &optional search-type)
  (format nil +search-result-cs+
          #\return #\linefeed
          *max-age* #\return #\linefeed
          date #\return #\linefeed
          #\return #\linefeed
          location #\return #\linefeed
          *os-version* *product-version* #\return #\linefeed
          (or search-type (format nil "uuid:~A" uuid)) #\return #\linefeed
          uuid search-type #\return #\linefeed
          #\return #\linefeed))
(defun search-result (local-addr st)
  (get-search-result-message
   (woo.response::current-rfc-1123-timestamp)
   (get-location local-addr)
   *root-uuid* st))

(defparameter +ssdp-all+ "ssdp:all")
(defparameter +upnp-media-server+ "urn:schemas-upnp-org:device:MediaServer:1")
(defparameter +valid-sts+ (list +ssdp-all+ +upnp-root+ +upnp-media-server+))
(defun valid-st (st)
  (member st +valid-sts+ :test 'string-equal))

(defparameter +timeout-thunks+ (make-hash-table))
(define-c-callback with-timeout-cb :void ((evloop :pointer) (timer :pointer) (events :int))
  (declare (ignore evloop events))
  (let ((addr (cffi:pointer-address timer)))
    (funcall (gethash addr +timeout-thunks+))
    (remhash addr +timeout-thunks+)
    (cffi:foreign-free timer)))
(defmacro with-timeout (timeout &body body)
  (with-gensyms (timer)
    `(let ((,timer (cffi:foreign-alloc '(:struct lev:ev-timer))))
       (setf (gethash (cffi:pointer-address ,timer) +timeout-thunks+) (lambda () ,@body))
       (lev:ev-timer-init ,timer 'with-timeout-cb (coerce ,timeout 'double-float) 0.0d0)
       (lev:ev-timer-start *evloop* ,timer))))

(defparameter +retry-thunks+ (make-hash-table))
(define-c-callback with-retry-cb :void ((evloop :pointer) (timer :pointer) (events :int))
  (declare (ignore evloop events))
  (let ((addr (cffi:pointer-address timer)))
    (funcall (gethash addr +retry-thunks+))))
(defmacro with-retry ((retry thunk) &body body)
  (with-gensyms (timer)
    `(let ((,timer (cffi:foreign-alloc '(:struct lev:ev-timer))))
       (setf (gethash (cffi:pointer-address ,timer) +retry-thunks+) ,thunk)
       (lev:ev-timer-init ,timer 'with-retry-cb 0.0d0 (coerce ,retry 'double-float))
       (lev:ev-timer-again *evloop* ,timer)
       ,@body)))


(defparameter +man-ssdp-discover+ "\"ssdp:discover\"")
(defun ssdp-app (env)
  (let* ((headers (getf env :headers))
         (local-addr (getf env :local-addr))
         (mx (gethash "mx" headers))
         (st (gethash "st" headers)))
    (when (and (equal (getf env :request-method) :m-search)
               (string-equal (gethash "man" headers) +man-ssdp-discover+)
               (typep mx 'integer)
               (valid-st st))
      (lambda (handle-response)
        (with-timeout (random (coerce (min mx 120) 'float))
          (funcall handle-response (search-result local-addr st)))))))


(defun start-ssdp-server (ssdp-app &key address (port 1900) fd (mcast (list +ssdp-multicast-group+)))
  (let ((*ssdp-app* ssdp-app))
    (with-udp-buffers
      (with-event-loop ()
        (let ((notify-sockets (make-notify-sockets)))
          (with-retry (5 #'(lambda () (loop for args in notify-sockets do (apply 'notify args))))
            (setf *ssdp-listener*
                  (udp-server address port
                              #'ssdp-read-cb
                              :fd fd
                              :sockopt wsock:+SO-REUSEADDR+
                              :multicast mcast))))))))

(defun 200-xml (data)
  (declare (optimize (speed 3) (safety 0))
           (type string data))
  `(200 (:content-type "text/xml; charset=\"utf-8\""
                       "EXT" "")
        ,(trivial-utf-8:string-to-utf-8-bytes data)))


(defparameter +root-desc+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<root configId=\"926238\" xmlns=\"urn:schemas-upnp-org:device-1-0\" xmlns:dlna=\"urn:schemas-dlna-org:device-1-0\">
  <specVersion>
    <major>1</major>
    <minor>1</minor>
  </specVersion>
  <device>
    <deviceType>urn:schemas-upnp-org:device:MediaServer:1</deviceType>
    <friendlyName>Chad-Music</friendlyName>
    <manufacturer>Microsoft Corporation</manufacturer>
    <manufacturerURL>http://kodi.tv/</manufacturerURL>
    <modelDescription>Chad music</modelDescription>
    <modelName>chad-dlna</modelName>
    <modelNumber>18.2 Git:18.2-Leia</modelNumber>
    <modelURL>http://kodi.tv/</modelURL>
    <UDN>uuid:93cb34ca-4bf2-4bc4-ad2b-5a7d1e423e53</UDN>
    <presentationURL>http://192.168.1.50/</presentationURL>
    <dlna:X_DLNADOC xmlns:dlna=\"urn:schemas-dlna-org:device-1-0\">DMS-1.50</dlna:X_DLNADOC>
    <iconList>
      <icon>
        <mimetype>image/png</mimetype>
        <width>256</width>
        <height>256</height>
        <depth>8</depth>
        <url>/logo-256.png</url>
      </icon>
    </iconList>
    <serviceList>
      <service>
        <serviceType>urn:microsoft.com:service:X_MS_MediaReceiverRegistrar:1</serviceType>
        <serviceId>urn:microsoft.com:serviceId:X_MS_MediaReceiverRegistrar</serviceId>
        <SCPDURL>/X_MS_MediaReceiverRegistrar/scpd.xml</SCPDURL>
        <controlURL>/X_MS_MediaReceiverRegistrar/control.xml</controlURL>
        <eventSubURL>/X_MS_MediaReceiverRegistrar/event.xml</eventSubURL>
      </service>
      <service>
        <serviceType>urn:schemas-upnp-org:service:ContentDirectory:1</serviceType>
        <serviceId>urn:upnp-org:serviceId:ContentDirectory</serviceId>
        <SCPDURL>/ContentDirectory/scpd.xml</SCPDURL>
        <controlURL>/ContentDirectory/control.xml</controlURL>
        <eventSubURL>/ContentDirectory/event.xml</eventSubURL>
      </service>
      <service>
        <serviceType>urn:schemas-upnp-org:service:ConnectionManager:1</serviceType>
        <serviceId>urn:upnp-org:serviceId:ConnectionManager</serviceId>
        <SCPDURL>/ConnectionManager/scpd.xml</SCPDURL>
        <controlURL>/ConnectionManager/control.xml</controlURL>
        <eventSubURL>/ConnectionManager/event.xml</eventSubURL>
      </service>
    </serviceList>
  </device>
</root>
")
(defun root-desc (params)
  (declare (ignore params))
  (200-xml +root-desc+))

(defparameter +rec-reg-scpd+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\">
  <specVersion>
    <major>1</major>
    <minor>0</minor>
  </specVersion>
  <actionList>
    <action>
      <name>IsAuthorized</name>
      <argumentList>
        <argument>
          <name>DeviceID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_DeviceID</relatedStateVariable>
        </argument>
        <argument>
          <name>Result</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Result</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>RegisterDevice</name>
      <argumentList>
        <argument>
          <name>RegistrationReqMsg</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_RegistrationReqMsg</relatedStateVariable>
        </argument>
        <argument>
          <name>RegistrationRespMsg</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_RegistrationRespMsg</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>IsValidated</name>
      <argumentList>
        <argument>
          <name>DeviceID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_DeviceID</relatedStateVariable>
        </argument>
        <argument>
          <name>Result</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Result</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
  </actionList>
  <serviceStateTable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_DeviceID</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Result</name>
      <dataType>int</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_RegistrationReqMsg</name>
      <dataType>bin.base64</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_RegistrationRespMsg</name>
      <dataType>bin.base64</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>AuthorizationGrantedUpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>AuthorizationDeniedUpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>ValidationSucceededUpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>ValidationRevokedUpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
  </serviceStateTable>
")

(defparameter +rec-reg-control+ "")
(defparameter +rec-reg-event+ "")

(defparameter +cont-dir-scpd+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\">
  <specVersion>
    <major>1</major>
    <minor>0</minor>
  </specVersion>
  <actionList>
    <action>
      <name>Browse</name>
      <argumentList>
        <argument>
          <name>ObjectID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_ObjectID</relatedStateVariable>
        </argument>
        <argument>
          <name>BrowseFlag</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_BrowseFlag</relatedStateVariable>
        </argument>
        <argument>
          <name>Filter</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Filter</relatedStateVariable>
        </argument>
        <argument>
          <name>StartingIndex</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Index</relatedStateVariable>
        </argument>
        <argument>
          <name>RequestedCount</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>SortCriteria</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_SortCriteria</relatedStateVariable>
        </argument>
        <argument>
          <name>Result</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Result</relatedStateVariable>
        </argument>
        <argument>
          <name>NumberReturned</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>TotalMatches</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>UpdateID</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_UpdateID</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>GetSortCapabilities</name>
      <argumentList>
        <argument>
          <name>SortCaps</name>
          <direction>out</direction>
          <relatedStateVariable>SortCapabilities</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>GetSystemUpdateID</name>
      <argumentList>
        <argument>
          <name>Id</name>
          <direction>out</direction>
          <relatedStateVariable>SystemUpdateID</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>GetSearchCapabilities</name>
      <argumentList>
        <argument>
          <name>SearchCaps</name>
          <direction>out</direction>
          <relatedStateVariable>SearchCapabilities</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>Search</name>
      <argumentList>
        <argument>
          <name>ContainerID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_ObjectID</relatedStateVariable>
        </argument>
        <argument>
          <name>SearchCriteria</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_SearchCriteria</relatedStateVariable>
        </argument>
        <argument>
          <name>Filter</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Filter</relatedStateVariable>
        </argument>
        <argument>
          <name>StartingIndex</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Index</relatedStateVariable>
        </argument>
        <argument>
          <name>RequestedCount</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>SortCriteria</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_SortCriteria</relatedStateVariable>
        </argument>
        <argument>
          <name>Result</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Result</relatedStateVariable>
        </argument>
        <argument>
          <name>NumberReturned</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>TotalMatches</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Count</relatedStateVariable>
        </argument>
        <argument>
          <name>UpdateID</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_UpdateID</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>UpdateObject</name>
      <argumentList>
        <argument>
          <name>ObjectID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_ObjectID</relatedStateVariable>
        </argument>
        <argument>
          <name>CurrentTagValue</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_TagValueList</relatedStateVariable>
        </argument>
        <argument>
          <name>NewTagValue</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_TagValueList</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
  </actionList>
  <serviceStateTable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_BrowseFlag</name>
      <dataType>string</dataType>
      <allowedValueList>
        <allowedValue>BrowseMetadata</allowedValue>
        <allowedValue>BrowseDirectChildren</allowedValue>
      </allowedValueList>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>ContainerUpdateIDs</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>SystemUpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Count</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_SortCriteria</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_SearchCriteria</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>SortCapabilities</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Index</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_ObjectID</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_UpdateID</name>
      <dataType>ui4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Result</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>SearchCapabilities</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Filter</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_TagValueList</name>
      <dataType>string</dataType>
    </stateVariable>
  </serviceStateTable>
</scpd>")

(defparameter +conn-man-scpd+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\">
  <specVersion>
    <major>1</major>
    <minor>0</minor>
  </specVersion>
  <actionList>
    <action>
      <name>GetCurrentConnectionInfo</name>
      <argumentList>
        <argument>
          <name>ConnectionID</name>
          <direction>in</direction>
          <relatedStateVariable>A_ARG_TYPE_ConnectionID</relatedStateVariable>
        </argument>
        <argument>
          <name>RcsID</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_RcsID</relatedStateVariable>
        </argument>
        <argument>
          <name>AVTransportID</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_AVTransportID</relatedStateVariable>
        </argument>
        <argument>
          <name>ProtocolInfo</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_ProtocolInfo</relatedStateVariable>
        </argument>
        <argument>
          <name>PeerConnectionManager</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_ConnectionManager</relatedStateVariable>
        </argument>
        <argument>
          <name>PeerConnectionID</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_ConnectionID</relatedStateVariable>
        </argument>
        <argument>
          <name>Direction</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_Direction</relatedStateVariable>
        </argument>
        <argument>
          <name>Status</name>
          <direction>out</direction>
          <relatedStateVariable>A_ARG_TYPE_ConnectionStatus</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>GetProtocolInfo</name>
      <argumentList>
        <argument>
          <name>Source</name>
          <direction>out</direction>
          <relatedStateVariable>SourceProtocolInfo</relatedStateVariable>
        </argument>
        <argument>
          <name>Sink</name>
          <direction>out</direction>
          <relatedStateVariable>SinkProtocolInfo</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
    <action>
      <name>GetCurrentConnectionIDs</name>
      <argumentList>
        <argument>
          <name>ConnectionIDs</name>
          <direction>out</direction>
          <relatedStateVariable>CurrentConnectionIDs</relatedStateVariable>
        </argument>
      </argumentList>
    </action>
  </actionList>
  <serviceStateTable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_ProtocolInfo</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_ConnectionStatus</name>
      <dataType>string</dataType>
      <allowedValueList>
        <allowedValue>OK</allowedValue>
        <allowedValue>ContentFormatMismatch</allowedValue>
        <allowedValue>InsufficientBandwidth</allowedValue>
        <allowedValue>UnreliableChannel</allowedValue>
        <allowedValue>Unknown</allowedValue>
      </allowedValueList>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_AVTransportID</name>
      <dataType>i4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_RcsID</name>
      <dataType>i4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_ConnectionID</name>
      <dataType>i4</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_ConnectionManager</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>SourceProtocolInfo</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>SinkProtocolInfo</name>
      <dataType>string</dataType>
    </stateVariable>
    <stateVariable sendEvents=\"no\">
      <name>A_ARG_TYPE_Direction</name>
      <dataType>string</dataType>
      <allowedValueList>
        <allowedValue>Input</allowedValue>
        <allowedValue>Output</allowedValue>
      </allowedValueList>
    </stateVariable>
    <stateVariable sendEvents=\"yes\">
      <name>CurrentConnectionIDs</name>
      <dataType>string</dataType>
    </stateVariable>
  </serviceStateTable>
</scpd>")

(defmacro static-xml (content)
  ``(200 (:content-type "text/xml; charset=\"utf-8\"") ,,(trivial-utf-8:string-to-utf-8-bytes (eval content))))

(defun catch-all (params)
  (declare (ignore params))
  (print myway:*env*)
  '(404 nil nil))

(defparameter +400+ '(400 nil #.(trivial-utf-8:string-to-utf-8-bytes "400")))
(defparameter +404+ '(404 nil #.(trivial-utf-8:string-to-utf-8-bytes "404")))
(defparameter +200+ '(200 nil #.(trivial-utf-8:string-to-utf-8-bytes "OK")))

(defparameter *mapper* (myway:make-mapper))
;;(myway:connect *mapper* "/:entity/:id" 'post-entity :method :post)
;;(myway:connect *mapper* "/:entity/:id" 'get-entity)
;;(myway:connect *mapper* "/users/:id/visits" 'user-visits)
;;(myway:connect *mapper* "/locations/:id/avg" 'location-avg-mark)
(myway:connect *mapper* "/logo-256.png" `(200 (:content-type "image/png") ,(pathname "logo-256.png")))
(myway:connect *mapper* "/X_MS_MediaReceiverRegistrar/scpd.xml" (static-xml +rec-reg-scpd+))
(myway:connect *mapper* "/X_MS_MediaReceiverRegistrar/control.xml" (static-xml +rec-reg-control+))
(myway:connect *mapper* "/X_MS_MediaReceiverRegistrar/event.xml" +200+ :method :subscribe)
(myway:connect *mapper* "/ContentDirectory/scpd.xml" (static-xml +cont-dir-scpd+))
(myway:connect *mapper* "/ContentDirectory/control.xml" (static-xml +cont-dir-control+))
(myway:connect *mapper* "/ContentDirectory/event.xml" +200+ :method :subscribe)
(myway:connect *mapper* "/ConnectionManager/scpd.xml" (static-xml +conn-man-scpd+))
(myway:connect *mapper* "/ConnectionManager/control.xml" (static-xml +conn-man-scpd+) :method :post)
(myway:connect *mapper* "/ConnectionManager/event.xml" +200+ :method :subscribe)
(myway:connect *mapper* "/" (static-xml +root-desc+))
(myway:connect *mapper* "*" 'catch-all :method :post)
(myway:connect *mapper* "*" 'catch-all :method :subscribe)
(myway:connect *mapper* "*" 'catch-all)
(myway:connect *mapper* "*" (lambda (p) (declare (ignore p)) +404+))

(defun start (&key addrs)
  (let ((*ssdp-app* 'ssdp-app)
        (notify-sockets (make-notify-sockets addrs)))
    (with-udp-buffers
      (labels ((init-ssdp ()
                 (with-retry (60 #'(lambda () (loop for args in notify-sockets do (apply 'notify args))))
                   (setf *ssdp-listener*
                         (udp-server nil +ssdp-port+
                                     #'ssdp-read-cb
                                     :sockopt wsock:+SO-REUSEADDR+
                                     :multicast (list +ssdp-multicast-group+))))))
        (woo:run (myway:to-app *mapper*) :port *port* :address nil :init-fn #'init-ssdp)))))