racket-upnp/resource-capabilities.rkt

#lang racket/base

;; Resolve DLNA resource capabilities advertised by an HTTP media server.

(require net/http-client
         net/url
         racket/match
         racket/port
         racket/string
         simple-log)

(provide resolve-dlna-resource-protocol-info
         clear-dlna-resource-capability-cache!)

(sl-def-log upnp-resource)

(define capability-cache (make-hash))
(define capability-cache-lock (make-semaphore 1))

(define (clear-dlna-resource-capability-cache!)
  (call-with-semaphore
   capability-cache-lock
   (lambda () (hash-clear! capability-cache))))

(define (url-request-target value)
  (let* ([relative
          (struct-copy url value
                       [scheme #f]
                       [user #f]
                       [host #f]
                       [port #f]
                       [fragment #f])]
         [target (url->string relative)])
    (if (string=? target "") "/" target)))

(define (header-value headers name)
  (for/or ([header (in-list headers)])
    (let* ([text
            (if (bytes? header)
                (bytes->string/latin-1 header)
                header)]
           [match
            (and (string? text)
                 (regexp-match
                  #px"^([^:]+):[ \t]*(.*?)[ \t]*$"
                  text))])
      (and match
           (string-ci=? (cadr match) name)
           (caddr match)))))

(define (protocol-info-parts protocol-info)
  (and protocol-info
       (regexp-match #px"^([^:]*):([^:]*):([^:]*):(.*)$"
                     protocol-info)))

(define (protocol-info-additional-info protocol-info)
  (let ([parts (protocol-info-parts protocol-info)])
    (and parts (list-ref parts 4))))

(define (replace-additional-info protocol-info additional-info)
  (match (protocol-info-parts protocol-info)
    [(list _ protocol network content-type _)
     (string-join
      (list protocol network content-type additional-info)
      ":")]
    [_ protocol-info]))

(define (call-with-timeout seconds thunk)
  (let ([custodian (make-custodian)]
        [result-channel (make-channel)])
    (parameterize ([current-custodian custodian])
      (thread
       (lambda ()
         (with-handlers
             ([exn:fail?
               (lambda (exception)
                 (channel-put result-channel
                              (cons #f exception)))])
           (channel-put result-channel
                        (cons #t (thunk)))))))
    (let ([result (sync/timeout seconds result-channel)])
      (custodian-shutdown-all custodian)
      (cond
        [(not result)
         (error 'resolve-dlna-resource-protocol-info
                "HTTP capability request timed out")]
        [(car result) (cdr result)]
        [else (raise (cdr result))]))))

(define (request-content-features uri timeout)
  (let* ([url-value (string->url uri)]
         [scheme (or (url-scheme url-value) "http")]
         [ssl? (string-ci=? scheme "https")]
         [host (url-host url-value)]
         [port (or (url-port url-value) (if ssl? 443 80))])
    (unless (and host
                 (or (string-ci=? scheme "http")
                     (string-ci=? scheme "https")))
      (raise-arguments-error
       'resolve-dlna-resource-protocol-info
       "resource is not an HTTP URI"
       "uri" uri))
    (call-with-timeout
     timeout
     (lambda ()
       (let-values ([(status headers in)
                     (http-sendrecv
                      host
                      (url-request-target url-value)
                      #:ssl? ssl?
                      #:port port
                      #:method #"HEAD"
                      #:headers
                      (list "getcontentFeatures.dlna.org: 1"
                            "transferMode.dlna.org: Streaming"
                            "Connection: close"))])
         (void status)
         (close-input-port in)
         (header-value headers "contentFeatures.dlna.org"))))))

(define (base-protocol-info protocol-info mime-type)
  (cond
    [(and (string? protocol-info)
          (not (string=? (string-trim protocol-info) "")))
     protocol-info]
    [(and (string? mime-type)
          (not (string=? (string-trim mime-type) "")))
     (format "http-get:*:~a:*" mime-type)]
    [else "http-get:*:application/octet-stream:*"]))

(define (resolve-dlna-resource-protocol-info
         uri
         #:protocol-info [protocol-info #f]
         #:mime-type [mime-type #f]
         #:timeout [timeout 5.0])
  (unless (and (string? uri)
               (not (string=? (string-trim uri) "")))
    (raise-argument-error
     'resolve-dlna-resource-protocol-info
     "non-empty-string?"
     uri))
  (for ([value (in-list (list protocol-info mime-type))])
    (unless (or (not value) (string? value))
      (raise-argument-error
       'resolve-dlna-resource-protocol-info
       "(or/c #f string?)"
       value)))
  (unless (and (rational? timeout) (positive? timeout))
    (raise-argument-error
     'resolve-dlna-resource-protocol-info
     "positive-real?"
     timeout))
  (let* ([base (base-protocol-info protocol-info mime-type)]
         [additional-info (protocol-info-additional-info base)])
    (cond
      [(and additional-info
            (not (string=? additional-info "*")))
       base]
      [else
       (let* ([key (list uri base)]
              [cached
               (call-with-semaphore
                capability-cache-lock
                (lambda () (hash-ref capability-cache key #f)))])
         (or cached
             (with-handlers
                 ([exn:fail?
                   (lambda (exception)
                     (warn-upnp-resource
                      "Could not resolve DLNA capabilities for ~a: ~a"
                      uri
                      (exn-message exception))
                     base)])
               (let ([content-features
                      (request-content-features uri timeout)])
                 (if (and content-features
                          (not (string=? content-features "")))
                     (let ([resolved
                            (replace-additional-info
                             base
                             content-features)])
                       (dbg-upnp-resource
                        "Resolved DLNA protocolInfo for ~a: ~a"
                        uri
                        resolved)
                       (call-with-semaphore
                        capability-cache-lock
                        (lambda ()
                          (hash-set! capability-cache key resolved)))
                       resolved)
                     base)))))])))

(module+ test
  (require rackunit)

  (check-equal?
   (replace-additional-info
    "http-get:*:audio/flac:*"
    "DLNA.ORG_OP=01;DLNA.ORG_CI=0")
   "http-get:*:audio/flac:DLNA.ORG_OP=01;DLNA.ORG_CI=0"))