whatsxmpp/nix/trivial-mimes.nix

102 lines
3.6 KiB
Nix
Raw Normal View History

{ mime-types, pkgs ? import <nixpkgs> {} }:
pkgs.writeText "trivial-mimes.lisp" ''
#|
This file is a part of Trivial-Mimes
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(defpackage #:trivial-mimes
(:nicknames #:mimes #:org.tymoonnext.trivial-mimes)
(:use #:cl)
(:export
#:*mime-db*
#:find-mime.types
#:mime-probe
#:mime-lookup
#:mime
#:mime-file-type))
(in-package #:org.tymoonnext.trivial-mimes)
(defun find-mime.types ()
"Attempts to find a usable MIME.TYPES file.
If none can be found, an error is signalled."
(or (loop for file in (list #p"${mime-types}"
#+asdf (merge-pathnames "mime.types" (asdf:system-source-directory :trivial-mimes)))
thereis (probe-file file))
(error "No MIME.TYPES file found anywhere!")))
(defvar *mime-db* (make-hash-table :test 'equalp)
"An EQUALP hash-table with file-extensions as keys and the mime-types as values.")
(defvar *reverse-mime-db* (make-hash-table :test 'equalp)
"An EQUALP hash-table with mime-types as keys and the file-extensions as values.")
(defun whitespace-p (char)
(find char '(#\Space #\Newline #\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout)))
(defun %read-tokens (line)
(let ((tokens)
(start))
(dotimes (i (length line))
(let ((char (aref line i)))
(cond
((and start (whitespace-p char))
(push (subseq line start i) tokens)
(setf start NIL))
((not (or start (whitespace-p char)))
(setf start i)))))
(when start (push (subseq line start) tokens))
(nreverse tokens)))
(defun build-mime-db (&optional (file (find-mime.types)))
"Populates the *MIME-DB* with data gathered from the file.
The file should have the following structure:
MIME-TYPE FILE-EXTENSION*"
(with-open-file (stream file :direction :input)
(loop for line = (read-line stream NIL)
while line
for tokens = (%read-tokens line)
do (dolist (ending (cdr tokens))
(setf (gethash ending *mime-db*) (car tokens)))
(setf (gethash (first tokens) *reverse-mime-db*) (second tokens)))))
(build-mime-db)
(defun mime-probe (pathname)
"Attempts to get the mime-type through a call to the FILE shell utility.
If the file does not exist or the platform is not unix, NIL is returned."
#+unix
(when (probe-file pathname)
(let ((output (uiop:run-program (list "file" #+darwin "-bI" #-darwin "-bi"
(uiop:native-namestring pathname))
:output :string)))
(with-output-to-string (mime)
(loop for c across output
for char = (char-downcase c)
;; Allowed characters as per RFC6383
while (find char "abcdefghijklmnopqrstuvwxyz0123456789!#$&-^_.+/")
do (write-char char mime)))))
#-unix
NIL)
(defun mime-lookup (pathname)
"Attempts to get the mime-type by file extension comparison.
If none can be found, NIL is returned."
(gethash (pathname-type pathname) *mime-db*))
(defun mime (pathname &optional (default "application/octet-stream"))
"Attempts to detect the mime-type of the given pathname.
First uses MIME-LOOKUP, then MIME-PROBE and lastly returns the DEFAULT if both fail."
(or (mime-lookup pathname)
(mime-probe pathname)
default))
(defun mime-file-type (mime-type)
"Returns a matching file-extension for the given mime-type.
If the given mime-type cannot be found, NIL is returned."
(gethash mime-type *reverse-mime-db*))
''