#lang racket/base

(require net/url
         (only-in net/url-connect current-https-protocol)
         racket/contract
         racket/file
         racket/port
         racket/string
         simple-log
         "private/mime-types.rkt"
         (rename-in "private/fallback.rkt"
                    [mimetypes fallback-mimetypes]))

(provide
 (contract-out
  [mimetype-for-ext
   (->* ((or/c path? string? symbol?))
        (#:default string?)
        string?)]))

(sl-def-log racket-mimetypes)

(define apache-mime-types-url
  "https://svn.apache.org/repos/asf/httpd/httpd/trunk/docs/conf/mime.types")

(define cache-directory
  (build-path (find-system-path 'cache-dir) "racket-mimetypes"))

(define cache-file
  (build-path cache-directory "mime.types"))

(define failure-file
  (build-path cache-directory "last-failure"))

(define update-running? #f)
(define update-guard (make-semaphore 1))

(define (read-cache)
  (with-handlers ([exn:fail?
                   (λ (exn)
                     (dbg-racket-mimetypes
                      "Could not read cached mime.types: ~a"
                      (exn-message exn))
                     (values fallback-mimetypes #f))])
    (if (file-exists? cache-file)
        (let ([types (call-with-input-file cache-file parse-mime-types)])
          (if (valid-apache-types? types)
              (values types #t)
              (begin
                (dbg-racket-mimetypes
                 "Cached mime.types did not pass validation")
                (values fallback-mimetypes #f))))
        (values fallback-mimetypes #f))))

(define-values (mimetypes cache-valid?) (read-cache))

(define (file-time path)
  (and (file-exists? path)
       (file-or-directory-modify-seconds path)))

(define (update-due?)
  (update-due?/times (current-seconds)
                     (and cache-valid? (file-time cache-file))
                     (file-time failure-file)))

(define (mark-update-failure!)
  (make-directory* cache-directory)
  (call-with-output-file failure-file
    (λ (out)
      (displayln (current-seconds) out))
    #:exists 'truncate/replace))

(define (download-apache-types)
  (parameterize ([current-https-protocol 'secure])
    (let-values ([(in headers)
                  (get-pure-port/headers
                   (string->url apache-mime-types-url)
                   null
                   #:redirections 5
                   #:status? #t)])
      (dynamic-wind
        void
        (λ ()
          (unless (regexp-match? #rx"^HTTP/[^ ]+ 200" headers)
            (error 'download-apache-types
                   "HTTP request failed: ~a"
                   (car (string-split headers "\n"))))
          (let* ([contents (port->bytes in)]
                 [types
                  (call-with-input-bytes contents parse-mime-types)])
            (unless (valid-apache-types? types)
              (error 'download-apache-types
                     "downloaded mime.types did not pass validation"))
            (values contents types)))
        (λ ()
          (close-input-port in))))))

(define (save-cache! contents)
  (make-directory* cache-directory)
  (call-with-atomic-output-file cache-file
    (λ (out temporary-file)
      (write-bytes contents out)
      (void))))

(define (update-mimetypes!)
  (with-handlers ([exn:fail?
                   (λ (exn)
                     (dbg-racket-mimetypes
                      "Could not update Apache mime.types: ~a"
                      (exn-message exn))
                     (with-handlers
                         ([exn:fail?
                           (λ (mark-exn)
                             (dbg-racket-mimetypes
                              "Could not record mime.types update failure: ~a"
                              (exn-message mark-exn)))])
                       (mark-update-failure!)))])
    (let-values ([(contents types) (download-apache-types)])
      (save-cache! contents)
      (set! mimetypes types)
      (set! cache-valid? #t)
      (dbg-racket-mimetypes
       "Apache mime.types updated: ~a extensions"
       (hash-count types)))))

(define (run-update!)
  (dynamic-wind
    void
    update-mimetypes!
    (λ ()
      (call-with-semaphore update-guard
        (λ ()
          (set! update-running? #f))))))

(define (maybe-start-update!)
  (when (updates-enabled?)
    (with-handlers ([exn:fail?
                     (λ (exn)
                       (dbg-racket-mimetypes
                        "Could not check Apache mime.types cache: ~a"
                        (exn-message exn)))])
      (call-with-semaphore update-guard
        (λ ()
          (when (and (not update-running?)
                     (update-due?))
            (set! update-running? #t)
            (thread run-update!)))))))

(define (mimetype-for-ext ext
                          #:default [default "application/octet-stream"])
  (maybe-start-update!)
  (hash-ref mimetypes (extension-symbol ext) default))