photo-store/photo-store.lisp

(in-package #:photo-store)
(use-package :iter)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (restas::register-pkgmodule-traits 'photo-store)
  (restas:reconnect-all-routes))


;; photos: id | album_id | filename | size | taken | width | height | lat | lon
;; albums: id | parent_id | path | date | name | description | cover_id | accessibility

(defvar *db-path* "db.sqlite" "SQLite database path")

(defmacro with-db ((db) &body body)
  `(sqlite:with-open-database (,db *db-path* :busy-timeout 10)
     (sqlite:execute-non-query ,db "PRAGMA foreign_keys = ON")
     ,@body))

(defun db-init ()
  (with-db (db)
    (sqlite:execute-non-query db "create table if not exists photos (id INTEGER PRIMARY KEY, path, size, taken, width, height, lat, lon)")
    (sqlite:execute-non-query db "create table if not exists albums (id INTEGER PRIMARY KEY, name, description, cover_id REFERENCES photos)")
    (sqlite:execute-non-query db "create table if not exists album_photos (album_id REFERENCES albums NOT NULL, photo_id REFERENCES photos NOT NULL, description, idx, hidden)")))

(defun db/add-photo (db info)
  (let* ((path (namestring (uiop:subpathp (aget :path info) *photo-storage-path*)))
         (size (aget :length info))
         (taken (local-time:timestamp-to-unix (aget :created-at info)))
         (dim (aget :dim info))
         (w (first dim)) (h (second dim))
         (loc (aget :location info))
         (lat (and loc (geo:latitude-deg loc)))
         (lon (and loc (geo:longitude-deg loc))))
    (sqlite:execute-non-query
     db "insert into photos (path, size, taken, width, height, lat, lon) values (?, ?, ?, ?, ?, ?, ?)"
     path size taken w h lat lon)
    (sqlite:last-insert-rowid db)))

(defun db/add-album (db name &optional description cover-id)
  (sqlite:execute-non-query
   db "insert into albums (name, description, cover_id) values (?, ?, ?)"
   name description cover-id)
  (sqlite:last-insert-rowid db))

(defun db/add-album-photo (db album-id photo-id &optional description idx hidden)
  (sqlite:execute-non-query
   db "insert into album_photos (album_id, photo_id, description, idx, hidden) values (?, ?, ?, ?, ?)"
   album-id photo-id description idx hidden))

(defvar *photo-storage-url* nil "base url for photo storage")
(defun db-load-album (album-id)
  (with-db (db)
    (multiple-value-bind (name cover-id)
        (sqlite:execute-one-row-m-v db "select id, name, cover_id from albums where id = ?" album-id)
      (when name
        (let ((photos (iter (for (id path title w h)
                                 in-sqlite-query "select p.id, p.path, ap.description, p.width, p.height from photos p inner join album_photos ap on ap.photo_id = p.id where ap.album_id = ? order by ap.idx"
                                 on-database db
                                 with-parameters (album-id))
                            (collect (list (cons :id id)
                                           (cons :src (concatenate 'string *photo-storage-url* path))
                                           (cons :title title)
                                           (cons :w w) (cons :h h))))))
          (list (cons :id album-id)
                (cons :title name)
                (cons :cover (find cover-id photos :key (agetter :id)))
                (cons :photos photos)))))))

(defun db-load-albums ()
  (with-db (db)
    (iter (for (id title cover-path cover-w cover-h)
               in-sqlite-query "select a.id, a.name, c.path, c.width, c.height from albums a inner join photos c on a.cover_id=c.id order by c.taken" on-database db)
          (collect (list (cons :id id)
                         (cons :title title)
                         (cons :cover (list (cons :src (concatenate 'string
                                                                    *photo-storage-url* cover-path))
                                            (cons :w cover-w)
                                            (cons :h cover-h))))))))

(defun dirname (directory)
  (car (last (pathname-directory directory))))

(defun guess-album-title (directory photos)
  (declare (ignore photos))
  (dirname directory))

(defvar *album-path-format*
  '(:year "/" :year "-" (:month 2) "-" (:day 2) "-" :name "/"))

(defun guess-album-path (directory photos)
  (let ((from (reduce #'local-time:timestamp-minimum photos :key (agetter :created-at)))
        (format (sublis `((:name . ,(dirname directory)))
                        *album-path-format*)))
    (local-time:format-timestring nil from :format format)))

(defun middle (seq)
  (elt seq (floor (length seq) 2)))

(defun imagep (path)
  (equal (string-downcase (pathname-type path)) "jpg"))

