Move folders

photo-store.lisp

@@ -8,9 +8,6 @@
 ;; photos: id | album_id | filename | size | taken | width | height | lat | lon
 ;; albums: id | parent_id | path | date | name | description | cover_id | accessibility
 
-(defun imagep (path)
-  (equal (string-downcase (pathname-type path)) "jpg"))
-
 (defun dirname (directory)
   (car (last (pathname-directory directory))))
 
@@ -30,11 +27,17 @@
 (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 (remove-if-not 'imagep (uiop:directory-files directory)))))
+  (let ((photos (mapcar 'load-photo-info (directory-images directory))))
     (when photos
       (list (cons :title (guess-album-title directory photos))
-            (cons :path (guess-album-path directory photos))
+            (cons :path directory)
             (cons :cover (middle photos))
             (cons :photos photos)))))
 
@@ -50,17 +53,43 @@
      when rel-path do (return (concatenate 'string base-url (namestring rel-path)))
      finally (error "Can't map path ~S" path)))
 
-(defun photo-item (info)
+(defun photo-item (info &optional incoming)
   `((:src . ,(map-path (aget :path info)))
-    (:title . ,(aget :name info))
+    ,@(when incoming (list (cons :path (namestring (aget :path info)))))
     (:w . ,(first (aget :dim info)))
     (:h . ,(second (aget :dim info)))))
 
-(defun album-item (album)
+(defun album-item (album &optional incoming)
   `((:title . ,(aget :title album))
     (:cover . ,(photo-item (aget :cover album)))
-    (:path . ,(namestring (aget :path album)))
-    (:photos . ,(mapcar 'photo-item (aget :photos 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"))
@@ -83,5 +112,7 @@
                                :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))