#lang racket/base

(require racket/class
         racket/list
         racket/match
         racket/string
         (prefix-in upnp: racket-upnp)
         "library-factory.rkt"
         "mc-media-server.rkt"
         "base/media-library.rkt"
         "track-media-server.rkt"
         "../misc/utils.rkt")

(provide library-media-server%
         register-library-media-server!)

(define library-media-server-kind
  'media-server)

(define library-media-server-version
  1)

(define (register-library-media-server! factory)
  (check/c register-library-media-server!
           factory
           (is-a?/c library-factory%))

  (send factory
        register-library-maker!
        library-media-server-kind
        library-media-server-version
        (lambda (cfg)
          (new library-media-server%
               [cfg cfg]))))

(define library-media-server%
  (class media-library%
    (init
     cfg)

    (define server
      #f)

    (define server-cfg-revision
      -1)

    (define/private (server-selector)
      (or (send (send this get-cfg)
                get-host)
          (send (send this get-cfg)
                get-name)))

    (define/private (server-matches? candidate selector)
      (let ((name
             (upnp:media-server-name candidate))
            (address
             (upnp:media-server-address candidate))
            (udn
             (upnp:upnp-device-udn candidate)))
        (or
         (and udn
              (string-ci=? udn selector))
         (and name
              (string-ci=? name selector))
         (and address
              (string-ci=? address selector))
         (and name
              (string-contains?
               (string-downcase name)
               (string-downcase selector))))))

    (define/private (get-server)
      (let ((cfg-revision
             (send (send this get-cfg)
                   get-revision)))
        (unless (= cfg-revision
                   server-cfg-revision)
          (set! server #f)
          (set! server-cfg-revision
                cfg-revision))
        (unless server
          (let* ((selector (server-selector))
                 (found
                  (findf
                   (lambda (candidate)
                     (server-matches?
                      candidate
                      selector))
                   (upnp:query-media-servers))))
            (unless found
              (raise-arguments-error
               'library-media-server%
               "configured media server was not found"
               "selector" selector))
            (set! server found)))
        server))

    (define/private (root-container-id)
      (format "~a"
              (send (send this get-cfg)
                    get-root)))

    (define/private (browse-page container-id start count)
      (with-handlers
          (((lambda (exception)
              (and
               (upnp:exn:fail:upnp? exception)
               (equal?
                (format "~a"
                        (upnp:exn:fail:upnp-code
                         exception))
                "701")
               (equal? container-id
                       (root-container-id))
               (not (string=? container-id
                              "0"))))
            (lambda (exception)
              (warn-rktplayer
               (string-append
                "Configured UPnP media-server root ~a "
                "does not exist; browsing root 0")
               container-id)
              (upnp:media-server-browse
               (get-server)
               "0"
               #:start start
               #:count count))))
        (upnp:media-server-browse
         (get-server)
         container-id
         #:start start
         #:count count)))

    (define/public (browse-container container-id)
      (check/c library-media-server% browse-container
               container-id
               string?)

      (browse-page
       container-id
       0
       (send (send this get-cfg)
             get-item-limit)))

    (define/private (find-entry parent-id entry-id)
      (let ((page-size
             (send (send this get-cfg)
                   get-item-limit)))
        (let loop ((start 0))
          (let* ((entries
                  (browse-page parent-id
                               start
                               page-size))
                 (entry
                  (findf
                   (lambda (candidate)
                     (equal?
                      (upnp:media-entry-id candidate)
                      entry-id))
                   entries)))
            (cond
              (entry entry)
              ((< (length entries)
                  page-size)
               #f)
              (else
               (loop (+ start
                        page-size))))))))

    (define/override (make-root-container)
      (new mc-media-server%
           [library this]
           [container-id
            (root-container-id)]
           [title
            (send (send this get-cfg)
                  get-name)]))

    (define/public (make-container entry)
      (check/c library-media-server% make-container
               entry
               upnp:media-container?)

      (new mc-media-server%
           [library this]
           [container-id
            (upnp:media-entry-id entry)]
           [title
            (upnp:media-entry-title entry)]))

    (define/public (make-track entry)
      (check/c library-media-server% make-track
               entry
               upnp:media-item?)

      (new track-media-server%
           [library this]
           [entry entry]))

    (define/public (relive-track track-factory-id
                                 track-relive-info)
      (case track-factory-id
        ((media-server-item)
         (match track-relive-info
           ((list (? string? parent-id)
                  (? string? entry-id))
            (let ((entry
                   (find-entry parent-id
                               entry-id)))
              (and entry
                   (upnp:media-item? entry)
                   (send this
                         make-track
                         entry))))
           (else #f)))
        (else #f)))

    (super-new
     [cfg cfg])))