153 lines
4.8 KiB
Racket
153 lines
4.8 KiB
Racket
#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))
|