(defun directory-images (directory)
  (remove-if-not 'imagep (uiop:directory-files directory)))

(defun photo-item (info)
  `((:src . ,(map-path (aget :path info)))
    (:path . ,(namestring (aget :path info)))
    (:title . ,(aget :name info))
    (:w . ,(first (aget :dim info)))
    (:h . ,(second (aget :dim info)))))

(defun load-album (directory)
  (let ((photos (mapcar 'load-photo-info (directory-images directory))))
    (when photos
      `((:title . ,(guess-album-title directory photos))
        (:cover . ,(photo-item (middle photos)))
        (:dest . ,(guess-album-path directory photos))
        (:photos . ,(mapcar 'photo-item photos))))))

(defun fs-load-albums (directory)
  (delete nil (list* (load-album directory)
                     (loop for subdir in (uiop:subdirectories directory)
                        append (fs-load-albums subdir)))))

(defvar *path-url-mapping* nil "alist of path-2-url mapping")
(defun map-path (path)
  (loop for (base-path . base-url) in *path-url-mapping*
     for rel-path = (uiop:subpathp path base-path)
     when rel-path do (return (concatenate 'string base-url (namestring rel-path)))
     finally (error "Can't map path ~S" path)))

(defun other-images (directory images)
  (remove-if #'(lambda (img) (member img images :test #'equal))
             (directory-images directory)))

(defun directories (files)
  (delete-duplicates (mapcar #'uiop:pathname-directory-pathname files) :test #'equal))

(defun move-file-to (file dest)
  (let ((destpath (uiop:make-pathname* :defaults file :directory (pathname-directory dest))))
    (when (probe-file destpath)
      (error "File ~S exists" destpath))
    (uiop:rename-file-overwriting-target file destpath)
    destpath))

(defun move-images-with-folders (files dest &optional after-move-func)
  (labels ((move (files dest)
             (dolist (f files)
               (funcall after-move-func (move-file-to f dest)))))
    (let ((dirs (directories files)))
      (unless after-move-func (setf after-move-func #'identity))
      (ensure-directories-exist dest)
      (move files dest)
      ;; Move all non-image files from original folders if no images left there.
      ;; Do not call after-move-func on them
      (setf after-move-func #'identity)
      (dolist (dir dirs)
        (unless (other-images dir files)
          (move (uiop:directory-files dir) dest)
          (ignore-errors (uiop:delete-empty-directory dir)))))))

(defun import-album (name dest paths)
  (let (added-photos
        (files (remove-if-not #'(lambda (p) (uiop:subpathp p *incoming-path*))
                              (mapcar #'probe-file paths))))
    (when files
      (with-db (db)
        (sqlite:with-transaction db
          (labels ((handle-moved (path)
                     (let ((info (load-photo-info path)))
                       (push (cons (db/add-photo db info) (aget :name info)) added-photos)
                       (log:info "Moved" (aget :path info)))))
            (move-images-with-folders files dest #'handle-moved)
            (let ((album-id (db/add-album db name nil (car (middle added-photos)))))
              (loop for (photo-id . name) in (reverse added-photos)
                 for idx from 1
                 do (db/add-album-photo db album-id photo-id name idx))
              album-id)))))))

(restas:define-route main ("")
  (asdf:system-relative-pathname :photo-store "index.html"))

(restas:define-route incoming ("incoming/")
  (asdf:system-relative-pathname :photo-store "incoming.html"))

;; Assets file path
(defparameter *assets-path*
  (asdf:system-relative-pathname :photo-store "assets/"))

(restas:define-route assets/css ("css/:file" :content-type "text/css")  
  (merge-pathnames file *assets-path*))

(restas:define-route assets/js ("js/:file" :content-type "application/x-javascript")
  (merge-pathnames file *assets-path*))

(defun json (object)
  (json:encode-json-to-string object))

(defvar *incoming-path* nil "Path for incoming photos")
(restas:define-route api/incoming ("api/incoming/"
                                   :content-type "application/json")
  (json (fs-load-albums *incoming-path*)))

(restas:define-route api/incoming-import ("api/incoming/import/"
                                          :method :post
                                          :content-type "application/json")
  (let* ((album (json:decode-json-from-string (hunchentoot:raw-post-data :external-format :utf-8)))
         (name (aget :name album))
         (dest (aget :dest album))
         (paths (aget :paths album)))
    (if (uiop:relative-pathname-p dest)
        (let ((new-id (import-album name (uiop:merge-pathnames* dest *photo-storage-path*) paths)))
          (json (db-load-album new-id)))
        400)))

(restas:define-route api/albums ("api/albums/"
                                 :content-type "application/json")
  (json (db-load-albums)))

(restas:define-route api/album ("api/albums/:album-id/"
                                :content-type "application/json")
  (:sift-variables (album-id 'integer))
  (json (db-load-album album-id)))

(defvar *photo-storage-path* nil "Destination storage path")

(defun start (&key (address "0.0.0.0") (port 8800))
  (restas:start '#:photo-store :address address :port port))