Mercurial > core / lisp/lib/dat/mime.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
da17bf652e48
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; mime.lisp --- MIME Database 8 (defun read-mime-match-offset (offset) 9 "Mime offsets are encoded as single int or range N:N. Returns an integer of a 11 (let ((len (length offset))) 13 (parse-integer offset) 14 (multiple-value-bind (int1 pos) (parse-integer offset :junk-allowed t) 17 (cons int1 (parse-integer offset :start (1+ pos)))))))) 19 (defstruct mime-magic offset value type) 21 (defstruct mime-type type name superclasses glob magic) 23 (declaim (inline mime-type)) 24 (defun mime-type (mime-type) 25 (mime-type-type mime-type)) 27 (defun load-mime-info (&optional (path #p"/usr/share/mime/packages/freedesktop.org.xml")) 28 (let ((types (xmlrep-find-child-tags "mime-type" 29 (xml-parse (with-open-file (file path) 30 (with-output-to-string (st) 31 (loop for l = (read-line file nil) 33 do (std:println l st))))))) 35 ;; assumes all children have a single attribute - TYPE 36 (dolist (mime types mime-types) 37 (let ((type (xmlrep-attrib-value "type" mime))) 38 (push (make-mime-type :type type 39 :name (car (split-sequence #\/ type :count 1 :from-end t)) 41 (mapcar (lambda (x) (xmlrep-attrib-value "type" x)) 42 (xmlrep-find-child-tags "sub-class-of" mime)) 44 (mapcar (lambda (x) (xmlrep-attrib-value "pattern" x)) 45 (xmlrep-find-child-tags "glob" mime)) 47 (loop for magic in (xmlrep-find-child-tags "magic" mime) 49 collect (loop for match in (xmlrep-find-child-tags "match" magic) 50 collect (make-mime-magic 51 :offset (read-mime-match-offset 52 (xmlrep-attrib-value "offset" match)) 53 :value (xmlrep-attrib-value "value" match) 54 :type (xmlrep-attrib-value "type" match))))) 57 (defvar *mime-types* #+linux (load-mime-info)) 59 (defvar *mime-database* 61 (let ((tbl (make-hash-table :size (length *mime-types*) :test 'equal))) 62 (dolist (mime *mime-types* tbl) 63 (setf (gethash (mime-type mime) tbl) mime)))) 67 (let ((tbl (make-hash-table :test 'equal))) ;; at least as large as *MIME-DATABASE* 68 (dolist (mime *mime-types* tbl) 69 (when-let ((patterns (mime-type-glob mime))) 71 (when (wild-pathname-p p) ;; drop '.*' 72 (setf p (subseq p 2))) 73 (setf (gethash p tbl) (mime-type mime))))))) 75 (defun get-mime (value) 76 "Return the name of a MIME-TYPE from *MIME-DB*. The resulting value is a string 77 which can be passed to MIME* to get the actual object from *MIME-DATABASE*." 78 (gethash value *mime-db*)) 80 (defun get-mime* (value) 81 "Return a MIME-TYPE from *MIME-DATABASE*." 82 (gethash value *mime-database*)) 85 (defun mime-probe (pathname) 86 "Attempts to get the mime-type through a call to the FILE shell utility. 87 If the file does not exist or the platform is not unix, NIL is returned." 89 (when (probe-file pathname) 90 (let ((output (uiop:run-program (list "file" #+darwin "-bI" #-darwin "-bi" 91 (uiop:native-namestring pathname)) 93 (with-output-to-string (mime) 94 (loop for c across output 95 for char = (char-downcase c) 96 ;; Allowed characters as per RFC6383 97 while (find char "abcdefghijklmnopqrstuvwxyz0123456789!#$&-^_.+/") 98 do (write-char char mime))))) 102 (defun mime-lookup (path) 103 (get-mime (pathname-type path))) 105 (defun mime (path &optional (default "application/octet-stream")) 106 (or (mime-lookup path) 110 ;; TODO 2024-06-11: from TRIVIAL-MIMES 111 (defun mime-equal (m1 m2) 116 (destructuring-bind (type1 subtype1 &rest parameters1) 117 (uiop:split-string m1 :separator '(#\/ #\;)) 118 (declare (ignorable parameters1)) 119 (destructuring-bind (type2 subtype2 &rest parameters2) 120 (uiop:split-string m2 :separator '(#\/ #\;)) 121 (declare (ignorable parameters2)) 123 ((or (equal "*" subtype1) 127 (string-equal type1 type2)) 128 ((string-equal type1 type2) 129 (string-equal subtype1 subtype2)) 132 (defmacro mime-case (file &body cases) 133 "A case-like macro that works with MIME type of FILE. 135 Otherwise clause is the last clause that starts with T or OTHERWISE,. 138 \(mime-case #p\"~/CHANGES.txt\" 139 ((\"application/json\" \"application/*\") \"Something opaque...\") 140 (\"text/plain\" \"That's a plaintext file :D\") 141 (t \"I don't know this type!\"))" 142 (let ((mime (gensym "mime"))) 143 `(let ((,mime (mime ,file))) 145 ,@(loop for ((mimes . body) . rest) on cases 146 when (member mimes '(T OTHERWISE)) 147 collect `(t ,@body) into clauses 149 (warn "Clauses after T and OTHERWISE are not reachable.") 151 collect `((member ,mime (list ,@(uiop:ensure-list mimes)) :test #'mime-equal) 154 finally (return clauses))))))