#lang racket/base

;; Publish local media files through Racket's web server.
;;
;; The module maps explicit URLs to local files.  Racket's file dispatcher
;; performs the actual streaming and supplies HEAD and HTTP byte-range support,
;; which media renderers commonly use for probing and seeking.

(require net/url
         racket/async-channel
         racket/file
         racket/path
         racket/string
         (prefix-in files: web-server/dispatchers/dispatch-files)
         (prefix-in sequence: web-server/dispatchers/dispatch-sequencer)
         web-server/http
         web-server/servlet-dispatch
         web-server/web-server)

(provide start-media-file-server
         media-file-server?
         media-file-server-url
         media-file-server-publish!
         media-file-server-unpublish!
         media-file-server-stop!)

(struct media-file-server
  (base-url
   base-path
   publications
   mime-types
   lock
   stop
   [stopped? #:mutable])
  #:constructor-name make-media-file-server)

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

(define (url-effective-port value)
  (or (url-port value)
      (and (equal? (url-scheme value) "http") 80)))

(define (url-path-string value)
  (let ([path
         (string-join
          (for/list ([part (in-list (url-path value))])
            (path/param-path part))
          "/")])
    (string-append
     (if (url-path-absolute? value) "/" "")
     path)))

(define (url-has-query? value)
  (and (url-query value)
       (pair? (url-query value))))

(define (normalize-base-url who value)
  (unless (string? value)
    (raise-argument-error who "string?" value))
  (let ([parsed (string->url value)])
    (unless (and (equal? (url-scheme parsed) "http")
                 (url-host parsed)
                 (url-effective-port parsed))
      (raise-arguments-error
       who
       "expected an absolute HTTP URL"
       "url" value))
    (when (or (url-user parsed)
              (url-has-query? parsed)
              (url-fragment parsed))
      (raise-arguments-error
       who
       "the server URL may not contain credentials, a query, or a fragment"
       "url" value))
    (let* ([text (url->string parsed)]
           [normalized-text
            (if (string-suffix? text "/")
                text
                (string-append text "/"))]
           [normalized (string->url normalized-text)])
      (values normalized
              (url-path-string normalized)))))

(define (same-origin? first second)
  (and (equal? (url-scheme first) (url-scheme second))
       (string-ci=? (url-host first) (url-host second))
       (= (url-effective-port first)
          (url-effective-port second))))

(define (guess-mime-type path)
  (let ([name (string-downcase (path->string path))])
    (cond
      [(regexp-match? #rx"[.]flac$" name) #"audio/flac"]
      [(regexp-match? #rx"[.]opus$" name) #"audio/ogg"]
      [(regexp-match? #rx"[.]ogg$" name) #"audio/ogg"]
      [(regexp-match? #rx"[.]oga$" name) #"audio/ogg"]
      [(regexp-match? #rx"[.]mp3$" name) #"audio/mpeg"]
      [(regexp-match? #rx"[.]m4a$" name) #"audio/mp4"]
      [(regexp-match? #rx"[.]mp4$" name) #"video/mp4"]
      [(regexp-match? #rx"[.]aac$" name) #"audio/aac"]
      [(regexp-match? #rx"[.]wav$" name) #"audio/wav"]
      [(regexp-match? #rx"[.]wave$" name) #"audio/wav"]
      [(regexp-match? #rx"[.]aif$" name) #"audio/aiff"]
      [(regexp-match? #rx"[.]aiff$" name) #"audio/aiff"]
      [(regexp-match? #rx"[.]ape$" name) #"audio/x-ape"]
      [(regexp-match? #rx"[.]wv$" name) #"audio/wavpack"]
      [(regexp-match? #rx"[.]mkv$" name) #"video/x-matroska"]
      [(regexp-match? #rx"[.]webm$" name) #"video/webm"]
      [(regexp-match? #rx"[.]jpg$" name) #"image/jpeg"]
      [(regexp-match? #rx"[.]jpeg$" name) #"image/jpeg"]
      [(regexp-match? #rx"[.]png$" name) #"image/png"]
      [else #"application/octet-stream"])))

(define (normalize-mime-type who value path)
  (cond
    [(not value) (guess-mime-type path)]
    [(bytes? value) value]
    [(string? value) (string->bytes/utf-8 value)]
    [else
     (raise-argument-error
      who
      "(or/c #f bytes? string?)"
      value)]))

(define (media-file-server-url server)
  (check-media-file-server 'media-file-server-url server)
  (url->string (media-file-server-base-url server)))

(define (resolve-publication-url who server value)
  (unless (string? value)
    (raise-argument-error who "string?" value))
  (let* ([base (media-file-server-base-url server)]
         [candidate
          (let ([parsed (string->url value)])
            (if (url-scheme parsed)
                parsed
                (combine-url/relative base value)))])
    (unless (and (equal? (url-scheme candidate) "http")
                 (url-host candidate)
                 (same-origin? base candidate))
      (raise-arguments-error
       who
       "the publication URL must use the server's HTTP origin"
       "server URL" (url->string base)
       "publication URL" value))
    (when (or (url-user candidate)
              (url-has-query? candidate)
              (url-fragment candidate))
      (raise-arguments-error
       who
       "the publication URL may not contain credentials, a query, or a fragment"
       "publication URL" value))
    (let ([path (url-path-string candidate)])
      (unless (string-prefix? path (media-file-server-base-path server))
        (raise-arguments-error
         who
         "the publication URL must be below the server URL"
         "server URL" (url->string base)
         "publication URL" value))
      (values candidate path))))

(define (start-media-file-server url
                                 #:listen-ip [listen-ip #f])
  (unless (or (not listen-ip) (string? listen-ip))
    (raise-argument-error
     'start-media-file-server
     "(or/c #f string?)"
     listen-ip))
  (let-values ([(base-url base-path)
                (normalize-base-url 'start-media-file-server url)])
    (let* ([publications (make-hash)]
           [mime-types (make-hash)]
           [lock (make-semaphore 1)]
           [missing-path
            (build-path
             (find-system-path 'temp-dir)
             (format "racket-upnp-missing-~a" (gensym)))]
           [url->path
            (lambda (request-url)
              (let ([path
                     (call-with-semaphore
                      lock
                      (lambda ()
                        (hash-ref publications
                                  (url-path-string request-url)
                                  missing-path)))])
                (values path '())))]
           [path->mime-type
            (lambda (path)
              (call-with-semaphore
               lock
               (lambda ()
                 (hash-ref mime-types
                           path
                           (lambda ()
                             (guess-mime-type path))))))]
           [file-dispatcher
            (files:make
             #:url->path url->path
             #:path->mime-type path->mime-type)]
           [not-found-dispatcher
            (dispatch/servlet
             (lambda (_request)
               (response/full
                404
                #f
                (current-seconds)
                #"text/plain; charset=utf-8"
                '()
                (list #"Not found\n"))))]
           [dispatcher
            (sequence:make
             file-dispatcher
             not-found-dispatcher)]
           [confirmation (make-async-channel)]
           [stop
            (serve
             #:dispatch dispatcher
             #:confirmation-channel confirmation
             #:listen-ip listen-ip
             #:port (url-effective-port base-url))]
           [result (sync confirmation)])
      (when (exn? result)
        (stop)
        (raise result))
      (make-media-file-server
       base-url
       base-path
       publications
       mime-types
       lock
       stop
       #f))))

(define (media-file-server-publish! server file url
                                    #:mime-type [mime-type #f])
  (check-media-file-server 'media-file-server-publish! server)
  (unless (path-string? file)
    (raise-argument-error
     'media-file-server-publish!
     "path-string?"
     file))
  (let ([path (path->complete-path file)])
    (unless (file-exists? path)
      (raise-arguments-error
       'media-file-server-publish!
       "media file does not exist"
       "file" file))
    (let-values ([(publication-url publication-path)
                  (resolve-publication-url
                   'media-file-server-publish!
                   server
                   url)])
      (call-with-semaphore
       (media-file-server-lock server)
       (lambda ()
         (when (media-file-server-stopped? server)
           (raise-arguments-error
            'media-file-server-publish!
            "media file server has been stopped"
            "server URL" (media-file-server-url server)))
         (hash-set! (media-file-server-publications server)
                    publication-path
                    path)
         (hash-set! (media-file-server-mime-types server)
                    path
                    (normalize-mime-type
                     'media-file-server-publish!
                     mime-type
                     path))))
      (url->string publication-url))))

(define (media-file-server-unpublish! server url)
  (check-media-file-server 'media-file-server-unpublish! server)
  (let-values ([(_publication-url publication-path)
                (resolve-publication-url
                 'media-file-server-unpublish!
                 server
                 url)])
    (call-with-semaphore
     (media-file-server-lock server)
     (lambda ()
       (hash-remove! (media-file-server-publications server)
                     publication-path)))
    (void)))

(define (media-file-server-stop! server)
  (check-media-file-server 'media-file-server-stop! server)
  (let ([stop
         (call-with-semaphore
          (media-file-server-lock server)
          (lambda ()
            (if (media-file-server-stopped? server)
                #f
                (begin
                  (set-media-file-server-stopped?! server #t)
                  (hash-clear! (media-file-server-publications server))
                  (media-file-server-stop server)))))])
    (when stop
      (stop))
    (void)))