photo-store/exif.lisp

(in-package #:photo-store)

(defun degrees-to-rational (deg ref)
  (when deg
    (let ((rational
           (+ (elt deg 0)
              (/ (elt deg 1) 60)
              (/ (elt deg 2) 3600))))
      (if (member ref '("N" "E") :test #'equal)
          rational
          (- rational)))))

(defun exif-to-point (exif)
  (when exif
    (let ((lat (degrees-to-rational (zpb-exif:exif-value :GPSLatitude exif)
                                    (zpb-exif:exif-value :GPSLatitudeRef exif)))
          (lon (degrees-to-rational (zpb-exif:exif-value :GPSLongitude exif)
                                    (zpb-exif:exif-value :GPSLongitudeRef exif))))
      (and lat lon (geo:point-deg lat lon)))))

(defun exif-to-taken (exif)
  (when exif
    (or (zpb-exif:parsed-exif-value :DateTimeOriginal exif)
        (zpb-exif:parsed-exif-value :DateTime exif))))

(defun exif-to-dim (exif)
  (when exif
    (let ((width (and exif (or (zpb-exif:exif-value :PixelXDimension exif)
                               (zpb-exif:exif-value :ImageWidth exif))))
          (height (and exif (or (zpb-exif:exif-value :PixelYDimension exif)
                                (zpb-exif:exif-value :ImageHeight exif)))))
      (and width height (list width height)))))

(defun get-dims (path)
  (with-open-file (in path :element-type '(unsigned-byte 8))
    (case (intern (string-upcase (pathname-type path)) "KEYWORD")
      (:jpg (multiple-value-bind (h w)
                (jpeg:decode-stream-height-width in)
              (list w h)))
      (:png (let ((png (png-read:read-png-datastream in)))
              (list (png-read:width png) (png-read:height png)))))))

(defun load-photo-info (path)
  (with-open-file (in path :element-type '(unsigned-byte 8))
    (let ((length (file-length in))
          (modified (file-write-date path))
          (exif (ignore-errors (zpb-exif:make-exif in))))
      (list
       (cons :path path)
       (cons :name (pathname-name path))
       (cons :modified modified)
       (cons :length length)
       (cons :created-at (local-time:universal-to-timestamp
                          (or (exif-to-taken exif) modified)))
       (cons :dim (or (exif-to-dim exif)
                      (get-dims path)))
       (cons :location (exif-to-point exif))))))