;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A little magic library.
;;;
;;; Exports one procedure, `identify`, that'll hopefully DWYM.
;;;
;;; See libmagic.scm for low-level bindings.
;;;
;;; Copyright (c) 2013-2018, Evan Hanson
;;; BSD-style license. See LICENSE for details.
;;;

(module (magic) (identify)
  (import (scheme)
          (chicken base)
          (chicken bitwise)
          (chicken blob)
          (chicken condition)
          (chicken file posix)
          (magic libmagic))
  (define (fold f a l) ; `foldl` not provided by CHICKENs < 4.7.3.
    (if (null? l) a (fold f (f a (car l)) (cdr l))))
  (define identify
    (let ((*flags* 'none)
          (*magic* (let ((cookie (magic_open MAGIC_ERROR)))
                     (cond ((and cookie (zero? (magic_load cookie #f))) cookie)
                           ((error "Unable to initialize libmagic"))))))
      (letrec ((magic-error
                (lambda (magic #!optional (message (magic_error magic)) #!rest arguments)
                  (signal
                   (make-composite-condition
                    (make-property-condition 'magic 'errno (magic_errno magic))
                    (make-property-condition 'exn
                     'message message 'location 'identify 'arguments arguments)))))
               (symbol->flags
                (lambda (sym)
                  (if (list? sym)
                      (fold bitwise-ior MAGIC_ERROR (map symbol->flags sym))
                      (case sym
                        ((apple) MAGIC_APPLE)
                        ((compress) MAGIC_COMPRESS)
                        ;((continue) MAGIC_CONTINUE) ; TODO List all.
                        ((device) MAGIC_DEVICES)
                        ((mime) MAGIC_MIME)
                        ((mime-encoding encoding) MAGIC_MIME_ENCODING)
                        ((mime-type type) MAGIC_MIME_TYPE)
                        ((no-apptype) MAGIC_NO_CHECK_APPTYPE)
                        ((no-cdf) MAGIC_NO_CHECK_CDF)
                        ((no-compress) MAGIC_NO_CHECK_COMPRESS)
                        ((no-elf) MAGIC_NO_CHECK_ELF)
                        ((no-encoding) MAGIC_NO_CHECK_ENCODING)
                        ((no-soft) MAGIC_NO_CHECK_SOFT)
                        ((no-tar) MAGIC_NO_CHECK_TAR)
                        ((no-text) MAGIC_NO_CHECK_TEXT)
                        ((no-tokens) MAGIC_NO_CHECK_TOKENS)
                        ((none) MAGIC_NONE)
                        ((preserve-atime) MAGIC_PRESERVE_ATIME)
                        ((raw) MAGIC_RAW)
                        ((symlink) MAGIC_SYMLINK)
                        (else (magic-error *magic* "Invalid magic type" sym)))))))
        (case-lambda
          (()
           (identify (current-input-port) 'none))
          ((obj)
           (identify obj 'none))
          ((obj type)
           (unless (equal? *flags* type)
             (unless (zero? (magic_setflags *magic* (symbol->flags type)))
               (magic-error *magic*))
             (set! *flags* type))
           (or (cond ((string? obj)     (magic_file *magic* obj))
                     ((blob? obj)       (magic_buffer *magic* obj (blob-size obj)))
                     ((fixnum? obj)     (magic_descriptor *magic* obj))
                     ((input-port? obj) (magic_descriptor *magic* (port->fileno obj)))
                     (else              (magic-error *magic* "Invalid argument" obj)))
               (magic-error *magic*))))))))