174 lines
6.4 KiB
Scheme
174 lines
6.4 KiB
Scheme
;;; mime.scm
|
|
|
|
;; Foreign interface to the libmagic C library provided by the file utility
|
|
|
|
(define-module (mime)
|
|
#:export (file->mime ; higher-level functions
|
|
magic? wrap-magic unwrap-magic ; lower-level functions
|
|
open-magic-database
|
|
close-magic-database
|
|
load-magic-database
|
|
get-mime/file get-mime/buffer
|
|
magic/none
|
|
magic/debug
|
|
magic/symlink
|
|
magic/compress
|
|
magic/devices
|
|
magic/mime-type
|
|
magic/continue
|
|
magic/check
|
|
magic/preserve-atime
|
|
magic/raw
|
|
magic/error
|
|
magic/mime-encoding
|
|
magic/apple
|
|
magic/no-check-compress
|
|
magic/no-check-tar
|
|
magic/no-check-soft
|
|
magic/no-check-apptype
|
|
magic/no-check-elf
|
|
magic/no-check-text
|
|
magic/no-check-cdf
|
|
magic/no-check-csv
|
|
magic/no-check-tokens
|
|
magic/no-check-encoding
|
|
magic/no-check-json
|
|
magic/no-check-simh
|
|
magic/extension
|
|
magic/compress-transp
|
|
magic/no-compress-fork
|
|
magic/mime
|
|
magic/nodesc))
|
|
|
|
(use-modules (rnrs bytevectors)
|
|
(ice-9 binary-ports)
|
|
(system foreign)
|
|
(system foreign-library))
|
|
|
|
|
|
;;; HIGHER-LEVEL ABSTRACTIONS ;;;
|
|
;; TODO: Parse the mime-types into something more immediately useful to
|
|
;; an end user, as "text/plain; charset=us-ascii" isn't very useful as-is
|
|
|
|
(define* (open-and-load-magic-database
|
|
#:optional (flags magic/mime) (database-paths %null-pointer))
|
|
;; Open and load the magic database at the same time
|
|
(let ((cookie (open-magic-database flags)))
|
|
(load-magic-database cookie database-paths)
|
|
cookie))
|
|
|
|
|
|
(define* (file->mime port
|
|
#:optional (flags magic/mime) (database-paths %null-pointer))
|
|
;; Stateless wrapper over the database stuff that uses ports
|
|
(let ((cookie (open-and-load-magic-database flags database-paths)))
|
|
(cond ((and (input-port? port) (port-filename port))
|
|
(let* ((name (port-filename port))
|
|
(mime (get-mime/file cookie name)))
|
|
(close-magic-database cookie)
|
|
mime))
|
|
((input-port? port)
|
|
(let* ((buffer (get-bytevector-all port))
|
|
(mime (get-mime/buffer cookie buffer)))
|
|
(close-magic-database cookie)
|
|
mime))
|
|
((string? port)
|
|
(let* ((mime (get-mime/file cookie port)))
|
|
(close-magic-database cookie)
|
|
mime))
|
|
((bytevector? port)
|
|
(let* ((mime (get-mime/buffer cookie port)))
|
|
(close-magic-database cookie)
|
|
mime)))))
|
|
|
|
|
|
;;; LOW-LEVEL FFI ;;;
|
|
(define magic-library (load-foreign-library "libmagic"))
|
|
|
|
|
|
;; Functions for working with the magic_t type
|
|
;; All further functions will wrap them before returning them, or unwrap them
|
|
;; if they expect them as an argument
|
|
(define-wrapped-pointer-type magic
|
|
magic? wrap-magic unwrap-magic
|
|
(lambda (magic port)
|
|
(format port "#<magic ~a>" magic)))
|
|
|
|
|
|
;; Bindings for the flag values
|
|
;; If anyone knows a way to do this dynamically, let me know!
|
|
(define magic/none #x0000000)
|
|
(define magic/debug #x0000001)
|
|
(define magic/symlink #x0000002)
|
|
(define magic/compress #x0000004)
|
|
(define magic/devices #x0000008)
|
|
(define magic/mime-type #x0000010)
|
|
(define magic/continue #x0000020)
|
|
(define magic/check #x0000040)
|
|
(define magic/preserve-atime #x0000080)
|
|
(define magic/raw #x0000100)
|
|
(define magic/error #x0000200)
|
|
(define magic/mime-encoding #x0000400)
|
|
(define magic/apple #x0000800)
|
|
(define magic/no-check-compress #x0001000)
|
|
(define magic/no-check-tar #x0002000)
|
|
(define magic/no-check-soft #x0004000)
|
|
(define magic/no-check-apptype #x0008000)
|
|
(define magic/no-check-elf #x0010000)
|
|
(define magic/no-check-text #x0020000)
|
|
(define magic/no-check-cdf #x0040000)
|
|
(define magic/no-check-csv #x0080000)
|
|
(define magic/no-check-tokens #x0100000)
|
|
(define magic/no-check-encoding #x0200000)
|
|
(define magic/no-check-json #x0400000)
|
|
(define magic/no-check-simh #x0800000)
|
|
(define magic/extension #x1000000)
|
|
(define magic/compress-transp #x2000000)
|
|
(define magic/no-compress-fork #x4000000)
|
|
|
|
(define magic/mime (logior magic/mime-type magic/mime-encoding))
|
|
(define magic/nodesc (logior magic/extension magic/mime magic/apple))
|
|
|
|
|
|
(define (open-magic-database flags)
|
|
;; Open and return the magic database with the given flags
|
|
(let ((open (foreign-library-function magic-library "magic_open"
|
|
#:return-type '*
|
|
#:arg-types (list int))))
|
|
(wrap-magic (open flags))))
|
|
|
|
|
|
(define (close-magic-database cookie)
|
|
;; Close the given magic database
|
|
(let ((close (foreign-library-function magic-library "magic_close"
|
|
#:arg-types (list '*))))
|
|
(close (unwrap-magic cookie))))
|
|
|
|
|
|
(define* (load-magic-database cookie #:optional (paths %null-pointer))
|
|
;; Load the given magic database, returning whether it succeeded as a bool
|
|
(let ((load (foreign-library-function magic-library "magic_load"
|
|
#:return-type int
|
|
#:arg-types (list '* '*)))
|
|
(cookie (unwrap-magic cookie)))
|
|
(= 0 (load cookie paths))))
|
|
|
|
|
|
(define (get-mime/file cookie path)
|
|
;; Get the mime-type of a file from the given path
|
|
(let ((get-mime (foreign-library-function magic-library "magic_file"
|
|
#:return-type '*
|
|
#:arg-types (list '* '*))))
|
|
(pointer->string (get-mime (unwrap-magic cookie)
|
|
(string->pointer path)))))
|
|
|
|
|
|
(define* (get-mime/buffer cookie bv #:optional bv-length)
|
|
;; Get the mime-type of a file contained in a bytevector
|
|
(let ((get-mime (foreign-library-function magic-library "magic_buffer"
|
|
#:return-type '*
|
|
#:arg-types (list '* '* int))))
|
|
(pointer->string (get-mime
|
|
(unwrap-magic cookie)
|
|
(bytevector->pointer bv)
|
|
(or bv-length (bytevector-length bv))))))
|