rktplayer/library/track-media-server.rkt

#lang racket/base

(require net/url
         racket-mimetypes/mimetypes
         racket/class
         racket/list
         racket/port
         racket/string
         (prefix-in upnp: racket-upnp)
         "base/booklet-provider.rkt"
         "base/image-provider.rkt"
         "library-ref.rkt"
         "base/media-resource.rkt"
         "base/tag-data-provider.rkt"
         "track-tag-data.rkt"
         "base/track.rkt"
         "../misc/utils.rkt")

(provide track-media-server%)

(define tag-data-provider-media-server%
  (class tag-data-provider%
    (init-field
     entry
     resource)

    (define/override (get-tag-data)
      (let ((artists
             (upnp:media-item-artists entry)))
        (track-tag-data
         (upnp:media-entry-title entry)
         (cond
           ((not (null? artists))
            (car artists))
           ((upnp:media-item-creator entry)
            (upnp:media-item-creator entry))
           (else ""))
         (or (upnp:media-item-album entry)
             "")
         (or
          (upnp:media-item-original-track-number
           entry)
          0)
         (or (upnp:media-resource-duration
              resource)
             0))))

    (super-new)))

(define image-provider-media-server%
  (class image-provider%
    (init-field uri)

    (define mime-type
      (and uri
           (mimetype-for-ext
            (regexp-replace
             #px"[?#].*$"
             uri
             "")
            #:default
            "application/octet-stream")))

    (define/private (stored-file target-file)
      (let ((extension
             (cond
               ((equal? mime-type "image/jpeg") ".jpg")
               ((equal? mime-type "image/png") ".png")
               (else ""))))
        (string-append
         (format "~a" target-file)
         extension)))

    (define/override (has-image?)
      (and (string? uri)
           (not (string=? uri ""))))

    (define/override (image->file target-file)
      (and
       (send this has-image?)
       (with-handlers
           ((exn:fail?
             (lambda (exception)
               (warn-rktplayer
                "Could not retrieve media-server image: ~a"
                (exn-message exception))
               #f)))
         (let ((file (stored-file target-file)))
           (call/input-url
            (string->url uri)
            get-pure-port
            (lambda (input)
              (call-with-output-file
               file
               (lambda (output)
                 (copy-port input output))
               #:exists 'replace)))
           file))))

    (define/override (image->mimetype)
      (or mime-type
          'no-mimetype))

    (super-new)))

(define booklet-provider-media-server%
  (class booklet-provider%
    (define/override (has-booklet?)
      #f)

    (define/override (booklet-file)
      #f)

    (super-new)))

(define (audio-resource? resource)
  (let ((content-type
         (upnp:media-resource-content-type
          resource)))
    (and content-type
         (string-prefix?
          content-type
          "audio/"))))

(define (resource-seekable? resource)
  (let ((protocol-info
         (upnp:media-resource-protocol-info
          resource)))
    (and protocol-info
         (regexp-match?
          #px"DLNA[.]ORG_OP=(?:01|10|11)"
          protocol-info))))

(define track-media-server%
  (class track%
    (init-field
     library
     entry)

    (check/c track-media-server%
             entry
             upnp:media-item?)

    (define source-resource
      (or
       (findf
        audio-resource?
        (upnp:media-item-resources entry))
       (car
        (upnp:media-item-resources entry))))

    (define resource
      (new media-resource%
           [uri
            (upnp:media-resource-uri
             source-resource)]
           [mime-type
            (upnp:media-resource-content-type
             source-resource)]
           [protocol-info
            (upnp:media-resource-protocol-info
             source-resource)]
           [seekable?
            (resource-seekable?
             source-resource)]))

    (super-new
     [resource resource]
     [music-library-factory-id
      (let ((cfg (send library get-cfg)))
        (library-ref
         (send cfg get-id)
         (send cfg get-kind)
         (send cfg get-kind-version)))]
     [track-factory-id
      'media-server-item]
     [track-relive-info
      (list
       (upnp:media-entry-parent-id entry)
       (upnp:media-entry-id entry))]
     [tag-data-provider
      (new tag-data-provider-media-server%
           [entry entry]
           [resource source-resource])]
     [image-provider
      (new image-provider-media-server%
           [uri
            (upnp:media-item-album-art-uri
             entry)])]
     [booklet-provider
      (new booklet-provider-media-server%)])))