Initial import

private/model.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+
+;; Internal data structures shared by the UPnP modules.  Constructors are
+;; intentionally kept out of the public interface; users receive these values
+;; through discovery and description functions.
+
+(provide (struct-out upnp-service)
+         (struct-out upnp-device))
+
+(struct upnp-service
+  (service-type
+   service-id
+   scpd-url
+   control-url
+   event-sub-url)
+  #:transparent)
+
+(struct upnp-device
+  (udn
+   device-type
+   friendly-name
+   manufacturer
+   model-name
+   model-number
+   serial-number
+   location
+   address
+   dns-name
+   services
+   embedded-devices
+   properties)
+  #:transparent)

private/xml.rkt

@@ -0,0 +1,119 @@
+#lang racket/base
+
+;; Small namespace-insensitive helpers for Racket x-expressions.
+;; UPnP documents use default namespaces and SOAP commonly uses prefixes, so
+;; matching by local element or attribute name keeps parsers independent of
+;; namespace prefixes.
+
+(require racket/list
+         racket/string)
+
+(provide xexpr-element?
+         xexpr-local-name
+         xexpr-attributes
+         xexpr-attribute
+         xexpr-children
+         xexpr-child-elements
+         xexpr-child-element
+         xexpr-text
+         xexpr-child-text
+         xexpr-find-descendant)
+
+(define (xexpr-element? value)
+  (and (pair? value)
+       (symbol? (car value))))
+
+(define (xexpr-attribute-list? value)
+  (and (list? value)
+       (andmap
+        (lambda (attribute)
+          (and (list? attribute)
+               (= (length attribute) 2)
+               (symbol? (car attribute))
+               (string? (cadr attribute))))
+        value)))
+
+(define (xexpr-local-name value)
+  (let* ([name (if (symbol? value) (symbol->string value) value)]
+         [parts (and (string? name) (string-split name ":"))])
+    (and parts
+         (string-downcase (last parts)))))
+
+(define (xexpr-attributes value)
+  (if (not (xexpr-element? value))
+      '()
+      (let ([rest (cdr value)])
+        (if (and (pair? rest)
+                 (xexpr-attribute-list? (car rest)))
+            (car rest)
+            '()))))
+
+(define (xexpr-attribute value name [default #f])
+  (let* ([wanted (xexpr-local-name name)]
+         [attribute
+          (findf
+           (lambda (candidate)
+             (string=? (xexpr-local-name (car candidate)) wanted))
+           (xexpr-attributes value))])
+    (if attribute
+        (cadr attribute)
+        default)))
+
+(define (xexpr-children value)
+  (if (not (xexpr-element? value))
+      '()
+      (let ([rest (cdr value)])
+        (cond
+          [(null? rest) '()]
+          [(xexpr-attribute-list? (car rest)) (cdr rest)]
+          [else rest]))))
+
+(define (xexpr-named-element? value name)
+  (and (xexpr-element? value)
+       (string=? (xexpr-local-name (car value))
+                 (string-downcase name))))
+
+(define (xexpr-child-elements value name)
+  (for/list ([child (in-list (xexpr-children value))]
+             #:when (xexpr-named-element? child name))
+    child))
+
+(define (xexpr-child-element value name [default #f])
+  (let ([elements (xexpr-child-elements value name)])
+    (if (pair? elements)
+        (car elements)
+        default)))
+
+(define (xexpr-content-text value)
+  (cond
+    [(string? value) value]
+    [(xexpr-element? value)
+     (apply string-append
+            (map xexpr-content-text (xexpr-children value)))]
+    [else ""]))
+
+(define (xexpr-text value [default #f])
+  (let ([text (string-trim (xexpr-content-text value))])
+    (if (string=? text "")
+        default
+        text)))
+
+(define (xexpr-child-text value name [default #f])
+  (let ([child (xexpr-child-element value name #f)])
+    (if child
+        (xexpr-text child default)
+        default)))
+
+(define (xexpr-find-descendant value name [default #f])
+  (cond
+    [(xexpr-named-element? value name) value]
+    [(xexpr-element? value)
+     (let loop ([children (xexpr-children value)])
+       (cond
+         [(null? children) default]
+         [else
+          (let ([result (xexpr-find-descendant (car children) name #f)])
+            (if result
+                result
+                (loop (cdr children))))]))]
+    [else default]))