(in-package #:photo-store) (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 (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 (/ (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 load-album (directory) (let ((photos (mapcar 'load-photo-info (directory-images directory)))) (when photos (list (cons :title (guess-album-title directory photos)) (cons :path directory) (cons :cover (middle photos)) (cons :photos photos))))) (defun load-albums-from-dir (directory) (remove-if #'null (list* (load-album directory) (loop for subdir in (uiop:subdirectories directory) append (load-albums-from-dir 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 photo-item (info &optional incoming) `((:src . ,(map-path (aget :path info))) ,@(when incoming (list (cons :path (namestring (aget :path info))))) (:w . ,(first (aget :dim info))) (:h . ,(second (aget :dim info))))) (defun album-item (album &optional incoming) `((:title . ,(aget :title album)) (:cover . ,(photo-item (aget :cover album))) ,@(when incoming (list (cons :path (namestring (aget :path album))) (cons :dest (guess-album-path (aget :path album) (aget :photos album))))) (:photos . ,(mapcar #'(lambda (p) (photo-item p incoming)) (aget :photos album))))) (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) (uiop:rename-file-overwriting-target file (uiop:make-pathname* :defaults file :directory (pathname-directory dest)))) (defun move-images-with-folders (files dest) (labels ((move (files dest) (dolist (f files) (move-file-to f dest)))) (let ((dirs (directories files))) (ensure-directories-exist dest) (move files dest) ;; Move all non-image files from original folders if no images left there (dolist (dir dirs) (unless (other-images dir files) (move (uiop:directory-files dir) dest) (uiop:delete-empty-directory dir)))))) (restas:define-route main ("") (asdf:system-relative-pathname :photo-store "index.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 incoming ("incoming/" :content-type "application/json") (json (mapcar 'album-item (load-albums-from-dir *incoming-path*)))) (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))