#lang racket/base

;; High-level browser for UPnP/DLNA MediaServer devices.
;;
;; ContentDirectory returns DIDL-Lite XML.  This module turns that XML into
;; ordinary containers, items and resources, while leaving the raw
;; ContentDirectory module available for applications that need exact paging
;; information or vendor-specific fields.

(require net/url
         racket/list
         racket/port
         racket/string
         xml
         "device.rkt"
         "private/model.rkt"
         "private/xml.rkt"
         "query.rkt"
         "services/content-directory.rkt")

(provide query-media-servers
         media-server?
         media-server-root
         media-server-browse
         media-container-children
         media-server-name
         media-server-address
         media-server-manufacturer
         media-server-model
         get-media-server 

         media-entry?
         media-entry-id
         media-entry-parent-id
         media-entry-title
         media-entry-class
         media-entry-restricted?

         media-container?
         media-container-child-count
         media-container-searchable?

         media-item?
         media-item-creator
         media-item-artists
         media-item-album
         media-item-genres
         media-item-date
         media-item-album-art-uri
         media-item-resources

         media-resource?
         media-resource-uri
         media-resource-protocol-info
         media-resource-content-type
         media-resource-size
         media-resource-duration
         media-resource-bitrate
         media-resource-sample-frequency
         media-resource-bits-per-sample
         media-resource-channels
         media-resource-resolution)

