7e457266f8
- Using tazjin's buildLisp.nix (you need the TVL Monorepo installed as <depot>), we have a derivation for whatsxmpp and its million dependencies. - The derivation currently just assumes whatscl is in ../whatscl, but we'll fix that eventually. - Also there are tons of buildLisp derivations in here, and even two instances where we had to vendor stuff in order to get it to work with nix (usually because it had some data file). - But yay, we can build via docker and it's not utter trash!
102 lines
3.6 KiB
Nix
102 lines
3.6 KiB
Nix
{ 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*))
|
|
''
|