ja

private/mime-types.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+
+(require racket/string)
+
+(provide extension-symbol
+         failure-interval
+         parse-mime-types
+         success-interval
+         update-due?/times
+         updates-enabled?
+         valid-apache-types?)
+
+(define success-interval (* 7 24 60 60))
+(define failure-interval (* 24 60 60))
+(define updates-enabled? (make-parameter #t))
+
+(define (parse-mime-types in)
+  (for/fold ([types (hash)])
+            ([line (in-lines in)])
+    (let ([fields (string-split (string-trim line))])
+      (cond
+        [(or (null? fields)
+             (string-prefix? (car fields) "#")
+             (null? (cdr fields)))
+         types]
+        [else
+         (let ([mime-type (car fields)])
+           (unless (regexp-match? #px"^[^/[:space:]]+/[^[:space:]]+$"
+                                  mime-type)
+             (error 'parse-mime-types
+                    "invalid MIME type: ~a"
+                    mime-type))
+           (for/fold ([result types])
+                     ([extension (in-list (cdr fields))])
+             (let ([key (string->symbol (string-downcase extension))])
+               (hash-set result key mime-type))))]))))
+
+(define (valid-apache-types? types)
+  (and (> (hash-count types) 500)
+       (equal? (hash-ref types 'html #f) "text/html")
+       (equal? (hash-ref types 'mp3 #f) "audio/mpeg")
+       (equal? (hash-ref types 'mp4 #f) "video/mp4")
+       (equal? (hash-ref types 'png #f) "image/png")))
+
+(define (extension-symbol ext)
+  (let* ([value (cond
+                  [(path? ext) (path->string ext)]
+                  [(symbol? ext) (symbol->string ext)]
+                  [else ext])]
+         [name (car (reverse (regexp-split #px"[\\\\/]" value)))]
+         [parts (regexp-match #px"(?:^|\\.)([^.]*)$" name)]
+         [extension (if parts (cadr parts) name)])
+    (string->symbol (string-downcase extension))))
+
+(define (update-due?/times now cache-time failure-time)
+  (cond
+    [(and cache-time
+          (< (- now cache-time) success-interval))
+     #f]
+    [(and failure-time
+          (< (- now failure-time) failure-interval))
+     #f]
+    [else #t]))