(struct media-entry
  (id parent-id title class restricted?)
  #:transparent
  #:constructor-name make-media-entry)

(struct media-container media-entry
  (child-count searchable?)
  #:transparent
  #:constructor-name make-media-container)

(struct media-item media-entry
  (creator artists album genres date album-art-uri resources)
  #:transparent
  #:constructor-name make-media-item)

(struct media-resource
  (uri
   protocol-info
   content-type
   size
   duration
   bitrate
   sample-frequency
   bits-per-sample
   channels
   resolution)
  #:transparent
  #:constructor-name make-media-resource)

(define (get-media-server filter-name)
  (let ((fnm (string-downcase (string-trim filter-name))))
    (let ((ms (filter (λ (x)
                        (let ((nm (string-downcase (media-server-name x))))
                          ;(displayln (format "string-contains? '~a' '~a' = ~a" nm fnm (string-contains? nm fnm)))
                          (string-contains? nm fnm)))
                      (query-media-servers))))
      (if (null? ms)
          #f
          (car ms)))))

(define (media-server? value)
  (and (upnp-device? value)
       (eq? (upnp-device-kind value) 'media-server)
       (content-directory? (device-content-directory value))))

(define (media-server-name v)
  (and (media-server? v) (upnp-device-name v)))

(define (media-server-address v)
  (and (media-server? v) (upnp-device-address v)))

(define (media-server-manufacturer v)
  (and (media-server? v) (upnp-device-manufacturer v)))

(define (media-server-model v)
  (and (media-server? v) (upnp-device-model v)))

(define (check-media-server who value)
  (unless (media-server? value)
    (raise-argument-error who "media-server?" value)))

(define (query-media-servers #:interface [interface #f]
                             #:dns? [dns? #f])
  (filter media-server?
          (query-upnp-devices 'media-server
                              #:interface interface
                              #:dns? dns?)))

(define (string->boolean value)
  (and value
       (or (string=? value "1")
           (string-ci=? value "true")
           (string-ci=? value "yes"))))

(define (string->integer value)
  (and value
       (let ([number (string->number value)])
         (and (exact-integer? number) number))))

(define (duration->seconds value)
  (and value
       (let ([match
              (regexp-match
               #px"^([0-9]+):([0-9]{2}):([0-9]{2}(?:[.][0-9]+)?)$"
               value)])
         (and match
              (+ (* 3600 (string->number (cadr match)))
                 (* 60 (string->number (caddr match)))
                 (string->number (cadddr match)))))))

(define (content-type-from-protocol-info value)
  (and value
       (let ([match (regexp-match #px"^[^:]*:[^:]*:([^:]*):" value)])
         (and match
              (not (string=? (cadr match) "*"))
              (cadr match)))))

(define (absolute-uri base value)
  (and value
       (with-handlers ([exn:fail? (lambda (_) value)])
         (url->string
          (combine-url/relative (string->url base) value)))))

(define (child-texts value name)
  (filter-map
   (lambda (child)
     (xexpr-text child #f))
   (xexpr-child-elements value name)))

(define (parse-resource value base-url)
  (let* ([uri (absolute-uri base-url (xexpr-text value #f))]
         [protocol-info (xexpr-attribute value "protocolInfo" #f)])
    (and uri
         (make-media-resource
          uri
          protocol-info
          (content-type-from-protocol-info protocol-info)
          (string->integer (xexpr-attribute value "size" #f))
          (duration->seconds (xexpr-attribute value "duration" #f))
          (string->integer (xexpr-attribute value "bitrate" #f))
          (string->integer (xexpr-attribute value "sampleFrequency" #f))
          (string->integer (xexpr-attribute value "bitsPerSample" #f))
          (string->integer (xexpr-attribute value "nrAudioChannels" #f))
          (xexpr-attribute value "resolution" #f)))))

(define (parse-container value)
  (make-media-container
   (xexpr-attribute value "id" #f)
   (xexpr-attribute value "parentID" #f)
   (or (xexpr-child-text value "title" #f) "")
   (xexpr-child-text value "class" #f)
   (string->boolean (xexpr-attribute value "restricted" #f))
   (string->integer (xexpr-attribute value "childCount" #f))
   (string->boolean (xexpr-attribute value "searchable" #f))))

(define (parse-item value base-url)
  (make-media-item
   (xexpr-attribute value "id" #f)
   (xexpr-attribute value "parentID" #f)
   (or (xexpr-child-text value "title" #f) "")
   (xexpr-child-text value "class" #f)
   (string->boolean (xexpr-attribute value "restricted" #f))
   (xexpr-child-text value "creator" #f)
   (child-texts value "artist")
   (xexpr-child-text value "album" #f)
   (child-texts value "genre")
   (xexpr-child-text value "date" #f)
   (absolute-uri base-url (xexpr-child-text value "albumArtURI" #f))
   (filter-map
    (lambda (resource)
      (parse-resource resource base-url))
    (xexpr-child-elements value "res"))))

(define (parse-entry value base-url)
  (cond
    [(string=? (xexpr-local-name (car value)) "container")
     (parse-container value)]
    [(string=? (xexpr-local-name (car value)) "item")
     (parse-item value base-url)]
    [else #f]))

(define (parse-didl-lite content base-url)
  (if (string=? (string-trim content) "")
      '()
      (with-handlers
          ([exn:fail?
            (lambda (exception)
              (raise
               (exn:fail
                (format "unable to parse DIDL-Lite: ~a"
                        (exn-message exception))
                (current-continuation-marks))))])
        (call-with-input-string
         content
         (lambda (in)
           (let* ([document (read-xml in)]
                  [root (xml->xexpr (document-element document))])
             (filter-map
              (lambda (child)
                (and (xexpr-element? child)
                     (parse-entry child base-url)))
              (xexpr-children root))))))))

(define (container-id value)
  (cond
    [(string? value) value]
    [(media-container? value)
     (or (media-entry-id value)
         (raise-arguments-error
          'media-server-browse
          "media container has no object id"
          "container" value))]
    [else
     (raise-argument-error
      'media-server-browse
      "(or/c string? media-container?)"
      value)]))

(define (browse-base-url server)
  (or (upnp-device-location server)
      (format "http://~a/" (upnp-device-address server))))

(define (media-server-browse server [container "0"]
                             #:start [start 0]
                             #:count [count 0])
  (check-media-server 'media-server-browse server)
  (let* ([directory (device-content-directory server)]
         [result
          (content-directory-browse
           directory
           (container-id container)
           #:start start
           #:count count)])
    (parse-didl-lite
     (content-result-content result)
     (browse-base-url server))))

(define (media-server-root server #:start [start 0] #:count [count 0])
  (media-server-browse server "0" #:start start #:count count))

(define (media-container-children server container
                                  #:start [start 0]
                                  #:count [count 0])
  (unless (media-container? container)
    (raise-argument-error 'media-container-children
                          "media-container?"
                          container))
  (media-server-browse server container #:start start #:count count))