Coverage report: /home/ellis/comp/core/lib/dat/mime.lisp

KindCoveredAll%
expression98237 41.4
branch416 25.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; mime.lisp --- MIME Database
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :dat/mime)
7
 
8
 (defun read-mime-match-offset (offset)
9
   "Mime offsets are encoded as single int or range N:N. Returns an integer of a
10
 cons of two ints."
11
   (let ((len (length offset)))
12
     (if (= 1 len)
13
         (parse-integer offset)
14
         (multiple-value-bind (int1 pos) (parse-integer offset :junk-allowed t)
15
           (if (>= pos len)
16
               int1
17
               (cons int1 (parse-integer offset :start (1+ pos))))))))
18
 
19
 (defstruct mime-magic offset value type)
20
 
21
 (defstruct mime-type type name superclasses glob magic)
22
 
23
 (declaim (inline mime-type))
24
 (defun mime-type (mime-type)
25
   (mime-type-type mime-type))
26
 
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)
32
                                                             while l
33
                                                             do (std:println l st)))))))
34
         (mime-types))
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))
40
                               :superclasses
41
                               (mapcar (lambda (x) (xmlrep-attrib-value "type" x))
42
                                       (xmlrep-find-child-tags "sub-class-of" mime))
43
                               :glob
44
                               (mapcar (lambda (x) (xmlrep-attrib-value "pattern" x))
45
                                       (xmlrep-find-child-tags "glob" mime))
46
                               :magic
47
                               (loop for magic in (xmlrep-find-child-tags "magic" mime)
48
                                     while magic
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)))))
55
             mime-types)))))
56
 
57
 (defvar *mime-types* 
58
   #+linux ;; a warning is apparently not good enough to prevent a comple-time
59
           ;; error from occuring.
60
   ;; (handler-case (load-mime-info)
61
   ;; (sb-ext:file-does-not-exist (c) (warn "~A" c)))
62
   (ignore-errors (load-mime-info)))
63
 
64
 (defvar *mime-database*
65
   #+linux
66
   (let ((tbl (make-hash-table :size (length *mime-types*) :test 'equal)))
67
     (dolist (mime *mime-types* tbl)
68
       (setf (gethash (mime-type mime) tbl) mime))))
69
 
70
 (defvar *mime-db*
71
   #+linux
72
   (let ((tbl (make-hash-table :test 'equal))) ;; at least as large as *MIME-DATABASE*
73
     (dolist (mime *mime-types* tbl)
74
       (when-let ((patterns (mime-type-glob mime)))
75
         (dolist (p patterns)
76
           (when (wild-pathname-p p) ;; drop '.*'
77
             (setf p (subseq p 2)))
78
           (setf (gethash p tbl) (mime-type mime)))))))
79
 
80
 (defun get-mime (value)
81
   "Return the name of a MIME-TYPE from *MIME-DB*. The resulting value is a string
82
 which can be passed to MIME* to get the actual object from *MIME-DATABASE*."
83
   (gethash value *mime-db*))
84
 
85
 (defun get-mime* (value)
86
   "Return a MIME-TYPE from *MIME-DATABASE*."
87
   (gethash value *mime-database*))
88
 
89
 ;; from TRIVIAL-MIMES
90
 (defun mime-probe (pathname)
91
   "Attempts to get the mime-type through a call to the FILE shell utility.
92
 If the file does not exist or the platform is not unix, NIL is returned."
93
   #+unix
94
   (when (probe-file pathname)
95
     (let ((output (uiop:run-program (list "file" #+darwin "-bI" #-darwin "-bi"
96
                                                  (uiop:native-namestring pathname))
97
                                     :output :string)))
98
       (with-output-to-string (mime)
99
         (loop for c across output
100
               for char = (char-downcase c)
101
               ;; Allowed characters as per RFC6383
102
               while (find char "abcdefghijklmnopqrstuvwxyz0123456789!#$&-^_.+/")
103
               do (write-char char mime)))))
104
   #-unix
105
   NIL)
106
 
107
 (defun mime-lookup (path)
108
   (get-mime (pathname-type path)))
109
 
110
 (defun mime (path &optional (default "application/octet-stream"))
111
   (or (mime-lookup path)
112
       (mime-probe path)
113
       default))
114
 
115
 ;; TODO 2024-06-11: from TRIVIAL-MIMES
116
 (defun mime-equal (m1 m2)
117
   (or (equal "*" m1)
118
       (equal "*" m2)
119
       (equal "*/*" m1)
120
       (equal "*/*" m2)
121
       (destructuring-bind (type1 subtype1 &rest parameters1)
122
           (uiop:split-string m1 :separator '(#\/ #\;))
123
         (declare (ignorable parameters1))
124
         (destructuring-bind (type2 subtype2 &rest parameters2)
125
             (uiop:split-string m2 :separator '(#\/ #\;))
126
           (declare (ignorable parameters2))
127
           (cond
128
             ((or (equal "*" subtype1)
129
                  (equal "*" subtype2)
130
                  (equal "" subtype1)
131
                  (equal "" subtype2))
132
              (string-equal type1 type2))
133
             ((string-equal type1 type2)
134
              (string-equal subtype1 subtype2))
135
             (t nil))))))
136
 
137
 (defmacro mime-case (file &body cases)
138
   "A case-like macro that works with MIME type of FILE.
139
 
140
 Otherwise clause is the last clause that starts with T or OTHERWISE,.
141
 
142
 Example:
143
 \(mime-case #p\"~/CHANGES.txt\"
144
   ((\"application/json\" \"application/*\") \"Something opaque...\")
145
   (\"text/plain\" \"That's a plaintext file :D\")
146
   (t \"I don't know this type!\"))"
147
   (let ((mime (gensym "mime")))
148
     `(let ((,mime (mime ,file)))
149
        (cond
150
          ,@(loop for ((mimes . body) . rest) on cases
151
                  when (member mimes '(T OTHERWISE))
152
                    collect `(t ,@body) into clauses
153
                    and do (if rest
154
                               (warn "Clauses after T and OTHERWISE are not reachable.")
155
                               (return clauses))
156
                  collect `((member ,mime (list ,@(uiop:ensure-list mimes)) :test #'mime-equal)
157
                            ,@body)
158
                    into clauses
159
                  finally (return clauses))))))