Commit abc1e9c1 authored by Eric Timmons's avatar Eric Timmons
Browse files

Fix bug causing multiple syncs to nuke existing data

parent 2a27bc28
Loading
Loading
Loading
Loading
+41 −25
Original line number Diff line number Diff line
@@ -48,6 +48,17 @@
      (when s
        (file-length s)))))

(defun call-with-staging-pathname (thunk pn append-p)
  (uiop:with-staging-pathname (staging-pn pn)
    (when (and append-p (probe-file pn))
      (uiop:copy-file pn staging-pn))
    (funcall thunk staging-pn)))

(defmacro with-staging-pathname ((pn-var &key (pathname-value pn-var)
                                           append-p)
                                 &body body)
  `(call-with-staging-pathname (lambda (,pn-var) ,@body) ,pathname-value ,append-p))

(defmethod index-object-write ((index file-index) path in-stream)
  (let ((pn (merge-pathnames path (file-index-root index))))
    (ensure-directories-exist pn)
@@ -61,18 +72,20 @@
  (when (metadata-dirty-p (metadata index))
    (let ((pn (merge-pathnames "metadata" (file-index-root index))))
      (ensure-directories-exist pn)
      (with-staging-pathname (pn)
        (with-open-file (s pn
                           :direction :output
                           :if-exists :supersede)
        (metadata-write-to-stream index s))))
          (metadata-write-to-stream index s)))))
  (let ((pn (merge-pathnames "index" (file-index-root index))))
    (ensure-directories-exist pn)
    (let ((plist (index-plist index)))
      (with-staging-pathname (pn)
        (with-open-file (s pn
                           :direction :output
                           :if-exists :supersede)
      (let ((plist (index-plist index)))
          (with-clpi-io-syntax ()
          (pprint plist s)))))
            (pprint plist s))))))
  (dolist (p (index-projects index))
    (let ((dirty-p (project-dirty-p p))
          (appendable-p (project-changes-appendable-p p))
@@ -82,28 +95,31 @@
          (incf (project-releases-object-version p)))
        (let ((pn (merge-pathnames (project-releases-path p) (file-index-root index))))
          (ensure-directories-exist pn)
          (with-staging-pathname (pn :append-p appendable-p)
            (with-open-file (s pn
                               :direction :output
                               :if-exists (if appendable-p :append :supersede)
                               :if-does-not-exist :create)
              (if (and appendable-p releases-object-version)
                  (project-write-changes-to-stream p s)
                (project-write-to-stream p s)))))
                  (project-write-to-stream p s))))))
      (when (metadata-dirty-p (metadata p))
        (let ((pn (merge-pathnames (metadata-path p) (file-index-root index))))
          (ensure-directories-exist pn)
          (with-staging-pathname (pn)
            (with-open-file (s pn
                               :direction :output
                               :if-exists :supersede)
            (metadata-write-to-stream p s))))))
              (metadata-write-to-stream p s)))))))
  (dolist (system (index-systems index))
    (when (metadata-dirty-p (metadata system))
      (let ((pn (merge-pathnames (metadata-path system) (file-index-root index))))
        (ensure-directories-exist pn)
        (with-staging-pathname (pn)
          (with-open-file (s pn
                             :direction :output
                             :if-exists :supersede)
          (metadata-write-to-stream system s))))))
            (metadata-write-to-stream system s)))))))

(defmethod open-index-object-stream ((index file-index) path
                                     &key signal-if-older-than